From 934cf98a59ec44e07c455ae64a5c557e8fe619d1 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 17 Jan 2025 03:11:42 +0100 Subject: [PATCH 01/86] Copied lineartwovarequalityanalysis and domain, including tests --- ...earTwoVarEqualityAnalysisPentagon.apron.ml | 31 + ...TwoVarEqualityAnalysisPentagon.no-apron.ml | 3 + ...inearTwoVarEqualityDomainPentagon.apron.ml | 830 ++++++++++++++++++ ...arTwoVarEqualityDomainPentagon.no-apron.ml | 5 + src/dune | 8 + src/goblint_lib.ml | 3 + tests/regression/82-lin2vareq_p/01-loop.c | 23 + .../regression/82-lin2vareq_p/02-iteration.c | 17 + .../82-lin2vareq_p/03-loop_increment.c | 21 + .../04-complicated_expression.c | 24 + tests/regression/82-lin2vareq_p/05-overflow.c | 23 + .../82-lin2vareq_p/06-join-non-constant.c | 25 + .../regression/82-lin2vareq_p/07-coeff_vec.c | 22 + .../82-lin2vareq_p/08-partitioning.c | 39 + .../82-lin2vareq_p/09-loop_relational.c | 22 + .../82-lin2vareq_p/10-linear_loop.c | 21 + .../82-lin2vareq_p/11-overflow_ignored.c | 27 + .../82-lin2vareq_p/12-bounds_guards_ov.c | 19 + .../regression/82-lin2vareq_p/13-meet-tcons.c | 15 + .../82-lin2vareq_p/14-function-call.c | 19 + .../82-lin2vareq_p/15-join_all_cases.c | 31 + .../82-lin2vareq_p/16-sum-of-two-vars.c | 24 + .../82-lin2vareq_p/17-svcomp-signextension.c | 28 + .../regression/82-lin2vareq_p/18-forget_var.c | 16 + .../82-lin2vareq_p/19-cast-to-short.c | 29 + .../82-lin2vareq_p/20-function_call2.c | 21 + .../82-lin2vareq_p/21-global-variables.c | 21 + .../82-lin2vareq_p/22-cast-to-short2.c | 29 + .../82-lin2vareq_p/23-function-return-value.c | 18 + .../82-lin2vareq_p/24-narrowing-on-steroids.c | 29 + .../82-lin2vareq_p/25-different_types.c | 31 + .../82-lin2vareq_p/26-termination-overflow.c | 13 + .../82-lin2vareq_p/27-overflow-unknown.c | 19 + .../82-lin2vareq_p/28-overflow-on-steroids.c | 43 + .../29-meet-tcons-on-steroids.c | 19 + .../82-lin2vareq_p/30-cast-non-int.c | 11 + tests/regression/82-lin2vareq_p/31-careful.c | 22 + .../82-lin2vareq_p/32-divbzero-in-overflow.c | 16 + tests/regression/82-lin2vareq_p/33-dimarray.c | 13 + .../82-lin2vareq_p/34-coefficient-features.c | 62 ++ .../82-lin2vareq_p/36-relations-overflow.c | 24 + tests/regression/82-lin2vareq_p/dune | 10 + 42 files changed, 1726 insertions(+) create mode 100644 src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml create mode 100644 src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.no-apron.ml create mode 100644 src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml create mode 100644 src/cdomains/apron/linearTwoVarEqualityDomainPentagon.no-apron.ml create mode 100644 tests/regression/82-lin2vareq_p/01-loop.c create mode 100644 tests/regression/82-lin2vareq_p/02-iteration.c create mode 100644 tests/regression/82-lin2vareq_p/03-loop_increment.c create mode 100644 tests/regression/82-lin2vareq_p/04-complicated_expression.c create mode 100644 tests/regression/82-lin2vareq_p/05-overflow.c create mode 100644 tests/regression/82-lin2vareq_p/06-join-non-constant.c create mode 100644 tests/regression/82-lin2vareq_p/07-coeff_vec.c create mode 100644 tests/regression/82-lin2vareq_p/08-partitioning.c create mode 100644 tests/regression/82-lin2vareq_p/09-loop_relational.c create mode 100644 tests/regression/82-lin2vareq_p/10-linear_loop.c create mode 100644 tests/regression/82-lin2vareq_p/11-overflow_ignored.c create mode 100644 tests/regression/82-lin2vareq_p/12-bounds_guards_ov.c create mode 100644 tests/regression/82-lin2vareq_p/13-meet-tcons.c create mode 100644 tests/regression/82-lin2vareq_p/14-function-call.c create mode 100644 tests/regression/82-lin2vareq_p/15-join_all_cases.c create mode 100644 tests/regression/82-lin2vareq_p/16-sum-of-two-vars.c create mode 100644 tests/regression/82-lin2vareq_p/17-svcomp-signextension.c create mode 100644 tests/regression/82-lin2vareq_p/18-forget_var.c create mode 100644 tests/regression/82-lin2vareq_p/19-cast-to-short.c create mode 100644 tests/regression/82-lin2vareq_p/20-function_call2.c create mode 100644 tests/regression/82-lin2vareq_p/21-global-variables.c create mode 100644 tests/regression/82-lin2vareq_p/22-cast-to-short2.c create mode 100644 tests/regression/82-lin2vareq_p/23-function-return-value.c create mode 100644 tests/regression/82-lin2vareq_p/24-narrowing-on-steroids.c create mode 100644 tests/regression/82-lin2vareq_p/25-different_types.c create mode 100644 tests/regression/82-lin2vareq_p/26-termination-overflow.c create mode 100644 tests/regression/82-lin2vareq_p/27-overflow-unknown.c create mode 100644 tests/regression/82-lin2vareq_p/28-overflow-on-steroids.c create mode 100644 tests/regression/82-lin2vareq_p/29-meet-tcons-on-steroids.c create mode 100644 tests/regression/82-lin2vareq_p/30-cast-non-int.c create mode 100644 tests/regression/82-lin2vareq_p/31-careful.c create mode 100644 tests/regression/82-lin2vareq_p/32-divbzero-in-overflow.c create mode 100644 tests/regression/82-lin2vareq_p/33-dimarray.c create mode 100644 tests/regression/82-lin2vareq_p/34-coefficient-features.c create mode 100644 tests/regression/82-lin2vareq_p/36-relations-overflow.c create mode 100644 tests/regression/82-lin2vareq_p/dune diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml new file mode 100644 index 0000000000..6b6087de02 --- /dev/null +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -0,0 +1,31 @@ +(** {{!RelationAnalysis} Relational integer value analysis} using an OCaml implementation of the linear two-variable equalities domain ([lin2vareq]). + + @see A. Flexeder, M. Petter, and H. Seidl Fast Interprocedural Linear Two-Variable Equalities. *) + +open Analyses +include RelationAnalysis + +let spec_module: (module MCPSpec) Lazy.t = + lazy ( + let module AD = LinearTwoVarEqualityDomainPentagon.D2 + in + let module Priv = (val RelationPriv.get_priv ()) in + let module Spec = + struct + include SpecFunctor (Priv) (AD) (RelationPrecCompareUtil.DummyUtil) + let name () = "lin2vareq_p" + end + in + (module Spec) + ) + +let get_spec (): (module MCPSpec) = + Lazy.force spec_module + +let after_config () = + let module Spec = (val get_spec ()) in + MCP.register_analysis (module Spec : MCPSpec); + GobConfig.set_string "ana.path_sens[+]" (Spec.name ()) + +let _ = + AfterConfig.register after_config diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.no-apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.no-apron.ml new file mode 100644 index 0000000000..0a444baa9b --- /dev/null +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.no-apron.ml @@ -0,0 +1,3 @@ +(* This analysis is empty on purpose. It serves only as an alternative dependency + in cases where the actual domain can't be used because of a missing library. + It was added because we don't want to fully depend on Apron. *) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml new file mode 100644 index 0000000000..6af7030a51 --- /dev/null +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -0,0 +1,830 @@ +(** OCaml implementation of the linear two-variable equality domain. + + @see A. Flexeder, M. Petter, and H. Seidl Fast Interprocedural Linear Two-Variable Equalities. *) + +(** Abstract states in this domain are represented by structs containing an array and an apron environment. + The arrays are modeled as proposed in the paper: Each variable is assigned to an index and each array element represents a linear relationship that must hold at the corresponding program point. + The apron environment is hereby used to organize the order of columns and variables. +*) + +open Batteries +open GoblintCil +open Pretty +module M = Messages +open GobApron +open VectorMatrix + +module Mpqf = SharedFunctions.Mpqf + +module Rhs = struct + (* Rhs represents coefficient*var_i + offset / divisor + depending on whether coefficient is 0, the monomial term may disappear completely, not refering to any var_i, thus: + (Some (coefficient, i), offset, divisor ) with coefficient != 0 , or + (None , offset, divisor ) *) + type t = ((GobZ.t * int) option * GobZ.t * GobZ.t) [@@deriving eq, ord, hash] + let var_zero i = (Some (Z.one,i), Z.zero, Z.one) + let show_coeff c = + if Z.equal c Z.one then "" + else if Z.equal c Z.minus_one then "-" + else (Z.to_string c) ^"·" + let show_rhs_formatted formatter = let ztostring n = (if Z.(geq n zero) then "+" else "") ^ Z.to_string n in + function + | (Some (coeff,v), o,_) when Z.equal o Z.zero -> Printf.sprintf "%s%s" (show_coeff coeff) (formatter v) + | (Some (coeff,v), o,_) -> Printf.sprintf "%s%s %s" (show_coeff coeff) (formatter v) (ztostring o) + | (None, o,_) -> Printf.sprintf "%s" (Z.to_string o) + let show (v,o,d) = + let rhs=show_rhs_formatted (Printf.sprintf "var_%d") (v,o,d) in + if not (Z.equal d Z.one) then "(" ^ rhs ^ ")/" ^ (Z.to_string d) else rhs + + (** factor out gcd from all terms, i.e. ax=by+c with a positive is the canonical form for adx+bdy+cd *) + let canonicalize (v,o,d) = + let gcd = Z.gcd o d in (* gcd of coefficients *) + let gcd = Option.map_default (fun (c,_) -> Z.gcd c gcd) gcd v in (* include monomial in gcd computation *) + let commondivisor = if Z.(lt d zero) then Z.neg gcd else gcd in (* canonical form dictates d being positive *) + (BatOption.map (fun (coeff,i) -> (Z.div coeff commondivisor,i)) v, Z.div o commondivisor, Z.div d commondivisor) + + (** Substitute rhs for varx in rhs' *) + let subst rhs varx rhs' = + match rhs,rhs' with + | (monom, o, d), (Some (c', x'), o', d') when x'=varx -> canonicalize (Option.map (fun (c,x) -> (Z.mul c c',x)) monom, Z.((o*c')+(d*o')), Z.mul d d') + | _ -> rhs' + +end + +module EqualitiesConjunction = struct + module IntMap = BatMap.Make(Int) + + type t = int * ( Rhs.t IntMap.t ) [@@deriving eq, ord] + + let show_formatted formatter econ = + if IntMap.is_empty econ then "{}" + else + let str = IntMap.fold (fun i (refmonom,off,divi) acc -> Printf.sprintf "%s%s=%s ∧ %s" (Rhs.show_coeff divi) (formatter i) (Rhs.show_rhs_formatted formatter (refmonom,off,divi)) acc) econ "" in + "{" ^ String.sub str 0 (String.length str - 4) ^ "}" + + let show econ = show_formatted (Printf.sprintf "var_%d") econ + + let hash (dim,x) = dim + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Rhs.hash value) x 0 (* TODO: derive *) + + (** creates a domain of dimension 0 *) + let empty () = (0, IntMap.empty) + + (** creates a domain of dimension len without any valid equalities *) + let make_empty_conj len = (len, IntMap.empty) + + (** trivial equalities are of the form var_i = var_i and are not kept explicitely in the sparse representation of EquanlitiesConjunction *) + let nontrivial (_,econmap) lhs = IntMap.mem lhs econmap + + (** turn x = (cy+o)/d into y = (dx-o)/c*) + let inverse x (c,y,o,d) = (y, (Some (d, x), Z.neg o, c)) + + (** sparse implementation of get rhs for lhs, but will default to no mapping for sparse entries *) + let get_rhs (_,econmap) lhs = IntMap.find_default (Rhs.var_zero lhs) lhs econmap + + (** set_rhs, staying loyal to immutable, sparse map underneath; do not attempt any normalization *) + let set_rhs (dim,map) lhs rhs = (dim, + if Rhs.equal rhs Rhs.(var_zero lhs) then + IntMap.remove lhs map + else + IntMap.add lhs rhs map + ) + + (** canonicalize equation, and set_rhs, staying loyal to immutable, sparse map underneath *) + let canonicalize_and_set (dim,map) lhs rhs = set_rhs (dim,map) lhs (Rhs.canonicalize rhs) + + let copy = identity + + + (** add/remove new variables to domain with particular indices; translates old indices to keep consistency + add if op = (+), remove if op = (-) + the semantics of indexes can be retrieved from apron: https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html *) + let modify_variables_in_domain (dim,map) indexes op = + if Array.length indexes = 0 then (dim,map) else + let offsetlist = Array.to_list indexes in + let rec bumpvar delta i = function (* bump the variable i by delta; find delta by counting indices in offsetlist until we reach a larger index then our current parameter *) + | head::rest when i>=head -> bumpvar (delta+1) i rest (* rec call even when =, in order to correctly interpret double bumps *) + | _ (* i op i delta + in + let memobumpvar = (* Memoized version of bumpvar *) + let module IntHash = struct type t = int [@@deriving eq,hash] end in + let module IntHashtbl = Hashtbl.Make (IntHash) in + if (Array.length indexes < 10) then fun x -> bumpvar 0 x offsetlist else (* only do memoization, if dimchange is significant *) + (let h = IntHashtbl.create @@ IntMap.cardinal map in (* #of bindings is a tight upper bound on the number of CCs and thus on the number of different lookups *) + fun x -> (* standard memoization wrapper *) + try IntHashtbl.find h x with Not_found -> + let r = bumpvar 0 x offsetlist in + IntHashtbl.add h x r; + r) + in + let rec bumpentry k (refvar,offset,divi) = function (* directly bumps lhs-variable during a run through indexes, bumping refvar explicitly with a new lookup in indexes *) + + | (tbl,delta,head::rest) when k>=head -> bumpentry k (refvar,offset,divi) (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) + | (tbl,delta,lyst) (* k (IntMap.add (op k delta) (BatOption.map (fun (c,v) -> (c,memobumpvar v)) refvar,offset,divi) tbl, delta, lyst) + in + let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,offsetlist) in (* Build new map during fold with bumped key/vals *) + (op dim (Array.length indexes), a) + + let modify_variables_in_domain m cols op = let res = modify_variables_in_domain m cols op in if M.tracing then + M.tracel "modify_dims" "dimarray bumping with (fun x -> x + %d) at positions [%s] in { %s } -> { %s }" + (op 0 1) + (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) cols "") + (show (snd m)) + (show (snd res)); + res + + (** required by AbstractRelationalDomainRepresentation, true if dimension is zero *) + let is_empty (d,_) = d = 0 + + let is_top_array = GobArray.for_alli (fun i (a, e) -> GobOption.exists ((=) i) a && Z.equal e Z.zero) + + let is_top_con (_,map) = IntMap.is_empty map + + (* Forget information about variable i *) + let forget_variable d var = + let res = + (let ref_var_opt = Tuple3.first (get_rhs d var) in + match ref_var_opt with + | Some (_,ref_var) when ref_var = var -> + if M.tracing then M.trace "forget" "headvar var_%d" var; + (* var is the reference variable of its connected component *) + (let cluster = List.sort (Int.compare) @@ IntMap.fold + (fun i (refe,_,_) l -> BatOption.map_default (fun (coeff,refe) -> if (refe=ref_var) then i::l else l) l refe) (snd d) [] in + if M.tracing then M.trace "forget" "cluster varindices: [%s]" (String.concat ", " (List.map (string_of_int) cluster)); + (* obtain cluster with common reference variable ref_var*) + match cluster with (* new ref_var is taken from head of the cluster *) + | head :: clusterrest -> + (* head: divi*x = coeff*y + offs *) + (* divi*x = coeff*y + offs =inverse=> y =( divi*x - offs)/coeff *) + let (newref,offs,divi) = (get_rhs d head) in + let (coeff,y) = BatOption.get newref in + let (y,yrhs) = inverse head (coeff,y,offs,divi) in (* reassemble yrhs out of components *) + let shifted_cluster = (List.fold (fun map i -> + let irhs = (get_rhs d i) in (* old entry is i = irhs *) + Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) + set_rhs map i + ) d clusterrest) in + set_rhs shifted_cluster head (Rhs.var_zero head) (* finally make sure that head is now trivial *) + | [] -> d) (* empty cluster means no work for us *) + | _ -> d) (* variable is either a constant or expressed by another refvar *) in + let res = (fst res, IntMap.remove var (snd res)) in (* set d(var) to unknown, finally *) + if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show (snd d)) (show (snd res)); + res + + let dim_add (ch: Apron.Dim.change) m = + modify_variables_in_domain m ch.dim (+) + + let dim_add ch m = timing_wrap "dim add" (dim_add ch) m + + let dim_remove (ch: Apron.Dim.change) m = + if Array.length ch.dim = 0 || is_empty m then + m + else ( + let cpy = Array.copy ch.dim in + Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) + let m' = Array.fold_lefti (fun y i x -> forget_variable y (x)) m cpy in (* clear m' from relations concerning ch.dim *) + modify_variables_in_domain m' cpy (-)) + + let dim_remove ch m = VectorMatrix.timing_wrap "dim remove" (fun m -> dim_remove ch m) m + + let dim_remove ch m ~del = let res = dim_remove ch m in if M.tracing then + M.tracel "dim_remove" "dim remove at positions [%s] in { %s } -> { %s }" + (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) ch.dim "") + (show (snd m)) + (show (snd res)); + res + + exception Contradiction + + let meet_with_one_conj ts i (var, offs, divi) = + let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) + let res = + let subst_var (dim,econj) x (vary, o, d) = + (* [[x substby (cy+o)/d ]] ((c'x+o')/d') *) + (* =====> (c'cy + c'o+o'd)/(dd') *) + let adjust = function + | (Some (c',varx), o',d') when varx = x -> + let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) + | e -> e + in + (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + in + (match var, (get_rhs ts i) with + (*| new conj , old conj *) + | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise Contradiction else ts + (* o/d = x_i = (c1*x_h1+o1)/d1 *) + (* ======> x_h1 = (o*d1-o1*d)/(d*c1) /\ x_i = o/d *) + | None , (Some (coeff1,h1), o1, divi1) -> subst_var ts h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) + (* (c*x_j+o)/d = x_i = o1/d1 *) + (* ======> x_j = (o1*d-o*d1)/(d1*c) /\ x_i = o1/d1 *) + | Some (coeff,j), (None , o1, divi1) -> subst_var ts j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) + (* (c*x_j+o)/d = x_i = (c1*x_h1+o1)/d1 *) + (* ======> x_j needs normalization wrt. ts *) + | Some (coeff,j), ((Some (coeff1,h1), o1, divi1) as oldi)-> + (match get_rhs ts j with + (* ts[x_j]=o2/d2 ========> ... *) + | (None , o2, divi2) -> + let newxi = Rhs.subst (None,o2,divi2) j (Some (coeff,j),offs,divi) in + let newxh1 = snd @@ inverse i (coeff1,h1,o1,divi1) in + let newxh1 = Rhs.subst newxi i newxh1 in + subst_var ts h1 newxh1 + (* ts[x_j]=(c2*x_h2+o2)/d2 ========> ... *) + | (Some (coeff2,h2), o2, divi2) as normalizedj -> + if h1 = h2 then (* this is the case where x_i and x_j already where in the same equivalence class; let's see whether the new equality contradicts the old one *) + let normalizedi= Rhs.subst normalizedj j (Some(coeff,j),offs,divi) in + if not @@ Rhs.equal normalizedi oldi then raise Contradiction else ts + else if h1 < h2 (* good, we now unite the two equvalence classes; let's decide upon the representative *) + then (* express h2 in terms of h1: *) + let (_,newh2)= inverse j (coeff2,h2,o2,divi2) in + let newh2 = Rhs.subst oldi i (Rhs.subst (snd @@ inverse i (coeff,j,offs,divi)) j newh2) in + subst_var ts h2 newh2 + else (* express h1 in terms of h2: *) + let (_,newh1)= inverse i (coeff1,h1,o1,divi1) in + let newh1 = Rhs.subst normalizedj j (Rhs.subst (Some(coeff,j),offs,divi) i newh1) in + subst_var ts h1 newh1)) in + if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (snd ts)) i (Rhs.show (var,offs,divi)) (show (snd res)) + ; res + + (** affine transform variable i allover conj with transformer (Some (coeff,i)+offs)/divi *) + let affine_transform econ i (coeff, j, offs, divi) = + if nontrivial econ i then (* i cannot occur on any other rhs apart from itself *) + set_rhs econ i (Rhs.subst (get_rhs econ i) i (Some (coeff,j), offs, divi)) + else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) + (* so now, we transform with the inverse of the transformer: *) + let inv = snd (inverse i (coeff,j,offs,divi)) in + IntMap.fold (fun k v acc -> + match v with + | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) + | _ -> acc + ) (snd econ) econ + +end + +(** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. + Furthermore, it provides the function [simplified_monomials_from_texp] that converts an apron expression into a list of monomials of reference variables and a constant offset *) +module VarManagement = +struct + module EConj = EqualitiesConjunction + include SharedFunctions.VarManagementOps (EConj) + + let dim_add = EConj.dim_add + let size t = BatOption.map_default (fun (d,_) -> d) 0 t.d + + (** Parses a Texpr to obtain a (coefficient, variable) pair list to repr. a sum of a variables that have a coefficient. If variable is None, the coefficient represents a constant offset. *) + let monomials_from_texp (t: t) texp = + let open Apron.Texpr1 in + let exception NotLinearExpr in + let exception ScalarIsInfinity in + let negate coeff_var_list = + List.map (fun (monom, offs, divi) -> Z.(BatOption.map (fun (coeff,i) -> (neg coeff, i)) monom, neg offs, divi)) coeff_var_list in + let multiply_with_Q dividend divisor coeff_var_list = + List.map (fun (monom, offs, divi) -> Rhs.canonicalize Z.(BatOption.map (fun (coeff,i) -> (dividend*coeff,i)) monom, dividend*offs, divi*divisor) ) coeff_var_list in + let multiply a b = + (* if one of them is a constant, then multiply. Otherwise, the expression is not linear *) + match a, b with + | [(None,coeff, divi)], c + | c, [(None,coeff, divi)] -> multiply_with_Q coeff divi c + | _ -> raise NotLinearExpr + in + let rec convert_texpr texp = + begin match texp with + | Cst (Interval _) -> failwith "constant was an interval; this is not supported" + | Cst (Scalar x) -> + begin match SharedFunctions.int_of_scalar ?round:None x with + | Some x -> [(None,x,Z.one)] + | None -> raise ScalarIsInfinity end + | Var x -> + let var_dim = Environment.dim_of_var t.env x in + begin match t.d with + | None -> [(Some (Z.one,var_dim),Z.zero,Z.one)] + | Some d -> + (match (EConj.get_rhs d var_dim) with + | (Some (coeff,i), k,divi) -> [(Some (coeff,i),Z.zero,divi); (None,k,divi)] + | (None, k,divi) -> [ (None,k,divi)]) + end + | Unop (Neg, e, _, _) -> negate (convert_texpr e) + | Unop (Cast, e, _, _) -> convert_texpr e (* Ignore since casts in apron are used for floating point nums and rounding in contrast to CIL casts *) + | Unop (Sqrt, e, _, _) -> raise NotLinearExpr + | Binop (Add, e1, e2, _, _) -> convert_texpr e1 @ convert_texpr e2 + | Binop (Sub, e1, e2, _, _) -> convert_texpr e1 @ negate (convert_texpr e2) + | Binop (Mul, e1, e2, _, _) -> multiply (convert_texpr e1) (convert_texpr e2) + | Binop _ -> raise NotLinearExpr end + in match convert_texpr texp with + | exception NotLinearExpr -> None + | exception ScalarIsInfinity -> None + | x -> Some(x) + + (** convert and simplify (wrt. reference variables) a texpr into a tuple of a list of monomials (coeff,varidx,divi) and a (constant/divi) *) + let simplified_monomials_from_texp (t: t) texp = + BatOption.bind (monomials_from_texp t texp) + (fun monomiallist -> + let d = Option.get t.d in + let module IMap = EConj.IntMap in + let accumulate_constants (exprcache,(aconst,adiv)) (v,offs,divi) = match v with + | None -> let gcdee = Z.gcd adiv divi in exprcache,(Z.(aconst*divi/gcdee + offs*adiv/gcdee),Z.lcm adiv divi) + | Some (coeff,idx) -> let (somevar,someoffs,somedivi)=Rhs.subst (EConj.get_rhs d idx) idx (v,offs,divi) in (* normalize! *) + let newcache = Option.map_default (fun (coef,ter) -> IMap.add ter Q.((IMap.find_default zero ter exprcache) + make coef somedivi) exprcache) exprcache somevar in + let gcdee = Z.gcd adiv divi in + (newcache,(Z.(aconst*divi/gcdee + offs*adiv/gcdee),Z.lcm adiv divi)) + in + let (expr,constant) = List.fold_left accumulate_constants (IMap.empty,(Z.zero,Z.one)) monomiallist in (* abstract simplification of the guard wrt. reference variables *) + Some (IMap.fold (fun v c acc -> if Q.equal c Q.zero then acc else (Q.num c,v,Q.den c)::acc) expr [], constant) ) + + let simplified_monomials_from_texp (t: t) texp = + let res = simplified_monomials_from_texp t texp in + if M.tracing then M.tracel "from_texp" "%s %a -> %s" (EConj.show @@ snd @@ BatOption.get t.d) Texpr1.Expr.pretty texp + (BatOption.map_default (fun (l,(o,d)) -> List.fold_right (fun (a,x,b) acc -> Printf.sprintf "%s*var_%d/%s + %s" (Z.to_string a) x (Z.to_string b) acc) l ((Z.to_string o)^"/"^(Z.to_string d))) "" res); + res + + let simplify_to_ref_and_offset (t: t) texp = + BatOption.bind (simplified_monomials_from_texp t texp ) + (fun (sum_of_terms, (constant,divisor)) -> + (match sum_of_terms with + | [] -> Some (None, constant,divisor) + | [(coeff,var,divi)] -> Some (Rhs.canonicalize (Some (Z.mul divisor coeff,var), Z.mul constant divi,Z.mul divisor divi)) + |_ -> None)) + + let simplify_to_ref_and_offset t texp = timing_wrap "coeff_vec" (simplify_to_ref_and_offset t) texp + + let assign_const t var const divi = match t.d with + | None -> t + | Some t_d -> {d = Some (EConj.set_rhs t_d var (None, const, divi)); env = t.env} + +end + + +module ExpressionBounds: (SharedFunctions.ConvBounds with type t = VarManagement.t) = +struct + include VarManagement + + let bound_texpr t texpr = + if t.d = None then None, None + else + match simplify_to_ref_and_offset t (Texpr1.to_expr texpr) with + | Some (None, offset, divisor) when Z.equal (Z.rem offset divisor) Z.zero -> let res = Z.div offset divisor in + (if M.tracing then M.tracel "bounds" "min: %a max: %a" GobZ.pretty res GobZ.pretty res; + Some res, Some res) + | _ -> None, None + + let bound_texpr d texpr1 = timing_wrap "bounds calculation" (bound_texpr d) texpr1 +end + +module D = +struct + include Printable.Std + include ConvenienceOps (Mpqf) + include VarManagement + + module Bounds = ExpressionBounds + module V = RelationDomain.V + module Arg = struct + let allow_global = true + end + module Convert = SharedFunctions.Convert (V) (Bounds) (Arg) (SharedFunctions.Tracked) + + type var = V.t + + let name () = "lin2vareq" + + let to_yojson _ = failwith "ToDo Implement in future" + + (** t.d is some empty array and env is empty *) + let is_bot t = equal t (bot ()) + + (** forall x_i in env, x_i:=X_i+0 *) + let top_of env = {d = Some (EConj.make_empty_conj (Environment.size env)); env = env} + + (** env = \emptyset, d = Some([||]) *) + let top () = {d = Some (EConj.empty()); env = empty_env} + + (** is_top returns true for top_of array and empty array; precondition: t.env and t.d are of same size *) + let is_top t = GobOption.exists EConj.is_top_con t.d + + let to_subscript i = + let transl = [|"₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"|] in + let rec subscr i = + if i = 0 then "" + else (subscr (i/10)) ^ transl.(i mod 10) in + subscr i + + let show_var env i = + let res = Var.to_string (Environment.var_of_dim env i) in + match String.split_on_char '#' res with + | varname::rest::[] -> varname ^ (try to_subscript @@ int_of_string rest with _ -> "#" ^ rest) + | _ -> res + + (** prints the current variable equalities with resolved variable names *) + let show varM = + match varM.d with + | None -> "⊥\n" + | Some arr when EConj.is_top_con arr -> "⊤\n" + | Some arr -> + if is_bot varM then + "Bot \n" + else + EConj.show_formatted (show_var varM.env) (snd arr) ^ (to_subscript @@ fst arr) + + let pretty () (x:t) = text (show x) + let printXml f x = BatPrintf.fprintf f "\n\n\nequalities\n\n\n%s\n\nenv\n\n\n%a\n\n\n" (XmlUtil.escape (show x)) Environment.printXml x.env + let eval_interval ask = Bounds.bound_texpr + + let meet_with_one_conj t i (var, o, divi) = + match t.d with + | None -> t + | Some d -> + try + { d = Some (EConj.meet_with_one_conj d i (var, o, divi)); env = t.env} + with EConj.Contradiction -> + if M.tracing then M.trace "meet" " -> Contradiction\n"; + { d = None; env = t.env} + + let meet_with_one_conj t i e = + let res = meet_with_one_conj t i e in + if M.tracing then M.tracel "meet" "%s with single eq %s=%s -> %s" (show t) (Z.(to_string @@ Tuple3.third e)^ show_var t.env i) (Rhs.show_rhs_formatted (show_var t.env) e) (show res); + res + + let meet t1 t2 = + let sup_env = Environment.lce t1.env t2.env in + let t1 = change_d t1 sup_env ~add:true ~del:false in + let t2 = change_d t2 sup_env ~add:true ~del:false in + match t1.d, t2.d with + | Some d1', Some d2' -> + EConj.IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + | _ -> {d = None; env = sup_env} + + let meet t1 t2 = + let res = meet t1 t2 in + if M.tracing then M.tracel "meet" "meet a: %s\n U \n b: %s \n -> %s" (show t1) (show t2) (show res) ; + res + + let meet t1 t2 = timing_wrap "meet" (meet t1) t2 + + let leq t1 t2 = + let env_comp = Environment.cmp t1.env t2.env in (* Apron's Environment.cmp has defined return values. *) + let implies ts i (var, offs, divi) = + let tuple_cmp = Tuple3.eq (Option.eq ~eq:(Tuple2.eq (Z.equal) (Int.equal))) (Z.equal) (Z.equal) in + match var with + (* directly compare in case of constant value *) + | None -> tuple_cmp (var, offs, divi) (EConj.get_rhs ts i) + (* normalize in case of a full blown equality *) + | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) + in + if env_comp = -2 || env_comp > 0 then false else + if is_bot_env t1 || is_top t2 then true + else if is_bot_env t2 || is_top t1 then false else + let m1, m2 = Option.get t1.d, Option.get t2.d in + let m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in + EConj.IntMap.for_all (implies m1') (snd m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + + let leq a b = timing_wrap "leq" (leq a) b + + let leq t1 t2 = + let res = leq t1 t2 in + if M.tracing then M.tracel "leq" "leq a: %s b: %s -> %b" (show t1) (show t2) res ; + res + + let join a b = + let join_d ad bd = + (* joinfunction handles the dirty details of performing an "inner join" on the lhs of both bindings; + in the resulting binding, the lhs is then mapped to values that are later relevant for sorting/grouping, i.e. + - lhs itself + - criteria A and B that characterize equivalence class, depending on the reference variable and the affine expression parameters wrt. each EConj + - rhs1 + - rhs2 + however, we have to account for the sparseity of EConj maps by manually patching holes with default values *) + let joinfunction lhs rhs1 rhs2 = + ( + let e = Option.default (Rhs.var_zero lhs) in + match rhs1,rhs2 with (* first of all re-instantiate implicit sparse elements *) + | None, None -> None + | a, b -> Some (e a, e b)) + |> + BatOption.map (fun (r1,r2) -> match (r1,r2) with (* criterion A , criterion B *) + | (Some (c1,_),o1,d1), (Some (c2,_),o2,d2)-> lhs, Q.make Z.((o1*d2)-(o2*d1)) Z.(c1*d2), Q.make Z.(c2*d2) Z.(c1*d1), r1, r2 + | (None, oc,dc), (Some (cv,_),ov,dv) + | (Some (cv,_),ov,dv), (None ,oc,dc)-> lhs, Q.make Z.((oc*dv)-(ov*dc)) Z.(dc*cv), Q.one , r1, r2 (* equivalence class defined by (oc/dc-ov/dv)/(cv/dv) *) + | (None, o1,d1), (None ,o2,d2)-> lhs, (if Z.(zero = ((o1*d2)-(o2*d1))) then Q.one else Q.zero), Q.zero, r1, r2 (* only two equivalence classes: constants with matching values or constants with different values *) + ) + in + let table = List.of_enum @@ EConj.IntMap.values @@ EConj.IntMap.merge joinfunction (snd ad) (snd bd) in + (* compare two variables for grouping depending on affine function parameters a, b and reference variable indices *) + let cmp_z (_, ai, bi, t1i, t2i) (_, aj, bj, t1j, t2j) = + let cmp_ref = Option.compare ~cmp:(fun x y -> Int.compare (snd x) (snd y)) in + Tuple4.compare ~cmp1:cmp_ref ~cmp2:cmp_ref ~cmp3:Q.compare ~cmp4:Q.compare (Tuple3.first t1i, Tuple3.first t2i, ai, bi) (Tuple3.first t1j, Tuple3.first t2j, aj, bj) + in + (* Calculate new components as groups *) + let new_components = BatList.group cmp_z table in + let varentry ci offi ch offh xh = + let (coeff,off,d) = Q.(ci,(offi*ch)-(ci*offh),ch) in (* compute new rhs in Q *) + let (coeff,off,d) = Z.(coeff.num*d.den*off.den,off.num*d.den*coeff.den,d. num*coeff.den*off.den) in (* convert that back into Z *) + Rhs.canonicalize (Some(coeff,xh),off,d) + in + (* ci1 = a*ch1+b /\ ci2 = a*ch2+b *) + (* ===> a = (ci1-ci2)/(ch1-ch2) b = ci2-a*ch2 *) + let constentry ci1 ci2 ch1 ch2 xh = + let a = Q.((ci1-ci2) / (ch1-ch2)) in + let b = Q.(ci2 - a*ch2) in + Rhs.canonicalize (Some (Z.(a.num*b.den),xh),Z.(b.num*a.den) ,Z.(a.den*b.den) ) in + let iterate map l = + match l with + | (_, _, _, rhs , rhs' ) :: t when Rhs.equal rhs rhs' -> List.fold (fun acc (x,_,_,rh,_) -> EConj.set_rhs acc x rh) map l + | (h, _, _, ((Some (ch,_),oh,dh)), ((Some _,_,_) )) :: t -> List.fold (fun acc (i,_,_,(monom,oi,di),_) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t + | (h, _, _, ((Some (ch,_),oh,dh)), ((None,_,_) )) :: t -> List.fold (fun acc (i,_,_,(monom,oi,di),_) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t + | (h, _, _, ((None,_,_) ), ((Some (ch,_),oh,dh))) :: t -> List.fold (fun acc (i,_,_,_,(monom,oi,di)) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t + | (h, _, _, ((None,oh1,dh1) ), ((None),oh2,dh2) ) :: t -> List.fold (fun acc (i,_,_,(_,oi1,di1),(_,oi2,di2)) -> EConj.set_rhs acc i (constentry Q.(make oi1 di1) Q.(make oi2 di2) Q.(make oh1 dh1) Q.(make oh2 dh2) h)) map t + | [] -> let exception EmptyComponent in raise EmptyComponent + in + Some (List.fold iterate (EConj.make_empty_conj @@ fst ad) new_components) + + in + (*Normalize the two domains a and b such that both talk about the same variables*) + match a.d, b.d with + | None, _ -> b + | _, None -> a + | Some x, Some y when is_top a || is_top b -> + let new_env = Environment.lce a.env b.env in + top_of new_env + | Some x, Some y when (Environment.cmp a.env b.env <> 0) -> + let sup_env = Environment.lce a.env b.env in + let mod_x = dim_add (Environment.dimchange a.env sup_env) x in + let mod_y = dim_add (Environment.dimchange b.env sup_env) y in + {d = join_d mod_x mod_y; env = sup_env} + | Some x, Some y when EConj.equal x y -> {d = Some x; env = a.env} + | Some x, Some y -> {d = join_d x y; env = a.env} + + let join a b = timing_wrap "join" (join a) b + + let join a b = + let res = join a b in + if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; + res + + let widen a b = + join a b + + let widen a b = + let res = widen a b in + if M.tracing then M.tracel "widen" "widen a: %s b: %s -> %s" (show a) (show b) (show res) ; + res + + let narrow a b = meet a b + + let narrow a b = + let res = narrow a b in + if M.tracing then M.tracel "narrow" "narrow a: %s b: %s -> %s" (show a) (show b) (show res) ; + res + + let pretty_diff () (x, y) = + dprintf "%s: %a not leq %a" (name ()) pretty x pretty y + + let forget_var t var = + if is_bot_env t || is_top t then t + else + {d = Some (EConj.forget_variable (Option.get t.d) (Environment.dim_of_var t.env var)); env = t.env} + + let forget_vars t vars = + if is_bot_env t || is_top t || List.is_empty vars then + t + else + let newm = List.fold (fun map i -> EConj.forget_variable map (Environment.dim_of_var t.env i)) (Option.get t.d) vars in + {d = Some newm; env = t.env} + + let forget_vars t vars = + let res = forget_vars t vars in + if M.tracing then M.tracel "ops" "forget_vars %s -> %s" (show t) (show res); + res + + let forget_vars t vars = timing_wrap "forget_vars" (forget_vars t) vars + + (** implemented as described on page 10 in the paper about Fast Interprocedural Linear Two-Variable Equalities in the Section "Abstract Effect of Statements" + This makes a copy of the data structure, it doesn't change it in-place. *) + let assign_texpr (t: VarManagement.t) var texp = + match t.d with + | Some d -> + let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in + begin match simplify_to_ref_and_offset t texp with + | None -> + (* Statement "assigned_var = ?" (non-linear assignment) *) + forget_var t var + | Some (None, off, divi) -> + (* Statement "assigned_var = off" (constant assignment) *) + assign_const (forget_var t var) var_i off divi + | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> + (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) + {d=Some (EConj.affine_transform d var_i (coeff_var, var_i, off, divi)); env=t.env } + | Some (Some monomial, off, divi) -> + (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) + meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) + end + | None -> bot_env + + let assign_texpr t var texp = timing_wrap "assign_texpr" (assign_texpr t var) texp + + (* no_ov -> no overflow + if it's true then there is no overflow + -> Convert.texpr1_expr_of_cil_exp handles overflow *) + let assign_exp ask (t: VarManagement.t) var exp (no_ov: bool Lazy.t) = + let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in + match Convert.texpr1_expr_of_cil_exp ask t t.env exp no_ov with + | texp -> assign_texpr t var texp + | exception Convert.Unsupported_CilExp _ -> forget_var t var + + let assign_exp ask t var exp no_ov = + let res = assign_exp ask t var exp no_ov in + if M.tracing then M.tracel "ops" "assign_exp t:\n %s \n var: %a \n exp: %a\n no_ov: %b -> \n %s" + (show t) Var.pretty var d_exp exp (Lazy.force no_ov) (show res); + res + + let assign_var (t: VarManagement.t) v v' = + let t = add_vars t [v; v'] in + assign_texpr t v (Var v') + + let assign_var t v v' = + let res = assign_var t v v' in + if M.tracing then M.tracel "ops" "assign_var t:\n %s \n v: %a \n v': %a\n -> %s" (show t) Var.pretty v Var.pretty v' (show res); + res + + (** Parallel assignment of variables. + First apply the assignments to temporary variables x' and y' to keep the old dependencies of x and y + and in a second round assign x' to x and y' to y + *) + let assign_var_parallel t vv's = + let assigned_vars = List.map fst vv's in + let t = add_vars t assigned_vars in + let primed_vars = List.init (List.length assigned_vars) (fun i -> Var.of_string (Int.to_string i ^"'")) in (* TODO: we use primed vars in analysis, conflict? *) + let t_primed = add_vars t primed_vars in + let multi_t = List.fold_left2 (fun t' v_prime (_,v') -> assign_var t' v_prime v') t_primed primed_vars vv's in + match multi_t.d with + | Some arr when not @@ is_top multi_t -> + let switched_arr = List.fold_left2 (fun multi_t assigned_var primed_var-> assign_var multi_t assigned_var primed_var) multi_t assigned_vars primed_vars in + drop_vars switched_arr primed_vars ~del:true + | _ -> t + + let assign_var_parallel t vv's = + let res = assign_var_parallel t vv's in + if M.tracing then M.tracel "ops" "assign_var parallel: %s -> %s" (show t) (show res); + res + + let assign_var_parallel t vv's = timing_wrap "var_parallel" (assign_var_parallel t) vv's + + let assign_var_parallel_with t vv's = + (* TODO: If we are angling for more performance, this might be a good place ot try. `assign_var_parallel_with` is used whenever a function is entered (body), + in unlock, at sync edges, and when entering multi-threaded mode. *) + let t' = assign_var_parallel t vv's in + t.d <- t'.d; + t.env <- t'.env + + let assign_var_parallel_with t vv's = + if M.tracing then M.tracel "var_parallel" "assign_var parallel'"; + assign_var_parallel_with t vv's + + let assign_var_parallel' t vs1 vs2 = + let vv's = List.combine vs1 vs2 in + assign_var_parallel t vv's + + let assign_var_parallel' t vv's = + let res = assign_var_parallel' t vv's in + if M.tracing then M.tracel "ops" "assign_var parallel'"; + res + + let substitute_exp ask t var exp no_ov = + let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in + let res = assign_exp ask t var exp no_ov in + forget_var res var + + let substitute_exp ask t var exp no_ov = + let res = substitute_exp ask t var exp no_ov in + if M.tracing then M.tracel "ops" "Substitute_expr t: \n %s \n var: %a \n exp: %a \n -> \n %s" (show t) Var.pretty var d_exp exp (show res); + res + + let substitute_exp ask t var exp no_ov = timing_wrap "substitution" (substitute_exp ask t var exp) no_ov + + + (** Assert a constraint expression. + The overflow is completely handled by the flag "no_ov", + which is set in relationAnalysis.ml via the function no_overflow. + In case of a potential overflow, "no_ov" is set to false + and Convert.tcons1_of_cil_exp will raise the exception Unsupported_CilExp Overflow + + meet_tcons -> meet with guard in if statement + texpr -> tree expr (right hand side of equality) + -> expression used to derive tcons -> used to check for overflow + tcons -> tree constraint (expression < 0) + -> does not have types (overflow is type dependent) + *) + let meet_tcons ask t tcons original_expr no_ov = + match t.d with + | None -> t + | Some d -> + match simplified_monomials_from_texp t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with + | None -> t + | Some (sum_of_terms, (constant,divisor)) ->( + match sum_of_terms with + | [] -> (* no reference variables in the guard, so check constant for zero *) + begin match Tcons1.get_typ tcons with + | EQ when Z.equal constant Z.zero -> t + | SUPEQ when Z.geq constant Z.zero -> t + | SUP when Z.gt constant Z.zero -> t + | DISEQ when not @@ Z.equal constant Z.zero -> t + | EQMOD _ -> t + | _ -> bot_env (* all other results are violating the guard *) + end + | [(coeff, index, divi)] -> (* guard has a single reference variable only *) + if Tcons1.get_typ tcons = EQ then + meet_with_one_conj t index (Rhs.canonicalize (None, Z.neg @@ Z.(divi*constant),Z.(coeff*divisor))) + else + t (* only EQ is supported in equality based domains *) + | [(c1,var1,d1); (c2,var2,d2)] -> (* two variables in relation needs a little sorting out *) + begin match Tcons1.get_typ tcons with + | EQ -> (* c1*var1/d1 + c2*var2/d2 +constant/divisor = 0*) + (* ======> c1*divisor*d2 * var1 = -c2*divisor*d1 * var2 +constant*-d1*d2*) + (* \/ c2*divisor*d1 * var2 = -c1*divisor*d2 * var1 +constant*-d1*d2*) + let open Z in + if var1 < var2 then + meet_with_one_conj t var2 (Rhs.canonicalize (Some (neg @@ c1*divisor,var1),neg @@ constant*d2*d1,c2*divisor*d1)) + else + meet_with_one_conj t var1 (Rhs.canonicalize (Some (neg @@ c2*divisor,var2),neg @@ constant*d2*d1,c1*divisor*d2)) + | _-> t (* Not supported in equality based 2vars without coeffiients *) + end + | _ -> t (* For equalities of more then 2 vars we just return t *)) + + let meet_tcons ask t tcons original_expr no_ov = + if M.tracing then M.tracel "meet_tcons" "meet_tcons with expr: %a no_ov:%b" d_exp original_expr (Lazy.force no_ov); + meet_tcons ask t tcons original_expr no_ov + + let meet_tcons t tcons expr = timing_wrap "meet_tcons" (meet_tcons t tcons) expr + + let unify a b = + meet a b + + let unify a b = + let res = unify a b in + if M.tracing then M.tracel "ops" "unify: %s\n U\n %s -> %s" (show a) (show b) (show res); + res + + (** Assert a constraint expression. Defined in apronDomain.apron.ml + + If the constraint is never fulfilled, then return bottom. + Else the domain can be modified with the new information given by the constraint. + + It basically just calls the function meet_tcons. + + It is called by eval (defined in sharedFunctions), but also when a guard in + e.g. an if statement is encountered in the C code. + + *) + let assert_constraint ask d e negate (no_ov: bool Lazy.t) = + match Convert.tcons1_of_cil_exp ask d d.env e negate no_ov with + | tcons1 -> meet_tcons ask d tcons1 e no_ov + | exception Convert.Unsupported_CilExp _ -> d + + let assert_constraint ask d e negate no_ov = timing_wrap "assert_constraint" (assert_constraint ask d e negate) no_ov + + let relift t = t + + (** representation as C expression + + This function returns all the equalities that are saved in our datastructure t. + + Lincons -> linear constraint *) + let invariant t = + let of_coeff xi coeffs o = + let typ = (Option.get @@ V.to_cil_varinfo xi).vtype in + let ikind = Cilfacade.get_ikind typ in + let cst = Coeff.s_of_z (IntDomain.Size.cast ikind o) in + let lincons = Lincons1.make (Linexpr1.make t.env) Lincons1.EQ in + Lincons1.set_list lincons coeffs (Some cst); + lincons + in + let get_const acc i = function + | (None, o, d) -> + let xi = Environment.var_of_dim t.env i in + of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi)] o :: acc + | (Some (c,r), _,_) when r = i -> acc + | (Some (c,r), o, d) -> + let xi = Environment.var_of_dim t.env i in + let ri = Environment.var_of_dim t.env r in + of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi); (GobApron.Coeff.s_of_z c, ri)] o :: acc + in + BatOption.get t.d |> fun (_,map) -> EConj.IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + + let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 + + let env t = t.env + + type marshal = t + (* marshal is not compatible with apron, therefore we don't have to implement it *) + let marshal t = t + + let unmarshal t = t + +end + +module D2: RelationDomain.RD with type var = Var.t = +struct + module D = D + module ConvArg = struct + let allow_global = false + end + include SharedFunctions.AssertionModule (D.V) (D) (ConvArg) + include D +end diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.no-apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.no-apron.ml new file mode 100644 index 0000000000..5fed2c883c --- /dev/null +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.no-apron.ml @@ -0,0 +1,5 @@ +(* This domain is empty on purpose. It serves only as an alternative dependency + in cases where the actual domain can't be used because of a missing library. + It was added because we don't want to fully depend on Apron. *) + +let reset_lazy () = () diff --git a/src/dune b/src/dune index 10996e7ee8..d11d7ad3da 100644 --- a/src/dune +++ b/src/dune @@ -43,6 +43,14 @@ (apron -> linearTwoVarEqualityDomain.apron.ml) (-> linearTwoVarEqualityDomain.no-apron.ml) ) + (select linearTwoVarEqualityAnalysisPentagon.ml from + (apron -> linearTwoVarEqualityAnalysisPentagon.apron.ml) + (-> linearTwoVarEqualityAnalysisPentagon.no-apron.ml) + ) + (select linearTwoVarEqualityDomainPentagon.ml from + (apron -> linearTwoVarEqualityDomainPentagon.apron.ml) + (-> linearTwoVarEqualityDomainPentagon.no-apron.ml) + ) (select relationAnalysis.ml from (apron -> relationAnalysis.apron.ml) (-> relationAnalysis.no-apron.ml) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 415fb21605..a13d6c9120 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -79,6 +79,7 @@ module RelationAnalysis = RelationAnalysis module ApronAnalysis = ApronAnalysis module AffineEqualityAnalysis = AffineEqualityAnalysis module LinearTwoVarEqualityAnalysis = LinearTwoVarEqualityAnalysis +module LinearTwoVarEqualityAnalysisPentagon = LinearTwoVarEqualityAnalysisPentagon module VarEq = VarEq module CondVars = CondVars module TmpSpecial = TmpSpecial @@ -261,6 +262,8 @@ module RelationDomain = RelationDomain module ApronDomain = ApronDomain module AffineEqualityDomain = AffineEqualityDomain module LinearTwoVarEqualityDomain = LinearTwoVarEqualityDomain +module LinearTwoVarEqualityDomainPentagon = LinearTwoVarEqualityDomainPentagon + (** {3 Concurrency} *) diff --git a/tests/regression/82-lin2vareq_p/01-loop.c b/tests/regression/82-lin2vareq_p/01-loop.c new file mode 100644 index 0000000000..c55215c998 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/01-loop.c @@ -0,0 +1,23 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +// Adapted example from https://link.springer.com/content/pdf/10.1007/BF00268497.pdf + +#include + +void main(void) { + int i; + int j; + int k; + if(k > 200){ + return 0; + } + j = k + 5; + + while (j < 100) { + __goblint_check(j - k == 5); //SUCCESS + j = j + 3; + k = k + 3; + } + __goblint_check(j - k == 5); //SUCCESS + +} diff --git a/tests/regression/82-lin2vareq_p/02-iteration.c b/tests/regression/82-lin2vareq_p/02-iteration.c new file mode 100644 index 0000000000..838034646b --- /dev/null +++ b/tests/regression/82-lin2vareq_p/02-iteration.c @@ -0,0 +1,17 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p +#include + +int main() { + int i, j; + int size = 5; + + for (i = 0; i < size; ++i) { + j = i; + + __goblint_check(i == j); //SUCCESS + } + + return 0; +} + +//This test case checks whether the value of variable i is always equal to the value of variable j within the loop. diff --git a/tests/regression/82-lin2vareq_p/03-loop_increment.c b/tests/regression/82-lin2vareq_p/03-loop_increment.c new file mode 100644 index 0000000000..7ed6adef9e --- /dev/null +++ b/tests/regression/82-lin2vareq_p/03-loop_increment.c @@ -0,0 +1,21 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +#include + +int main() { + int i, j, k; + int size = 5; + i = 0; + j = 0; + k = 5; + + for (i = 1; i < size; ++i) { + j = i; + k = j + 5; + } + + __goblint_check(j + 1 == i); // SUCCESS + + __goblint_check(k == i + 4); // SUCCESS + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/04-complicated_expression.c b/tests/regression/82-lin2vareq_p/04-complicated_expression.c new file mode 100644 index 0000000000..ebe41061e5 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/04-complicated_expression.c @@ -0,0 +1,24 @@ +// SKIP PARAM: --set sem.int.signed_overflow assume_none --set ana.int.enums false --set ana.int.interval false --set ana.int.interval_set false --set ana.int.congruence false --set ana.activated[+] lin2vareq_p + +#include +#include + + +int main() { + int x; + int k; + if (x < 300 && k < 300) { + int y = 5; + + int result1 = 3 * (x + y) - 2 * x + 6; + int result2 = 3 * (x + y) - 2 * k + 6; + int result3 = x * 3 - x * 2; + int result4 = x * 3 - x * k * x; + + __goblint_check(result1 == x + 21); // SUCCESS + __goblint_check(result2 == x + 21); // UNKNOWN! + __goblint_check(result3 == x); // SUCCES + __goblint_check(result4 == x * 3 - x * k * x); // UNKNOWN + } + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/05-overflow.c b/tests/regression/82-lin2vareq_p/05-overflow.c new file mode 100644 index 0000000000..aef5f04b6c --- /dev/null +++ b/tests/regression/82-lin2vareq_p/05-overflow.c @@ -0,0 +1,23 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p + +#include + +int main() { + int x; + int k; + int y; + + x = k + 1; + //there might be an overflow + __goblint_check(x == k + 1); // UNKNOWN! + + int unknown; + + if (unknown < 300 && unknown > 0) { + x = unknown; + // an overflow is not possible + __goblint_check(x == unknown); // SUCCESS + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/06-join-non-constant.c b/tests/regression/82-lin2vareq_p/06-join-non-constant.c new file mode 100644 index 0000000000..bd1bf20d38 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/06-join-non-constant.c @@ -0,0 +1,25 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +#include + +int main(void) { + int a, b, c, d; + + int t; + + if (t) { + b = a + 2; + c = a + 7; + d = a + 1; + } else { + b = a + 30; + c = a + 35; + d = a + 10; + } + __goblint_check(c == b + 5); // SUCCESS + __goblint_check(c == b + 3); // FAILURE + __goblint_check(d == b - 1); // UNKNOWN! + __goblint_check(b == a + 2); // UNKNOWN! + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/07-coeff_vec.c b/tests/regression/82-lin2vareq_p/07-coeff_vec.c new file mode 100644 index 0000000000..06a1bfdc7d --- /dev/null +++ b/tests/regression/82-lin2vareq_p/07-coeff_vec.c @@ -0,0 +1,22 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p +// This was problematic earlier where both branches were dead with lin2vareq +// Thus worth having even if it can be answered by base alone +int main() { + + unsigned int a = 1; + + unsigned int b = -a; + + __goblint_check(b == 4294967295); + + unsigned short int allbits = -1; + + short int signedallbits = allbits; + + __goblint_check(signedallbits == -1); + + short c = 32767; + c = c + 2; + + __goblint_check(c == -32767); +} diff --git a/tests/regression/82-lin2vareq_p/08-partitioning.c b/tests/regression/82-lin2vareq_p/08-partitioning.c new file mode 100644 index 0000000000..b6a8b1025c --- /dev/null +++ b/tests/regression/82-lin2vareq_p/08-partitioning.c @@ -0,0 +1,39 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// example from https://dl.acm.org/doi/10.1145/2049706.2049710 + +#include +#include +#include + +int main() { + + int x, x1, x2, x3, x4, x5, x6, x7; + + if (x1 > INT_MAX - 5 || x2 > INT_MAX - 5 || x2 > INT_MIN + 5) { + return -1; + } + + if (x > 5) { + x1 = x1; + x2 = x2; + x3 = x1; + x4 = x2 + 5; + x5 = x1 + 5; + x6 = x1 + 3; + x7 = x1 + 2; + } else { + x1 = x1; + x2 = x2; + x3 = x2 - 5; + x4 = x2 + 5; + x5 = x2; + x6 = x2 + 1; + x7 = x2; + } + + __goblint_check(x4 == x2 + 5); // SUCCESS + __goblint_check(x5 == x3 + 5); // SUCCESS + __goblint_check(x7 == x6 - 1); // SUCCESS + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/09-loop_relational.c b/tests/regression/82-lin2vareq_p/09-loop_relational.c new file mode 100644 index 0000000000..dcdcfd8cb2 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/09-loop_relational.c @@ -0,0 +1,22 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + + +#include +#include + +int main() { + int x = 0; + int y = 10; + int z = 5; + + for (int i = 0; i < 3; i++) { + x = z; + y = i; + __goblint_check(x == z); // SUCCESS + z = 2; + __goblint_check(y == i); // SUCCESS + __goblint_check(z == 2); // SUCCESS + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/10-linear_loop.c b/tests/regression/82-lin2vareq_p/10-linear_loop.c new file mode 100644 index 0000000000..75df99d858 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/10-linear_loop.c @@ -0,0 +1,21 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +#include +#include + +int main() { + int x = 1; + int y = 1; + int z = 1; + int k; + + for (int i = 1; i <= 3; i++) { + x = x * i; + y = x; + z = y + (y - x) + 2; + __goblint_check(x == y); // SUCCESS + __goblint_check(z == y + 2); // SUCCESS + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/11-overflow_ignored.c b/tests/regression/82-lin2vareq_p/11-overflow_ignored.c new file mode 100644 index 0000000000..4e14c8aed2 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/11-overflow_ignored.c @@ -0,0 +1,27 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +#include +#include + +int main() { + int x; + int k; + int y; + + if (k > INT_MAX - 8) { + printf("Potential overflow detected.\n"); + return -1; + } + + x = k + 1; + __goblint_check(x == k + 1); // SUCCESS + + for (int i = 0; i < 7; i++) { + x++; + k++; + } + + __goblint_check(x == k + 1); // SUCCESS + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/12-bounds_guards_ov.c b/tests/regression/82-lin2vareq_p/12-bounds_guards_ov.c new file mode 100644 index 0000000000..350b8a23ce --- /dev/null +++ b/tests/regression/82-lin2vareq_p/12-bounds_guards_ov.c @@ -0,0 +1,19 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p +// same test as 63-affeq/10-bounds_guards.ov.c + +int main() { + int x, y; + int p = 0; + + if (x - 2 == __INT32_MAX__) { + __goblint_check(x == __INT32_MAX__ + 2); //UNKNOWN! + p = 1; + } + + __goblint_check(p == 0); //UNKNOWN! + + if (x + y == __INT32_MAX__) { + __goblint_check(1); + } + +} diff --git a/tests/regression/82-lin2vareq_p/13-meet-tcons.c b/tests/regression/82-lin2vareq_p/13-meet-tcons.c new file mode 100644 index 0000000000..b612acbfbd --- /dev/null +++ b/tests/regression/82-lin2vareq_p/13-meet-tcons.c @@ -0,0 +1,15 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + + +int main(void) { + int x, y, z; + + if (x == 0) { + __goblint_check(x == 0); // SUCCESS + } else if (y - x == 3) { + __goblint_check(y == x + 0); // FAILURE + __goblint_check(y - x == 3); // SUCCESS + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/14-function-call.c b/tests/regression/82-lin2vareq_p/14-function-call.c new file mode 100644 index 0000000000..ec4867875b --- /dev/null +++ b/tests/regression/82-lin2vareq_p/14-function-call.c @@ -0,0 +1,19 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + + +int myfunction(int x, int y){ + if (x == 0) { + __goblint_check(x == 0); // SUCCESS + } else if (y - x == 3) { + __goblint_check(y == x + 0); // FAILURE + __goblint_check(y - x == 3); // SUCCESS + } + + return 5; +} + +int main(void) { + int x, y, z; + z = myfunction(x,y); + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/15-join_all_cases.c b/tests/regression/82-lin2vareq_p/15-join_all_cases.c new file mode 100644 index 0000000000..b6a05e3e93 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/15-join_all_cases.c @@ -0,0 +1,31 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set ana.relation.privatization top --set sem.int.signed_overflow assume_none + +void main(void) { + int x1, x2, x3, x4, x5, x6, x7, x8, x9; + int t; + if (x6 < 300 && x6 > -300) { + if (t) { + x2 = 2; + x1 = 3; + x3 = 4; + x4 = 5; + x5 = x6 + 6; + x7 = x6 + 3; + x8 = x6 - 55; + } else { + x1 = 3; + x2 = 3; + x3 = 4; + x4 = 5; + x5 = x6 + 11; + x7 = x6 + 8; + x8 = x6 - 50; + } + __goblint_check(x1 == 3); + __goblint_check(x2 == 2); // UNKNOWN! + __goblint_check(x3 == 4); + __goblint_check(x4 == 5); + __goblint_check(x7 == x5 - 3); + __goblint_check(x8 == x7 - 58); + } +} diff --git a/tests/regression/82-lin2vareq_p/16-sum-of-two-vars.c b/tests/regression/82-lin2vareq_p/16-sum-of-two-vars.c new file mode 100644 index 0000000000..13f25ca581 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/16-sum-of-two-vars.c @@ -0,0 +1,24 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + + +#include + +int main() { + int x, y, z, w, k; + + z = y; + x = y; + w = y; + + __goblint_check(z == 2 * x - y); // SUCCESS + + k = z + w - x + 5; + + __goblint_check(k == y + 5); //SUCCESS + + y = 3; + __goblint_check(k == y + 5); // UNKNOWN! + + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/17-svcomp-signextension.c b/tests/regression/82-lin2vareq_p/17-svcomp-signextension.c new file mode 100644 index 0000000000..f6b3f6103e --- /dev/null +++ b/tests/regression/82-lin2vareq_p/17-svcomp-signextension.c @@ -0,0 +1,28 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// This was problematic earlier where we were unsound with lin2vareq +// Thus worth having even if it can be answered by base alone + +#include +int main() { + + unsigned short int allbits = -1; + short int signedallbits = allbits; + int unsignedtosigned = allbits; + unsigned int unsignedtounsigned = allbits; + int signedtosigned = signedallbits; + unsigned int signedtounsigned = signedallbits; + + /* + printf ("unsignedtosigned: %d\n", unsignedtosigned); + printf ("unsignedtounsigned: %u\n", unsignedtounsigned); + printf ("signedtosigned: %d\n", signedtosigned); + printf ("signedtounsigned: %u\n", signedtounsigned); + */ + + if (signedtounsigned == 4294967295) { + __goblint_check(1); // reachable + return (-1); + } +__goblint_check(0); // NOWARN (unreachable) + return (0); +} diff --git a/tests/regression/82-lin2vareq_p/18-forget_var.c b/tests/regression/82-lin2vareq_p/18-forget_var.c new file mode 100644 index 0000000000..6f18ac6b5d --- /dev/null +++ b/tests/regression/82-lin2vareq_p/18-forget_var.c @@ -0,0 +1,16 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +#include + +int main() { + int x, y, z; + + z = x; + + __goblint_check(z == x); // SUCCESS + + x = y * y; + + __goblint_check(x == z); // UNKNOWN! + + return 0; +} \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/19-cast-to-short.c b/tests/regression/82-lin2vareq_p/19-cast-to-short.c new file mode 100644 index 0000000000..65601943f0 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/19-cast-to-short.c @@ -0,0 +1,29 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// This was problematic earlier where we were unsound with lin2vareq +// Thus worth having even if it can be answered by base alone + +#include +int main() { + + unsigned int allbits = -1; + int signedallbits = allbits; + short unsignedtosigned = allbits; + unsigned short unsignedtounsigned = allbits; + +// printf("allbits: %u\n", allbits); +// printf("signedallbits: %d\n", signedallbits); +// printf("unsignedtosigned: %hd\n", unsignedtosigned); +// printf("unsignedtounsigned: %hu\n", unsignedtounsigned); + + if (unsignedtounsigned == 4294967295) { + __goblint_check(0); // NOWARN (unreachable) + return (-1); + } + if (allbits == 4294967295 && signedallbits == -1 && unsignedtosigned == -1 && + unsignedtounsigned == 65535) { + __goblint_check(1); // reachable + return (-1); + } + __goblint_check(0); // NOWARN (unreachable) + return (0); +} diff --git a/tests/regression/82-lin2vareq_p/20-function_call2.c b/tests/regression/82-lin2vareq_p/20-function_call2.c new file mode 100644 index 0000000000..653051dbe4 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/20-function_call2.c @@ -0,0 +1,21 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +#include + +int check_equal(int x, int y, int z) { + __goblint_check(x == y); + __goblint_check(z == y); + __goblint_check(x == z); + return 8; +} + +int main(void) { + int x, y, z; + + y = x; + z = y; + + check_equal(x, y, z); + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/21-global-variables.c b/tests/regression/82-lin2vareq_p/21-global-variables.c new file mode 100644 index 0000000000..daadd96f29 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/21-global-variables.c @@ -0,0 +1,21 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +#include +#include + +int x; +int y; + +void setY() { y = x + 3; } + +int main() { + int k; + x = k * k; + + if (x < INT_MAX - 3) { + setY(); + + __goblint_check(y == x + 3); // SUCCESS + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/22-cast-to-short2.c b/tests/regression/82-lin2vareq_p/22-cast-to-short2.c new file mode 100644 index 0000000000..79081e073a --- /dev/null +++ b/tests/regression/82-lin2vareq_p/22-cast-to-short2.c @@ -0,0 +1,29 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// This was problematic earlier where both branches were dead with lin2vareq +// Thus worth having even if it can be answered by base alone + +#include +int main() { + + unsigned int allbits = -255 - 25; // choose a value which is not representable in short + int signedallbits = allbits; + short unsignedtosigned = allbits; + unsigned short unsignedtounsigned = allbits; + + printf("allbits: %u\n", allbits); + printf("signedallbits: %d\n", signedallbits); + printf("unsignedtosigned: %hd\n", unsignedtosigned); + printf("unsignedtounsigned: %hu\n", unsignedtounsigned); + + if (unsignedtounsigned == 4294967295) { + __goblint_check(0); // NOWARN (unreachable) + return (-1); + } + if (allbits == 4294967295 && signedallbits == -1 && unsignedtosigned == -1 && + unsignedtounsigned == 65535) { + __goblint_check(0); // NOWARN (unreachable) + return (-1); + } + + return (0); +} diff --git a/tests/regression/82-lin2vareq_p/23-function-return-value.c b/tests/regression/82-lin2vareq_p/23-function-return-value.c new file mode 100644 index 0000000000..60f070aff8 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/23-function-return-value.c @@ -0,0 +1,18 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +#include + +int k; + +int x_plus_three(int x) { + return x + 3; +} + +int main(void) { + int y, z; + z = x_plus_three(k); + + __goblint_check(z == k + 3); + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/24-narrowing-on-steroids.c b/tests/regression/82-lin2vareq_p/24-narrowing-on-steroids.c new file mode 100644 index 0000000000..f7592898a3 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/24-narrowing-on-steroids.c @@ -0,0 +1,29 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --enable ana.int.interval --set solver slr3tp +#include + +int main() { + short a; + a = a % 10; + int b; + int c; + b = a + 1; + c = a + 2; + int x, g; + + for(x=0; x < 50; x++){ + g = 1; + } + b = a + x; + + // x = [50, 50] after narrow + if(b - a > 50){ // live after widen, but dead after narrow + // node after Pos(x>50) is marked dead at the end + // but the loop is not with x = [51,2147483647] + for(int i=0; i<=0 && i > -1000; i--){ + b = 8; + } + assert(1); // NOWARN (unreachable) + } + __goblint_check(b == c + 48); + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/25-different_types.c b/tests/regression/82-lin2vareq_p/25-different_types.c new file mode 100644 index 0000000000..bfecec61f4 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/25-different_types.c @@ -0,0 +1,31 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p +#include + +int x = 42; +long y; +short z; + +int main() { + + y = (long)x; + z = (short)x; + + int a = (int)y; + short b = (short)y; + + int c = (int)z; + long d = (long)z; + + unsigned int u1 = (unsigned int)x; + unsigned long u2 = (unsigned long)y; + unsigned short u3 = (unsigned short)z; + + __goblint_check(x == a); + __goblint_check(x == c); + __goblint_check(y == d); + __goblint_check(x == (int)u1); + __goblint_check(y == (long)u2); + __goblint_check(z == (short)u3); + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/26-termination-overflow.c b/tests/regression/82-lin2vareq_p/26-termination-overflow.c new file mode 100644 index 0000000000..a1103c9be7 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/26-termination-overflow.c @@ -0,0 +1,13 @@ +// SKIP TERM PARAM: --set "ana.activated[+]" lin2vareq_p + +#include + +int main() { + int i = 2147483647; + i++; + while (i <= 10) { + printf("%d\n", i); + } + + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/27-overflow-unknown.c b/tests/regression/82-lin2vareq_p/27-overflow-unknown.c new file mode 100644 index 0000000000..475be3746c --- /dev/null +++ b/tests/regression/82-lin2vareq_p/27-overflow-unknown.c @@ -0,0 +1,19 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p +#include +#include + +int main(void) { + int x = 10; + + if (x + 2147483647 == 2147483657) { + return 0; + } + + __goblint_check(1); + + // Overflow + int c = 2147483647; + c = c + 1; + + __goblint_check(c < 2147483647); // UNKNOWN! +} diff --git a/tests/regression/82-lin2vareq_p/28-overflow-on-steroids.c b/tests/regression/82-lin2vareq_p/28-overflow-on-steroids.c new file mode 100644 index 0000000000..ee99b27240 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/28-overflow-on-steroids.c @@ -0,0 +1,43 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --enable ana.int.interval +#include + +int main(void) { + int b; + int a; + int c; // c is an unknown value + a = a % 8; // a is in the interval [-7, 7] + + b = c; // no overflow + __goblint_check(b == c);// SUCCESS + + b = c * 1; // no overflow + __goblint_check(b == c);// SUCCESS + + b = c ? c : c; // no overflow + __goblint_check(b == c);// SUCCESS + + b = a + 2; // no overflow + __goblint_check(b == a + 2);// SUCCESS + + b = c + 2; // might overflow + __goblint_check(b == c + 2);// UNKNOWN! + + b = a - 2; // no overflow + __goblint_check(b == a - 2);// SUCCESS + + b = c - 2; // might overflow + __goblint_check(b == c - 2);// UNKNOWN! + + b = a * 2 - a * 1; // no overflow + __goblint_check(b == a);// SUCCESS + + b = c * 2 - c * 1; // might overflow + __goblint_check(b == c); // UNKNOWN! + + b = (-a) + a; // no overflow + __goblint_check(b == 0); // SUCCESS + + b = (-c) + c; // might overflow + __goblint_check(b == 0); // UNKNOWN! + +} diff --git a/tests/regression/82-lin2vareq_p/29-meet-tcons-on-steroids.c b/tests/regression/82-lin2vareq_p/29-meet-tcons-on-steroids.c new file mode 100644 index 0000000000..ccdb955fb6 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/29-meet-tcons-on-steroids.c @@ -0,0 +1,19 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --enable ana.int.interval +#include + +int main(void) { + short b; + short a; + int c = a; + int d = b; + int cc = c + 20; + int dd = d - 30; + a = 3 * 1543; + if (a*(c - cc) == a*(d -dd - 50)){ + __goblint_check(1);// (reachable) + return 0; + }else{ + __goblint_check(0);// NOWARN (unreachable) + return -1; + } +} diff --git a/tests/regression/82-lin2vareq_p/30-cast-non-int.c b/tests/regression/82-lin2vareq_p/30-cast-non-int.c new file mode 100644 index 0000000000..6657d86ff1 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/30-cast-non-int.c @@ -0,0 +1,11 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +#include +//#include +int main(void) { + float b = 2.5; + float a = 1.5; + int c = (int) a; + int d = (int) b; + //printf("c: %d\nd: %d\n", c, d); + __goblint_check(d -c -1 == 0); // UNKNOWN +} diff --git a/tests/regression/82-lin2vareq_p/31-careful.c b/tests/regression/82-lin2vareq_p/31-careful.c new file mode 100644 index 0000000000..b83c7bc147 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/31-careful.c @@ -0,0 +1,22 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p --enable ana.int.interval +#include +#include + +int main(void) { + int top; + unsigned int i; + unsigned int j; + + if(top) { + i = 3; + j = i + UINT_MAX; + } else { + i = 2; + j = i + UINT_MAX; + } + + + // Both hold in the concrete + __goblint_check(j == i-1); //UNKNOWN + __goblint_check(j == i + UINT_MAX); //UNKNOWN +} diff --git a/tests/regression/82-lin2vareq_p/32-divbzero-in-overflow.c b/tests/regression/82-lin2vareq_p/32-divbzero-in-overflow.c new file mode 100644 index 0000000000..5d13057099 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/32-divbzero-in-overflow.c @@ -0,0 +1,16 @@ +// SKIP PARAM: --set ana.activated[+] lin2vareq_p + +/** + * This test shows an instance where MaySignedOverflow raised + * an uncaught division by zero in the treatment of main's sole statement + * + * Fixed in #1419 + */ +int a; +char b; +int main() +{ + 0 == a && 1 / b; + __goblint_check(1); // (reachable) + return 0; +} diff --git a/tests/regression/82-lin2vareq_p/33-dimarray.c b/tests/regression/82-lin2vareq_p/33-dimarray.c new file mode 100644 index 0000000000..8b48d2f3b6 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/33-dimarray.c @@ -0,0 +1,13 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// special input triggering add_dimarray of [0,0] at line 10; visible via --trace modify_dims +// both occurances of variables need to be bumped/shifted by 2 indices +// in our case, d = c still needs to hold +#include +int a; +b() {} +void main() { + int c; + int d = c; + b(); + __goblint_check(d == c); //SUCCESS +} diff --git a/tests/regression/82-lin2vareq_p/34-coefficient-features.c b/tests/regression/82-lin2vareq_p/34-coefficient-features.c new file mode 100644 index 0000000000..1f1fe82d4f --- /dev/null +++ b/tests/regression/82-lin2vareq_p/34-coefficient-features.c @@ -0,0 +1,62 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none +// this test checks basic coefficient handing in main and join capabilities in loop + +#include + +void loop() { + int random; + int i = 0; + int x = 0; + int y = 0; + + x=x+4; + y=y+8; + i=i+1; + + if (random) { + x=x+4; + y=y+8; + i=i+1; + } + + __goblint_check(x == 4*i); //SUCCESS + + x=0; + y=0; + + for(i = 1; i < 100; i++) { + x=x+4; + y=y+8; + + __goblint_check(y == 2*x); //SUCCESS + __goblint_check(x == 4*i); //SUCCESS + } +} + +void main() { + int a; + int b; + int c; + int unknown; + a = 4; + + b = 4*c; + + __goblint_check(b == 4*c); //SUCCESS + + b = a*c; + + __goblint_check(b == 4*c); //SUCCESS + + if (7*b == 20*unknown + a){ + + __goblint_check(7*b == 20*unknown + a); //SUCCESS + } + + b = unknown ? a*c : 4*c; + + __goblint_check(b == 4*c); //SUCCESS + + loop(); + +} \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/36-relations-overflow.c b/tests/regression/82-lin2vareq_p/36-relations-overflow.c new file mode 100644 index 0000000000..91cf369ebc --- /dev/null +++ b/tests/regression/82-lin2vareq_p/36-relations-overflow.c @@ -0,0 +1,24 @@ +//SKIP PARAM: --enable ana.int.interval --set sem.int.signed_overflow assume_none --set ana.activated[+] lin2vareq_p + +#include + +int nondet() { + int x; + return x; +} +int SIZE = 1; +int rand; + +int main() { + unsigned int n=2,i=8; + n = i%(SIZE+2); //NOWARN + + rand=nondet(); + + if (rand>5 && rand<10) { + n= i%(rand+2); //NOWARN + } + + return 0; +} + diff --git a/tests/regression/82-lin2vareq_p/dune b/tests/regression/82-lin2vareq_p/dune new file mode 100644 index 0000000000..f8e68307a1 --- /dev/null +++ b/tests/regression/82-lin2vareq_p/dune @@ -0,0 +1,10 @@ +(rule + (aliases runtest runaprontest) + (enabled_if %{lib-available:apron}) + (deps + (package goblint) + ../../../goblint ; update_suite calls local goblint + (:update_suite ../../../scripts/update_suite.rb) + (glob_files ??-*.c)) + (locks /update_suite) + (action (chdir ../../.. (run %{update_suite} group lin2vareq_p -q)))) \ No newline at end of file From 41135b83b172d3e187e21c631ea93efb2d224305 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 3 Feb 2025 15:34:47 +0100 Subject: [PATCH 02/86] added intervals, does not work yet --- .../cdomains/int/intervalDomainWithBounds.ml | 443 +++++++++++ ...inearTwoVarEqualityDomainPentagon.apron.ml | 725 ++++++++++-------- 2 files changed, 864 insertions(+), 304 deletions(-) create mode 100644 src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml diff --git a/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml b/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml new file mode 100644 index 0000000000..b809462cf5 --- /dev/null +++ b/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml @@ -0,0 +1,443 @@ +open IntDomain0 + +(**TODO Better Naming!*) +module type BoundedIntOps = sig + include IntOps.IntOps + + type t_interval = (t * t) option + + val range : GoblintCil.ikind -> t * t + val top_of : GoblintCil.ikind -> t_interval + val bot_of : GoblintCil.ikind -> t_interval + + + val norm : ?suppress_ovwarn:bool -> ?cast:bool -> GoblintCil.ikind -> t_interval -> t_interval * overflow_info +end + +module Bounded (Ints_t : IntOps.IntOps): BoundedIntOps with type t = Ints_t.t and type t_interval = (Ints_t.t * Ints_t.t) option = struct + include Ints_t + type t_interval = (Ints_t.t * Ints_t.t) option + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top_of ik = Some (range ik) + let bot_of ik = None (* TODO: improve *) + + + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t_interval -> t_interval * 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) + ) + +end + +module IntervalFunctor (Ints_t : BoundedIntOps): SOverflow with type int_t = Ints_t.t and type t = Ints_t.t_interval = +struct + let name () = "intervals bounds injected" + 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 = Ints_t.range + let top_of = Ints_t.top_of + let norm = Ints_t.norm + let bot_of = Ints_t.bot_of + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let bot () = None + + 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 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 Interval = IntervalFunctor (Bounded(IntOps.BigIntOps)) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (Bounded(IntOps.Int64Ops))))) (IntIkind) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 6af7030a51..5c0050773e 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1,11 +1,4 @@ -(** OCaml implementation of the linear two-variable equality domain. - - @see A. Flexeder, M. Petter, and H. Seidl Fast Interprocedural Linear Two-Variable Equalities. *) - -(** Abstract states in this domain are represented by structs containing an array and an apron environment. - The arrays are modeled as proposed in the paper: Each variable is assigned to an index and each array element represents a linear relationship that must hold at the corresponding program point. - The apron environment is hereby used to organize the order of columns and variables. -*) +(**Extending the LinearTwoVarDomain with Intervals for the representative interval *) open Batteries open GoblintCil @@ -16,189 +9,279 @@ open VectorMatrix module Mpqf = SharedFunctions.Mpqf -module Rhs = struct - (* Rhs represents coefficient*var_i + offset / divisor - depending on whether coefficient is 0, the monomial term may disappear completely, not refering to any var_i, thus: - (Some (coefficient, i), offset, divisor ) with coefficient != 0 , or - (None , offset, divisor ) *) - type t = ((GobZ.t * int) option * GobZ.t * GobZ.t) [@@deriving eq, ord, hash] - let var_zero i = (Some (Z.one,i), Z.zero, Z.one) - let show_coeff c = - if Z.equal c Z.one then "" - else if Z.equal c Z.minus_one then "-" - else (Z.to_string c) ^"·" - let show_rhs_formatted formatter = let ztostring n = (if Z.(geq n zero) then "+" else "") ^ Z.to_string n in - function - | (Some (coeff,v), o,_) when Z.equal o Z.zero -> Printf.sprintf "%s%s" (show_coeff coeff) (formatter v) - | (Some (coeff,v), o,_) -> Printf.sprintf "%s%s %s" (show_coeff coeff) (formatter v) (ztostring o) - | (None, o,_) -> Printf.sprintf "%s" (Z.to_string o) - let show (v,o,d) = - let rhs=show_rhs_formatted (Printf.sprintf "var_%d") (v,o,d) in - if not (Z.equal d Z.one) then "(" ^ rhs ^ ")/" ^ (Z.to_string d) else rhs - - (** factor out gcd from all terms, i.e. ax=by+c with a positive is the canonical form for adx+bdy+cd *) - let canonicalize (v,o,d) = - let gcd = Z.gcd o d in (* gcd of coefficients *) - let gcd = Option.map_default (fun (c,_) -> Z.gcd c gcd) gcd v in (* include monomial in gcd computation *) - let commondivisor = if Z.(lt d zero) then Z.neg gcd else gcd in (* canonical form dictates d being positive *) - (BatOption.map (fun (coeff,i) -> (Z.div coeff commondivisor,i)) v, Z.div o commondivisor, Z.div d commondivisor) - - (** Substitute rhs for varx in rhs' *) - let subst rhs varx rhs' = - match rhs,rhs' with - | (monom, o, d), (Some (c', x'), o', d') when x'=varx -> canonicalize (Option.map (fun (c,x) -> (Z.mul c c',x)) monom, Z.((o*c')+(d*o')), Z.mul d d') - | _ -> rhs' +module Rhs = LinearTwoVarEqualityDomain.Rhs +module EConj = LinearTwoVarEqualityDomain.EqualitiesConjunction + +module TopIntBase (Int_t : IntOps.IntOpsBase) = +struct + type sign = Pos | Neg [@@deriving eq, hash] + type t = Int of Int_t.t + | Top of sign [@@deriving eq, hash] + + let compare a b = match a, b with + | Int a, Int b -> Int_t.compare a b + | Top Neg, Top Neg + | Top Pos, Top Pos -> 0 + | _ , Top Pos + | Top Neg, _ -> -1 + | _ , Top Neg + | Top Pos, _ -> 1 + + let get_int_t = function + | Int i -> i + | _ -> failwith "get_int_t on top value" + + + let lift2 op t1 t2 = match t1, t2 with + Int t1, Int t2 -> Int (op t1 t2) + | Top Neg, Top Pos + | Top Pos, Top Neg -> Top Neg + | t, Int _ (*TODO I think this should switch sign when int is negativem*) + | Int _, t -> t + | Top Neg, Top Neg -> Top Pos + | Top Pos, Top Pos -> Top Pos + + let lift2_1 op t1 t2 = match t1 with + | Int t1 -> Int (op t1 t2) + | t -> t + + let name () = Int_t.name () ^ " with top" + + let zero = Int (Int_t.zero) + let one = Int (Int_t.one) + + let lower_bound = Some (Top Neg) + let upper_bound = Some (Top Pos) + + let neg = function + | Int i -> Int (Int_t.neg i) + | Top Pos -> Top Neg + | Top Neg -> Top Pos + let abs = function + | Int i -> Int (Int_t.abs i) + | Top _ -> Top Pos + + let add = lift2 Int_t.add + let sub = lift2 Int_t.sub + let mul = lift2 Int_t.mul + let div = lift2 Int_t.div + + (*TODO will these two make problems later?*) + let rem = lift2 Int_t.rem + let gcd = lift2 Int_t.gcd + + let shift_left = lift2_1 Int_t.shift_left + let shift_right = lift2_1 Int_t.shift_right + let logand = lift2 Int_t.logand + let logor = lift2 Int_t.logor + let logxor = lift2 Int_t.logxor + let lognot = function + | Int i -> Int (Int_t.lognot i) + | t -> t + + (**TODO not clear what this should do*) + let top_range _ _ = false + let max = lift2 Int_t.max + let min = lift2 Int_t.min + + let of_int i = Int (Int_t.of_int i) + let to_int t = Int_t.to_int @@ get_int_t t + + let of_int64 i = Int (Int_t.of_int64 i) + let to_int64 t = Int_t.to_int64 @@ get_int_t t + + let of_string s = if s = "+⊤" then Top Pos else (if s = "-⊤" then Top Pos else Int (Int_t.of_string s)) + let to_string = function + | Int i -> Int_t.to_string i + | Top Pos -> "+⊤" + | Top Neg -> "-⊤" + + let of_bigint i = Int (Int_t.of_bigint i) + let to_bigint t = Int_t.to_bigint @@ get_int_t t + + (*TODO*) + let arbitrary () = failwith "arbitrary not implemented yet" end -module EqualitiesConjunction = struct - module IntMap = BatMap.Make(Int) +(*TODO this is a copy of the IntOpsDecorator, but we keep the constructor of type t -> is there a better way??*) +module TopIntOps = struct + + include Printable.StdLeaf + include TopIntBase(IntOps.BigIntOpsBase) + let show = to_string + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = to_string + end + ) + let pred x = sub x one + let of_bool x = if x then one else zero + let to_bool x = x <> zero + + (* These are logical operations in the C sense! *) + let log_op op a b = of_bool @@ op (to_bool a) (to_bool b) + let c_lognot x = of_bool (x = zero) + let c_logand = log_op (&&) + let c_logor = log_op (||) + let c_logxor = log_op (<>) + + let lt x y = of_bool (compare x y < 0) + let gt x y = of_bool (compare x y > 0) + let le x y = of_bool (compare x y <= 0) + let ge x y = of_bool (compare x y >= 0) - type t = int * ( Rhs.t IntMap.t ) [@@deriving eq, ord] +end - let show_formatted formatter econ = - if IntMap.is_empty econ then "{}" - else - let str = IntMap.fold (fun i (refmonom,off,divi) acc -> Printf.sprintf "%s%s=%s ∧ %s" (Rhs.show_coeff divi) (formatter i) (Rhs.show_rhs_formatted formatter (refmonom,off,divi)) acc) econ "" in - "{" ^ String.sub str 0 (String.length str - 4) ^ "}" +module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOps.t = struct + include TopIntOps - let show econ = show_formatted (Printf.sprintf "var_%d") econ + type t_interval = (t * t) option [@@deriving eq, ord, hash] - let hash (dim,x) = dim + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Rhs.hash value) x 0 (* TODO: derive *) + let range _ = (Top Neg, Top Pos) + let top_of ik = Some (range ik) + let bot_of ik = None - (** creates a domain of dimension 0 *) - let empty () = (0, IntMap.empty) + let norm ?(suppress_ovwarn=false) ?(cast=false) ik t = + let t = match t with + | Some (Top Pos, Top Neg) -> Some (Top Neg, Top Pos) + | Some (l, Top Neg) -> Some (l, Top Pos) + | Some (Top Pos, u) -> Some (Top Neg, u) + | _ -> t + in (t,IntDomain0.{underflow=false; overflow=false}) +end - (** creates a domain of dimension len without any valid equalities *) - let make_empty_conj len = (len, IntMap.empty) +(*TODO add wrapper to remove ikind parameter or not? *) +module Interval = struct + include IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) - (** trivial equalities are of the form var_i = var_i and are not kept explicitely in the sparse representation of EquanlitiesConjunction *) - let nontrivial (_,econmap) lhs = IntMap.mem lhs econmap + let ik = IChar (*Placeholder for all functions that need one*) + let of_bigint x = of_int ik (TopIntOps.of_bigint x) +end - (** turn x = (cy+o)/d into y = (dx-o)/c*) - let inverse x (c,y,o,d) = (y, (Some (d, x), Z.neg o, c)) +module EqualitiesConjunctionWithIntervals = +struct + module IntMap = EConj.IntMap + module I = Interval + type t = EConj.t * (Interval.t IntMap.t) [@@deriving eq, ord] + + let hash (econj, x) = EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + I.hash value) x 0 - (** sparse implementation of get rhs for lhs, but will default to no mapping for sparse entries *) - let get_rhs (_,econmap) lhs = IntMap.find_default (Rhs.var_zero lhs) lhs econmap + let show_intervals formatter is = + if IntMap.is_empty is then "{}" + else + let str = IntMap.fold (fun k v acc -> Printf.sprintf "%s=%s , %s" (formatter k) (I.show v) acc) is "" in + "{" ^ String.sub str 0 (String.length str - 3) ^ "}" - (** set_rhs, staying loyal to immutable, sparse map underneath; do not attempt any normalization *) - let set_rhs (dim,map) lhs rhs = (dim, - if Rhs.equal rhs Rhs.(var_zero lhs) then - IntMap.remove lhs map - else - IntMap.add lhs rhs map - ) + let show_formatted formatter ((dim, econj), is) = Printf.sprintf "(%s, %s)" (EConj.show_formatted formatter econj) (show_intervals formatter is) - (** canonicalize equation, and set_rhs, staying loyal to immutable, sparse map underneath *) - let canonicalize_and_set (dim,map) lhs rhs = set_rhs (dim,map) lhs (Rhs.canonicalize rhs) + let show = show_formatted (Printf.sprintf "var_%d") let copy = identity + let empty () = (EConj.empty (), IntMap.empty) + let is_empty (e,is) = EConj.is_empty e && IntMap.is_empty is - (** add/remove new variables to domain with particular indices; translates old indices to keep consistency - add if op = (+), remove if op = (-) - the semantics of indexes can be retrieved from apron: https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html *) - let modify_variables_in_domain (dim,map) indexes op = - if Array.length indexes = 0 then (dim,map) else - let offsetlist = Array.to_list indexes in - let rec bumpvar delta i = function (* bump the variable i by delta; find delta by counting indices in offsetlist until we reach a larger index then our current parameter *) - | head::rest when i>=head -> bumpvar (delta+1) i rest (* rec call even when =, in order to correctly interpret double bumps *) - | _ (* i op i delta - in - let memobumpvar = (* Memoized version of bumpvar *) - let module IntHash = struct type t = int [@@deriving eq,hash] end in - let module IntHashtbl = Hashtbl.Make (IntHash) in - if (Array.length indexes < 10) then fun x -> bumpvar 0 x offsetlist else (* only do memoization, if dimchange is significant *) - (let h = IntHashtbl.create @@ IntMap.cardinal map in (* #of bindings is a tight upper bound on the number of CCs and thus on the number of different lookups *) - fun x -> (* standard memoization wrapper *) - try IntHashtbl.find h x with Not_found -> - let r = bumpvar 0 x offsetlist in - IntHashtbl.add h x r; - r) - in - let rec bumpentry k (refvar,offset,divi) = function (* directly bumps lhs-variable during a run through indexes, bumping refvar explicitly with a new lookup in indexes *) + let is_top_con (e, is) = EConj.is_top_con e && IntMap.is_empty is - | (tbl,delta,head::rest) when k>=head -> bumpentry k (refvar,offset,divi) (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) - | (tbl,delta,lyst) (* k (IntMap.add (op k delta) (BatOption.map (fun (c,v) -> (c,memobumpvar v)) refvar,offset,divi) tbl, delta, lyst) + (**TODO Test this code*) + let modify_variables_in_domain_intervals map indexes op = + if Array.length indexes = 0 then map else + let rec bumpentry k v = function + | (tbl,delta,head::rest) when k>=head -> bumpentry k v (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) + | (tbl,delta,lyst) (* k (IntMap.add (op k delta) v tbl, delta, lyst) in - let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,offsetlist) in (* Build new map during fold with bumped key/vals *) - (op dim (Array.length indexes), a) - - let modify_variables_in_domain m cols op = let res = modify_variables_in_domain m cols op in if M.tracing then - M.tracel "modify_dims" "dimarray bumping with (fun x -> x + %d) at positions [%s] in { %s } -> { %s }" - (op 0 1) - (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) cols "") - (show (snd m)) - (show (snd res)); - res + let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,Array.to_list indexes) in (* Build new map during fold with bumped keys *) + a - (** required by AbstractRelationalDomainRepresentation, true if dimension is zero *) - let is_empty (d,_) = d = 0 - - let is_top_array = GobArray.for_alli (fun i (a, e) -> GobOption.exists ((=) i) a && Z.equal e Z.zero) - - let is_top_con (_,map) = IntMap.is_empty map - - (* Forget information about variable i *) - let forget_variable d var = - let res = - (let ref_var_opt = Tuple3.first (get_rhs d var) in - match ref_var_opt with - | Some (_,ref_var) when ref_var = var -> - if M.tracing then M.trace "forget" "headvar var_%d" var; - (* var is the reference variable of its connected component *) - (let cluster = List.sort (Int.compare) @@ IntMap.fold - (fun i (refe,_,_) l -> BatOption.map_default (fun (coeff,refe) -> if (refe=ref_var) then i::l else l) l refe) (snd d) [] in - if M.tracing then M.trace "forget" "cluster varindices: [%s]" (String.concat ", " (List.map (string_of_int) cluster)); - (* obtain cluster with common reference variable ref_var*) - match cluster with (* new ref_var is taken from head of the cluster *) - | head :: clusterrest -> - (* head: divi*x = coeff*y + offs *) - (* divi*x = coeff*y + offs =inverse=> y =( divi*x - offs)/coeff *) - let (newref,offs,divi) = (get_rhs d head) in - let (coeff,y) = BatOption.get newref in - let (y,yrhs) = inverse head (coeff,y,offs,divi) in (* reassemble yrhs out of components *) - let shifted_cluster = (List.fold (fun map i -> - let irhs = (get_rhs d i) in (* old entry is i = irhs *) - Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) - set_rhs map i - ) d clusterrest) in - set_rhs shifted_cluster head (Rhs.var_zero head) (* finally make sure that head is now trivial *) - | [] -> d) (* empty cluster means no work for us *) - | _ -> d) (* variable is either a constant or expressed by another refvar *) in - let res = (fst res, IntMap.remove var (snd res)) in (* set d(var) to unknown, finally *) - if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show (snd d)) (show (snd res)); - res - - let dim_add (ch: Apron.Dim.change) m = - modify_variables_in_domain m ch.dim (+) + let make_empty_with_size size = (EConj.make_empty_conj size, IntMap.empty) - let dim_add ch m = timing_wrap "dim add" (dim_add ch) m + let dim_add (ch: Apron.Dim.change) (econj, i) = + (EConj.dim_add ch econj, modify_variables_in_domain_intervals i ch.dim (+)) - let dim_remove (ch: Apron.Dim.change) m = - if Array.length ch.dim = 0 || is_empty m then - m + let dim_remove (ch: Apron.Dim.change) (econj, i) ~del = + if Array.length ch.dim = 0 || EConj.is_empty econj then + (econj, i) else ( let cpy = Array.copy ch.dim in Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) - let m' = Array.fold_lefti (fun y i x -> forget_variable y (x)) m cpy in (* clear m' from relations concerning ch.dim *) - modify_variables_in_domain m' cpy (-)) + let econj' = Array.fold_lefti (fun y i x -> EConj.forget_variable y (x)) econj cpy in (* clear m' from relations concerning ch.dim *) + let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in + let i' = modify_variables_in_domain_intervals i cpy (-) in + (econj'', i')) + + let forget_variable (econj, is) var = (EConj.forget_variable econj var, IntMap.add var (Interval.top_of Interval.ik) is) + + + let get_rhs t = EConj.get_rhs (fst t) + + let get_interval (econ, is) lhs = + match IntMap.find_opt lhs is with + Some i -> i + | None -> (*If there is no interval saved, we have calculate it*) + let (v,o,d) = get_rhs (econ, is) lhs in + if (v,o,d) = Rhs.var_zero lhs then I.top_of I.ik (*uninitialised -> Tot*) + else match v with + None -> I.div I.ik (I.of_bigint o) (I.of_bigint d)(*constant*) (*TODO is divisor always 1?*) + | Some (coeff,v) -> match IntMap.find_opt v is with + None -> I.top_of I.ik(*uninitialised*) + | Some i -> I.div I.ik (I.add I.ik (I.of_bigint o) @@ I.mul I.ik (I.of_bigint coeff) i) (I.of_bigint d) + + let set_interval ((econ, is):t) lhs i = + let refine _ _ = identity in (**TODO do some refinement based on the fact that all variables must be integers*) + let set_interval_for_root lhs i = + let i = refine econ lhs i in + if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Interval.show i); + match I.to_int i with + | None -> (econ, IntMap.add lhs i is) (*Not a constant*) + | Some (Top _) -> (econ, IntMap.remove lhs is) (*Top -> do not save*) (*TODO I think somewhere else we might save top values -> fix?*) + | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) + let update_references = function + | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) + | t -> t + in + ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is) + in let (v,o,d) = get_rhs (econ, is) lhs in + if (v,o,d) = Rhs.var_zero lhs then + set_interval_for_root lhs i + else + match v with + | None -> (econ, is) (*For a constant, we do not need to save an interval*) (*TODO should we check for equality?*) + | Some (coeff, v) -> + let i1 = I.mul I.ik (I.of_bigint d) i in + let i2 = I.sub I.ik (I.of_bigint o) i1 in + let i3 = I.div I.ik i2 (I.of_bigint coeff) in + let i_transformed = i3 in + if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Interval.show i) (Interval.show i1) (Interval.show i2) (Interval.show i3); + set_interval_for_root v i_transformed + + let set_interval t lhs i = + let res = set_interval t lhs i in + if M.tracing then M.tracel "modify_pentagon" "set_interval before: %s eq: var_%d=%s -> %s " (show t) lhs (Interval.show i) (show res); + res - let dim_remove ch m = VectorMatrix.timing_wrap "dim remove" (fun m -> dim_remove ch m) m - let dim_remove ch m ~del = let res = dim_remove ch m in if M.tracing then - M.tracel "dim_remove" "dim remove at positions [%s] in { %s } -> { %s }" - (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) ch.dim "") - (show (snd m)) - (show (snd res)); + (**Assumes that values of variables and all other rhs stay the same. TODO can it happen that multiple rhs update at the same time? Problem if a variable is removed from the group in the same step?*) + let set_rhs (econ, is) lhs rhs = + let econ' = EConj.set_rhs econ lhs rhs in + match rhs with + | (None, _, _) -> econ', IntMap.remove lhs is (*when setting as a constant, we do not need a separate interval *) + | _ -> + let new_constraint = get_interval (econ', is) lhs in + let old_constraint = get_interval (econ, is) lhs in + let new_interval = I.meet I.ik new_constraint old_constraint in + set_interval (econ', is) lhs new_interval + + let set_rhs t lhs rhs = + let res = set_rhs t lhs rhs in + if M.tracing then M.tracel "modify_pentagon" "set_rhs before: %s eq: var_%d=%s -> %s " (show t) lhs (Rhs.show rhs) (show res); res - exception Contradiction - - let meet_with_one_conj ts i (var, offs, divi) = + let meet_with_one_conj ((ts, is):t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) - let res = - let subst_var (dim,econj) x (vary, o, d) = + let res : t = + let subst_var ((dim,econj), is) x (vary, o, d) = (* [[x substby (cy+o)/d ]] ((c'x+o')/d') *) (* =====> (c'cy + c'o+o'd)/(dd') *) let adjust = function @@ -206,68 +289,61 @@ module EqualitiesConjunction = struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + let interval = get_interval (ts, is) x in + let is' = IntMap.remove x is in + set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) in - (match var, (get_rhs ts i) with + (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) - | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise Contradiction else ts + | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise EConj.Contradiction else ts, is (* o/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_h1 = (o*d1-o1*d)/(d*c1) /\ x_i = o/d *) - | None , (Some (coeff1,h1), o1, divi1) -> subst_var ts h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) + | None , (Some (coeff1,h1), o1, divi1) -> subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) (* (c*x_j+o)/d = x_i = o1/d1 *) (* ======> x_j = (o1*d-o*d1)/(d1*c) /\ x_i = o1/d1 *) - | Some (coeff,j), (None , o1, divi1) -> subst_var ts j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) + | Some (coeff,j), (None , o1, divi1) -> subst_var (ts, is) j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) (* (c*x_j+o)/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_j needs normalization wrt. ts *) | Some (coeff,j), ((Some (coeff1,h1), o1, divi1) as oldi)-> - (match get_rhs ts j with + (match EConj.get_rhs ts j with (* ts[x_j]=o2/d2 ========> ... *) | (None , o2, divi2) -> let newxi = Rhs.subst (None,o2,divi2) j (Some (coeff,j),offs,divi) in - let newxh1 = snd @@ inverse i (coeff1,h1,o1,divi1) in + let newxh1 = snd @@ EConj.inverse i (coeff1,h1,o1,divi1) in let newxh1 = Rhs.subst newxi i newxh1 in - subst_var ts h1 newxh1 + subst_var (ts, is) h1 newxh1 (* ts[x_j]=(c2*x_h2+o2)/d2 ========> ... *) | (Some (coeff2,h2), o2, divi2) as normalizedj -> if h1 = h2 then (* this is the case where x_i and x_j already where in the same equivalence class; let's see whether the new equality contradicts the old one *) let normalizedi= Rhs.subst normalizedj j (Some(coeff,j),offs,divi) in - if not @@ Rhs.equal normalizedi oldi then raise Contradiction else ts + if not @@ Rhs.equal normalizedi oldi then raise EConj.Contradiction else (ts, is) else if h1 < h2 (* good, we now unite the two equvalence classes; let's decide upon the representative *) then (* express h2 in terms of h1: *) - let (_,newh2)= inverse j (coeff2,h2,o2,divi2) in - let newh2 = Rhs.subst oldi i (Rhs.subst (snd @@ inverse i (coeff,j,offs,divi)) j newh2) in - subst_var ts h2 newh2 + let (_,newh2)= EConj.inverse j (coeff2,h2,o2,divi2) in + let newh2 = Rhs.subst oldi i (Rhs.subst (snd @@ EConj.inverse i (coeff,j,offs,divi)) j newh2) in + subst_var (ts, is) h2 newh2 else (* express h1 in terms of h2: *) - let (_,newh1)= inverse i (coeff1,h1,o1,divi1) in + let (_,newh1)= EConj.inverse i (coeff1,h1,o1,divi1) in let newh1 = Rhs.subst normalizedj j (Rhs.subst (Some(coeff,j),offs,divi) i newh1) in - subst_var ts h1 newh1)) in - if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (snd ts)) i (Rhs.show (var,offs,divi)) (show (snd res)) + subst_var (ts, is) h1 newh1)) in + if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res - (** affine transform variable i allover conj with transformer (Some (coeff,i)+offs)/divi *) - let affine_transform econ i (coeff, j, offs, divi) = - if nontrivial econ i then (* i cannot occur on any other rhs apart from itself *) - set_rhs econ i (Rhs.subst (get_rhs econ i) i (Some (coeff,j), offs, divi)) - else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) - (* so now, we transform with the inverse of the transformer: *) - let inv = snd (inverse i (coeff,j,offs,divi)) in - IntMap.fold (fun k v acc -> - match v with - | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) - | _ -> acc - ) (snd econ) econ - + let meet_with_one_interval var interval t = + let new_interval = I.meet I.ik interval (get_interval t var) + in set_interval t var new_interval end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. Furthermore, it provides the function [simplified_monomials_from_texp] that converts an apron expression into a list of monomials of reference variables and a constant offset *) module VarManagement = struct - module EConj = EqualitiesConjunction - include SharedFunctions.VarManagementOps (EConj) + module EConjI = EqualitiesConjunctionWithIntervals + include SharedFunctions.VarManagementOps (EConjI) - let dim_add = EConj.dim_add - let size t = BatOption.map_default (fun (d,_) -> d) 0 t.d + let dim_add = EConjI.dim_add + let size t = BatOption.map_default (fun ((d,_),_) -> d) 0 t.d (** Parses a Texpr to obtain a (coefficient, variable) pair list to repr. a sum of a variables that have a coefficient. If variable is None, the coefficient represents a constant offset. *) let monomials_from_texp (t: t) texp = @@ -297,7 +373,7 @@ struct begin match t.d with | None -> [(Some (Z.one,var_dim),Z.zero,Z.one)] | Some d -> - (match (EConj.get_rhs d var_dim) with + (match (EConjI.get_rhs d var_dim) with | (Some (coeff,i), k,divi) -> [(Some (coeff,i),Z.zero,divi); (None,k,divi)] | (None, k,divi) -> [ (None,k,divi)]) end @@ -318,10 +394,10 @@ struct BatOption.bind (monomials_from_texp t texp) (fun monomiallist -> let d = Option.get t.d in - let module IMap = EConj.IntMap in + let module IMap = EConjI.IntMap in let accumulate_constants (exprcache,(aconst,adiv)) (v,offs,divi) = match v with | None -> let gcdee = Z.gcd adiv divi in exprcache,(Z.(aconst*divi/gcdee + offs*adiv/gcdee),Z.lcm adiv divi) - | Some (coeff,idx) -> let (somevar,someoffs,somedivi)=Rhs.subst (EConj.get_rhs d idx) idx (v,offs,divi) in (* normalize! *) + | Some (coeff,idx) -> let (somevar,someoffs,somedivi)=Rhs.subst (EConjI.get_rhs d idx) idx (v,offs,divi) in (* normalize! *) let newcache = Option.map_default (fun (coef,ter) -> IMap.add ter Q.((IMap.find_default zero ter exprcache) + make coef somedivi) exprcache) exprcache somevar in let gcdee = Z.gcd adiv divi in (newcache,(Z.(aconst*divi/gcdee + offs*adiv/gcdee),Z.lcm adiv divi)) @@ -331,7 +407,7 @@ struct let simplified_monomials_from_texp (t: t) texp = let res = simplified_monomials_from_texp t texp in - if M.tracing then M.tracel "from_texp" "%s %a -> %s" (EConj.show @@ snd @@ BatOption.get t.d) Texpr1.Expr.pretty texp + if M.tracing then M.tracel "from_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (BatOption.map_default (fun (l,(o,d)) -> List.fold_right (fun (a,x,b) acc -> Printf.sprintf "%s*var_%d/%s + %s" (Z.to_string a) x (Z.to_string b) acc) l ((Z.to_string o)^"/"^(Z.to_string d))) "" res); res @@ -345,9 +421,45 @@ struct let simplify_to_ref_and_offset t texp = timing_wrap "coeff_vec" (simplify_to_ref_and_offset t) texp + (*TODO texpr has rather few constructors. Would we be more precise if we evaluated the CIL expression instead??*) + let eval_texpr (t:t) texp = + let open Apron.Texpr1 in + let binop_function = function + | Add -> Interval.add Interval.ik + | Sub -> Interval.sub Interval.ik + | Mul -> Interval.mul Interval.ik + | Div -> Interval.div Interval.ik + | Mod -> Interval.rem Interval.ik + | Pow -> failwith "power is not supported" (*TODO should this be supported*) + in let unop_function = function + | Neg -> Interval.neg Interval.ik + | Cast -> identity + | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) + in let rec eval = function + | Cst (Scalar x) -> + begin match SharedFunctions.int_of_scalar ?round:None x with + | Some x -> Interval.of_bigint x + | None -> Interval.top_of Interval.ik + end + | Cst (Interval _) -> failwith "constant was an interval; this is not supported" (*TODO monomials_from_texp does not support this as well, but maybe we should*) + | Var x -> + let var_dim = Environment.dim_of_var t.env x in + begin match t.d with + | None -> Interval.top_of Interval.ik + | Some d -> EConjI.get_interval d var_dim + end + | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) + | Unop (op, a, Int, _) -> (unop_function op) (eval a) + | _ -> Interval.top_of Interval.ik (*not integers*) + in + let res = eval texp in + if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Interval.show res); + res + + let assign_const t var const divi = match t.d with | None -> t - | Some t_d -> {d = Some (EConj.set_rhs t_d var (None, const, divi)); env = t.env} + | Some t_d -> {d = Some (EConjI.set_rhs t_d var (None, const, divi)); env = t.env} end @@ -383,7 +495,7 @@ struct type var = V.t - let name () = "lin2vareq" + let name () = "lin2vareq_pentagon" let to_yojson _ = failwith "ToDo Implement in future" @@ -391,13 +503,13 @@ struct let is_bot t = equal t (bot ()) (** forall x_i in env, x_i:=X_i+0 *) - let top_of env = {d = Some (EConj.make_empty_conj (Environment.size env)); env = env} + let top_of env = {d = Some (EConjI.make_empty_with_size (Environment.size env)); env = env} (** env = \emptyset, d = Some([||]) *) - let top () = {d = Some (EConj.empty()); env = empty_env} + let top () = {d = Some (EConjI.empty()); env = empty_env} (** is_top returns true for top_of array and empty array; precondition: t.env and t.d are of same size *) - let is_top t = GobOption.exists EConj.is_top_con t.d + let is_top t = GobOption.exists EConjI.is_top_con t.d let to_subscript i = let transl = [|"₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"|] in @@ -416,12 +528,11 @@ struct let show varM = match varM.d with | None -> "⊥\n" - | Some arr when EConj.is_top_con arr -> "⊤\n" | Some arr -> if is_bot varM then "Bot \n" else - EConj.show_formatted (show_var varM.env) (snd arr) ^ (to_subscript @@ fst arr) + EConjI.show_formatted (show_var varM.env) arr ^ (to_subscript @@ fst @@ fst arr) let pretty () (x:t) = text (show x) let printXml f x = BatPrintf.fprintf f "\n\n\nequalities\n\n\n%s\n\nenv\n\n\n%a\n\n\n" (XmlUtil.escape (show x)) Environment.printXml x.env @@ -432,7 +543,7 @@ struct | None -> t | Some d -> try - { d = Some (EConj.meet_with_one_conj d i (var, o, divi)); env = t.env} + { d = Some (EConjI.meet_with_one_conj d i (var, o, divi)); env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction\n"; { d = None; env = t.env} @@ -442,13 +553,23 @@ struct if M.tracing then M.tracel "meet" "%s with single eq %s=%s -> %s" (show t) (Z.(to_string @@ Tuple3.third e)^ show_var t.env i) (Rhs.show_rhs_formatted (show_var t.env) e) (show res); res + let meet_with_one_interval i interval t = + let res = match t.d with + | None -> t + | Some d -> + { d = Some (EConjI.meet_with_one_interval i interval d ); env = t.env} + in + if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Interval.show interval) (show res); + res + let meet t1 t2 = let sup_env = Environment.lce t1.env t2.env in let t1 = change_d t1 sup_env ~add:true ~del:false in let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with | Some d1', Some d2' -> - EConj.IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + let conj_met = EConjI.IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd @@ fst d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + in EConjI.IntMap.fold meet_with_one_interval (snd d2') conj_met | _ -> {d = None; env = sup_env} let meet t1 t2 = @@ -468,12 +589,15 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in + let implies_interval v i interval = Interval.leq (EConjI.get_interval v i) interval + in if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true else if is_bot_env t2 || is_top t1 then false else let m1, m2 = Option.get t1.d, Option.get t2.d in let m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in - EConj.IntMap.for_all (implies m1') (snd m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + EConj.IntMap.for_all (implies @@ fst m1') (snd @@ fst m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + && EConj.IntMap.for_all (implies_interval m1') (snd m2) let leq a b = timing_wrap "leq" (leq a) b @@ -482,59 +606,26 @@ struct if M.tracing then M.tracel "leq" "leq a: %s b: %s -> %b" (show t1) (show t2) res ; res - let join a b = - let join_d ad bd = - (* joinfunction handles the dirty details of performing an "inner join" on the lhs of both bindings; - in the resulting binding, the lhs is then mapped to values that are later relevant for sorting/grouping, i.e. - - lhs itself - - criteria A and B that characterize equivalence class, depending on the reference variable and the affine expression parameters wrt. each EConj - - rhs1 - - rhs2 - however, we have to account for the sparseity of EConj maps by manually patching holes with default values *) - let joinfunction lhs rhs1 rhs2 = - ( - let e = Option.default (Rhs.var_zero lhs) in - match rhs1,rhs2 with (* first of all re-instantiate implicit sparse elements *) - | None, None -> None - | a, b -> Some (e a, e b)) - |> - BatOption.map (fun (r1,r2) -> match (r1,r2) with (* criterion A , criterion B *) - | (Some (c1,_),o1,d1), (Some (c2,_),o2,d2)-> lhs, Q.make Z.((o1*d2)-(o2*d1)) Z.(c1*d2), Q.make Z.(c2*d2) Z.(c1*d1), r1, r2 - | (None, oc,dc), (Some (cv,_),ov,dv) - | (Some (cv,_),ov,dv), (None ,oc,dc)-> lhs, Q.make Z.((oc*dv)-(ov*dc)) Z.(dc*cv), Q.one , r1, r2 (* equivalence class defined by (oc/dc-ov/dv)/(cv/dv) *) - | (None, o1,d1), (None ,o2,d2)-> lhs, (if Z.(zero = ((o1*d2)-(o2*d1))) then Q.one else Q.zero), Q.zero, r1, r2 (* only two equivalence classes: constants with matching values or constants with different values *) - ) - in - let table = List.of_enum @@ EConj.IntMap.values @@ EConj.IntMap.merge joinfunction (snd ad) (snd bd) in - (* compare two variables for grouping depending on affine function parameters a, b and reference variable indices *) - let cmp_z (_, ai, bi, t1i, t2i) (_, aj, bj, t1j, t2j) = - let cmp_ref = Option.compare ~cmp:(fun x y -> Int.compare (snd x) (snd y)) in - Tuple4.compare ~cmp1:cmp_ref ~cmp2:cmp_ref ~cmp3:Q.compare ~cmp4:Q.compare (Tuple3.first t1i, Tuple3.first t2i, ai, bi) (Tuple3.first t1j, Tuple3.first t2j, aj, bj) - in - (* Calculate new components as groups *) - let new_components = BatList.group cmp_z table in - let varentry ci offi ch offh xh = - let (coeff,off,d) = Q.(ci,(offi*ch)-(ci*offh),ch) in (* compute new rhs in Q *) - let (coeff,off,d) = Z.(coeff.num*d.den*off.den,off.num*d.den*coeff.den,d. num*coeff.den*off.den) in (* convert that back into Z *) - Rhs.canonicalize (Some(coeff,xh),off,d) - in - (* ci1 = a*ch1+b /\ ci2 = a*ch2+b *) - (* ===> a = (ci1-ci2)/(ch1-ch2) b = ci2-a*ch2 *) - let constentry ci1 ci2 ch1 ch2 xh = - let a = Q.((ci1-ci2) / (ch1-ch2)) in - let b = Q.(ci2 - a*ch2) in - Rhs.canonicalize (Some (Z.(a.num*b.den),xh),Z.(b.num*a.den) ,Z.(a.den*b.den) ) in - let iterate map l = - match l with - | (_, _, _, rhs , rhs' ) :: t when Rhs.equal rhs rhs' -> List.fold (fun acc (x,_,_,rh,_) -> EConj.set_rhs acc x rh) map l - | (h, _, _, ((Some (ch,_),oh,dh)), ((Some _,_,_) )) :: t -> List.fold (fun acc (i,_,_,(monom,oi,di),_) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t - | (h, _, _, ((Some (ch,_),oh,dh)), ((None,_,_) )) :: t -> List.fold (fun acc (i,_,_,(monom,oi,di),_) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t - | (h, _, _, ((None,_,_) ), ((Some (ch,_),oh,dh))) :: t -> List.fold (fun acc (i,_,_,_,(monom,oi,di)) -> EConj.set_rhs acc i (varentry Q.(make (fst@@Option.get monom) di) Q.(make oi di) Q.(make ch dh) Q.(make oh dh) h)) map t - | (h, _, _, ((None,oh1,dh1) ), ((None),oh2,dh2) ) :: t -> List.fold (fun acc (i,_,_,(_,oi1,di1),(_,oi2,di2)) -> EConj.set_rhs acc i (constentry Q.(make oi1 di1) Q.(make oi2 di2) Q.(make oh1 dh1) Q.(make oh2 dh2) h)) map t - | [] -> let exception EmptyComponent in raise EmptyComponent - in - Some (List.fold iterate (EConj.make_empty_conj @@ fst ad) new_components) - + (*The first parameter is the function used to join two intervals. Different uses for join / widen*) + let join' join_function a b = + let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d + in + (*Check all variables (up to index vars) if we need to save an interval for them*) + let rec collect_intervals x y econj_joined vars is = + if vars < 0 then is + else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) is (*we only need intervals for roots of the connected components*) + else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in (*TODO: if we tighten the interval in set_interval, we also should do that here.*) + if Interval.is_top_of Interval.ik joined_interval + then collect_intervals x y econj_joined (vars-1) is (*DO not add top intervals*) + else collect_intervals x y econj_joined (vars-1) (EConjI.IntMap.add vars joined_interval is) + in + let join_d x y env = + let econj' = join_econj (fst x) (fst y) env in + match econj' with + None -> None + | Some econj'' -> + let is' = collect_intervals x y econj'' ((fst @@ fst x) - 1) (EConjI.IntMap.empty) in + Some (econj'', is') in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with @@ -547,10 +638,12 @@ struct let sup_env = Environment.lce a.env b.env in let mod_x = dim_add (Environment.dimchange a.env sup_env) x in let mod_y = dim_add (Environment.dimchange b.env sup_env) y in - {d = join_d mod_x mod_y; env = sup_env} - | Some x, Some y when EConj.equal x y -> {d = Some x; env = a.env} - | Some x, Some y -> {d = join_d x y; env = a.env} + {d = join_d mod_x mod_y sup_env; env = sup_env} + | Some x, Some y when EConjI.equal x y -> {d = Some x; env = a.env} + | Some x, Some y -> {d = join_d x y a.env; env = a.env} + + let join = join' (Interval.join Interval.ik) let join a b = timing_wrap "join" (join a) b let join a b = @@ -558,15 +651,14 @@ struct if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; res - let widen a b = - join a b + let widen = join' (Interval.widen Interval.ik) let widen a b = let res = widen a b in if M.tracing then M.tracel "widen" "widen a: %s b: %s -> %s" (show a) (show b) (show res) ; res - let narrow a b = meet a b + let narrow a b = meet a b (*TODO use narrow for intervals!*) let narrow a b = let res = narrow a b in @@ -579,13 +671,13 @@ struct let forget_var t var = if is_bot_env t || is_top t then t else - {d = Some (EConj.forget_variable (Option.get t.d) (Environment.dim_of_var t.env var)); env = t.env} + {d = Some (EConjI.forget_variable (Option.get t.d) (Environment.dim_of_var t.env var)); env = t.env} let forget_vars t vars = if is_bot_env t || is_top t || List.is_empty vars then t else - let newm = List.fold (fun map i -> EConj.forget_variable map (Environment.dim_of_var t.env i)) (Option.get t.d) vars in + let newm = List.fold (fun map i -> EConjI.forget_variable map (Environment.dim_of_var t.env i)) (Option.get t.d) vars in {d = Some newm; env = t.env} let forget_vars t vars = @@ -601,7 +693,7 @@ struct match t.d with | Some d -> let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in - begin match simplify_to_ref_and_offset t texp with + let t' = match simplify_to_ref_and_offset t texp with | None -> (* Statement "assigned_var = ?" (non-linear assignment) *) forget_var t var @@ -610,10 +702,12 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform d var_i (coeff_var, var_i, off, divi)); env=t.env } + {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) + in begin match t'.d with None -> bot_env + | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t' texp)); env = t'.env} end | None -> bot_env @@ -698,7 +792,6 @@ struct let substitute_exp ask t var exp no_ov = timing_wrap "substitution" (substitute_exp ask t var exp) no_ov - (** Assert a constraint expression. The overflow is completely handled by the flag "no_ov", which is set in relationAnalysis.ml via the function no_overflow. @@ -715,41 +808,65 @@ struct match t.d with | None -> t | Some d -> - match simplified_monomials_from_texp t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with - | None -> t - | Some (sum_of_terms, (constant,divisor)) ->( - match sum_of_terms with - | [] -> (* no reference variables in the guard, so check constant for zero *) - begin match Tcons1.get_typ tcons with - | EQ when Z.equal constant Z.zero -> t - | SUPEQ when Z.geq constant Z.zero -> t - | SUP when Z.gt constant Z.zero -> t - | DISEQ when not @@ Z.equal constant Z.zero -> t - | EQMOD _ -> t - | _ -> bot_env (* all other results are violating the guard *) - end - | [(coeff, index, divi)] -> (* guard has a single reference variable only *) - if Tcons1.get_typ tcons = EQ then - meet_with_one_conj t index (Rhs.canonicalize (None, Z.neg @@ Z.(divi*constant),Z.(coeff*divisor))) - else - t (* only EQ is supported in equality based domains *) - | [(c1,var1,d1); (c2,var2,d2)] -> (* two variables in relation needs a little sorting out *) - begin match Tcons1.get_typ tcons with - | EQ -> (* c1*var1/d1 + c2*var2/d2 +constant/divisor = 0*) - (* ======> c1*divisor*d2 * var1 = -c2*divisor*d1 * var2 +constant*-d1*d2*) - (* \/ c2*divisor*d1 * var2 = -c1*divisor*d2 * var1 +constant*-d1*d2*) - let open Z in - if var1 < var2 then - meet_with_one_conj t var2 (Rhs.canonicalize (Some (neg @@ c1*divisor,var1),neg @@ constant*d2*d1,c2*divisor*d1)) - else - meet_with_one_conj t var1 (Rhs.canonicalize (Some (neg @@ c2*divisor,var2),neg @@ constant*d2*d1,c1*divisor*d2)) - | _-> t (* Not supported in equality based 2vars without coeffiients *) + let expr = (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) in + (* meet EConj*) + let t = match simplified_monomials_from_texp t expr with + | None -> t + | Some (sum_of_terms, (constant,divisor)) ->( + match sum_of_terms with + | [] -> (* no reference variables in the guard, so check constant for zero *) + begin match Tcons1.get_typ tcons with + | EQ when Z.equal constant Z.zero -> t + | SUPEQ when Z.geq constant Z.zero -> t + | SUP when Z.gt constant Z.zero -> t + | DISEQ when not @@ Z.equal constant Z.zero -> t + | EQMOD _ -> t + | _ -> bot_env (* all other results are violating the guard *) + end + | [(coeff, index, divi)] -> (* guard has a single reference variable only *) + if Tcons1.get_typ tcons = EQ then + meet_with_one_conj t index (Rhs.canonicalize (None, Z.neg @@ Z.(divi*constant),Z.(coeff*divisor))) + else + t (* only EQ is supported in equality based domains *) + | [(c1,var1,d1); (c2,var2,d2)] -> (* two variables in relation needs a little sorting out *) + begin match Tcons1.get_typ tcons with + | EQ -> (* c1*var1/d1 + c2*var2/d2 +constant/divisor = 0*) + (* ======> c1*divisor*d2 * var1 = -c2*divisor*d1 * var2 +constant*-d1*d2*) + (* \/ c2*divisor*d1 * var2 = -c1*divisor*d2 * var1 +constant*-d1*d2*) + let open Z in + if var1 < var2 then + meet_with_one_conj t var2 (Rhs.canonicalize (Some (neg @@ c1*divisor,var1),neg @@ constant*d2*d1,c2*divisor*d1)) + else + meet_with_one_conj t var1 (Rhs.canonicalize (Some (neg @@ c2*divisor,var2),neg @@ constant*d2*d1,c1*divisor*d2)) + | _-> t (* Not supported in equality based 2vars without coeffiients *) + end + | _ -> t (* For equalities of more then 2 vars we just return t *)) + in (*meet interval*) (*TODO this should be extended much further, should reuse some code from base -> meet with CIL expression instead?*) + (* currently only supports simple assertions x > c*) + (*match expr, Tcons1.get_typ tcons with + | Var v, SUP -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval match" ; + meet_with_one_interval (Environment.dim_of_var t.env v) (Interval.of_bigint Z.zero) t + | _, _ -> t *) + (*match expr with + | Binop (Sub,Var v,Cst (Scalar c),_,_) -> + begin match SharedFunctions.int_of_scalar ?round:None c with + | None -> t + | Some c -> begin match Tcons1.get_typ tcons with + | SUP -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons meet interval"; + meet_with_one_interval (Environment.dim_of_var t.env v) (Some (Int (Z.add Z.one (Z.neg c)), Top Pos)) t + | _ -> t end - | _ -> t (* For equalities of more then 2 vars we just return t *)) + end + | _ ->*) t + let meet_tcons ask t tcons original_expr no_ov = - if M.tracing then M.tracel "meet_tcons" "meet_tcons with expr: %a no_ov:%b" d_exp original_expr (Lazy.force no_ov); - meet_tcons ask t tcons original_expr no_ov + let res = meet_tcons ask t tcons original_expr no_ov + in if M.tracing then M.tracel "meet_tcons" "meet_tcons with expr: %a no_ov:%b : %s -> %s" d_exp original_expr (Lazy.force no_ov) (show t) (show res); + res + let meet_tcons t tcons expr = timing_wrap "meet_tcons" (meet_tcons t tcons) expr @@ -805,7 +922,7 @@ struct let ri = Environment.var_of_dim t.env r in of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi); (GobApron.Coeff.s_of_z c, ri)] o :: acc in - BatOption.get t.d |> fun (_,map) -> EConj.IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + BatOption.get t.d |> fun ((_,map),_) -> EConj.IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 @@ -827,4 +944,4 @@ struct end include SharedFunctions.AssertionModule (D.V) (D) (ConvArg) include D -end +end \ No newline at end of file From 231e1649cf3c82f944f2f9ec34b6e92060d64307 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 5 Feb 2025 01:24:49 +0100 Subject: [PATCH 03/86] Simple tests are working, no regression failures anymore --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 191 ++++++++++++------ 1 file changed, 134 insertions(+), 57 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 5c0050773e..2940cb2684 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -32,15 +32,17 @@ struct | Int i -> i | _ -> failwith "get_int_t on top value" + let neg_s = function + | Pos -> Neg + | Neg -> Pos + let lift2 op t1 t2 = match t1, t2 with Int t1, Int t2 -> Int (op t1 t2) | Top Neg, Top Pos | Top Pos, Top Neg -> Top Neg - | t, Int _ (*TODO I think this should switch sign when int is negativem*) - | Int _, t -> t - | Top Neg, Top Neg -> Top Pos - | Top Pos, Top Pos -> Top Pos + | Top s, _ + | _, Top s -> Top s let lift2_1 op t1 t2 = match t1 with | Int t1 -> Int (op t1 t2) @@ -62,12 +64,37 @@ struct | Int i -> Int (Int_t.abs i) | Top _ -> Top Pos - let add = lift2 Int_t.add - let sub = lift2 Int_t.sub - let mul = lift2 Int_t.mul - let div = lift2 Int_t.div - - (*TODO will these two make problems later?*) + let add a b = match a,b with + | Int a, Int b -> Int (Int_t.add a b) + | Top s, _ + | _, Top s -> Top s + let sub a b = match a,b with + | Int a, Int b -> Int (Int_t.sub a b) + | Top s, _ -> Top s + | Int _, Top Pos -> Top Neg + | Int _, Top Neg -> Top Pos + + + let mul a b = match a,b with + | Int a, Int b -> Int (Int_t.mul a b) + | Top s, Int x + | Int x, Top s -> + let comp = Int_t.compare x Int_t.zero in + if comp = 0 then Int (Int_t.zero) + else if comp < 0 then Top (neg_s s) + else Top s + | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) + let div a b = match a,b with + | Int a, Int b -> Int (Int_t.div a b) + | Top s, Int x + | Int x, Top s -> + let comp = Int_t.compare x Int_t.zero in + if comp = 0 then Int (Int_t.zero) + else if comp < 0 then Top (neg_s s) + else Top s + | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) + + (*TODO will rem/gcd/shift/logical functions lead to problems??*) let rem = lift2 Int_t.rem let gcd = lift2 Int_t.gcd @@ -82,8 +109,20 @@ struct (**TODO not clear what this should do*) let top_range _ _ = false - let max = lift2 Int_t.max - let min = lift2 Int_t.min + let max a b = + match a,b with + | Top Neg, m + | m, Top Neg -> m + | Top Pos, _ + | _, Top Pos -> Top Pos + | Int a, Int b -> Int (Int_t.max a b) + let min a b = + match a,b with + | Top Pos, m + | m, Top Pos -> m + | Top Neg, _ + | _, Top Neg -> Top Neg + | Int a, Int b -> Int (Int_t.min a b) let of_int i = Int (Int_t.of_int i) let to_int t = Int_t.to_int @@ get_int_t t @@ -145,10 +184,11 @@ module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOp let norm ?(suppress_ovwarn=false) ?(cast=false) ik t = let t = match t with - | Some (Top Pos, Top Neg) -> Some (Top Neg, Top Pos) - | Some (l, Top Neg) -> Some (l, Top Pos) - | Some (Top Pos, u) -> Some (Top Neg, u) - | _ -> t + | Some (Top Pos, Top Neg) -> Some (Top Neg, Top Pos) + | Some (l, Top Neg) -> Some (l, Top Pos) + | Some (Top Pos, u) -> Some (Top Neg, u) + | Some (Int a, Int b) when Z.compare a b > 0 -> None + | _ -> t in (t,IntDomain0.{underflow=false; overflow=false}) end @@ -158,6 +198,9 @@ module Interval = struct let ik = IChar (*Placeholder for all functions that need one*) let of_bigint x = of_int ik (TopIntOps.of_bigint x) + + let contains t i = leq (of_bigint i) t + end module EqualitiesConjunctionWithIntervals = @@ -195,23 +238,34 @@ struct let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,Array.to_list indexes) in (* Build new map during fold with bumped keys *) a + let modify_variables_in_domain_intervals map indexes op = + let res = modify_variables_in_domain_intervals map indexes op in if M.tracing then + M.tracel "modify_dims" "dimarray bumping with (fun x -> x + %d) at positions [%s] in { %s } -> { %s }" + (op 0 1) + (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) indexes "") + (show_intervals (Printf.sprintf "var_%d") map) + (show_intervals (Printf.sprintf "var_%d") res); + res + + let make_empty_with_size size = (EConj.make_empty_conj size, IntMap.empty) let dim_add (ch: Apron.Dim.change) (econj, i) = (EConj.dim_add ch econj, modify_variables_in_domain_intervals i ch.dim (+)) + let forget_variable (econj, is) var = (EConj.forget_variable econj var, IntMap.remove var is) + + let dim_remove (ch: Apron.Dim.change) (econj, i) ~del = if Array.length ch.dim = 0 || EConj.is_empty econj then (econj, i) else ( let cpy = Array.copy ch.dim in Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) - let econj' = Array.fold_lefti (fun y i x -> EConj.forget_variable y (x)) econj cpy in (* clear m' from relations concerning ch.dim *) + let (econj', i') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, i) cpy in (* clear m' from relations concerning ch.dim *) let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in - let i' = modify_variables_in_domain_intervals i cpy (-) in - (econj'', i')) - - let forget_variable (econj, is) var = (EConj.forget_variable econj var, IntMap.add var (Interval.top_of Interval.ik) is) + let i'' = modify_variables_in_domain_intervals i' cpy (-) in + (econj'', i'')) let get_rhs t = EConj.get_rhs (fst t) @@ -228,20 +282,26 @@ struct None -> I.top_of I.ik(*uninitialised*) | Some i -> I.div I.ik (I.add I.ik (I.of_bigint o) @@ I.mul I.ik (I.of_bigint coeff) i) (I.of_bigint d) + let get_interval t lhs = + let res = get_interval t lhs in + if M.tracing then M.tracel "get_interval" "reading var_%d from %s -> %s" lhs (show t) (Interval.show res); + res + + let set_interval ((econ, is):t) lhs i = let refine _ _ = identity in (**TODO do some refinement based on the fact that all variables must be integers*) let set_interval_for_root lhs i = let i = refine econ lhs i in if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Interval.show i); - match I.to_int i with - | None -> (econ, IntMap.add lhs i is) (*Not a constant*) - | Some (Top _) -> (econ, IntMap.remove lhs is) (*Top -> do not save*) (*TODO I think somewhere else we might save top values -> fix?*) - | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) - let update_references = function - | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) - | t -> t - in - ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is) + if i = Interval.top_of Interval.ik then (econ, IntMap.remove lhs is) (*stay sparse*) + else match I.to_int i with + | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) + let update_references = function + | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) + | t -> t + in + ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is) + | _ -> (econ, IntMap.add lhs i is) (*Not a constant*) in let (v,o,d) = get_rhs (econ, is) lhs in if (v,o,d) = Rhs.var_zero lhs then set_interval_for_root lhs i @@ -250,7 +310,7 @@ struct | None -> (econ, is) (*For a constant, we do not need to save an interval*) (*TODO should we check for equality?*) | Some (coeff, v) -> let i1 = I.mul I.ik (I.of_bigint d) i in - let i2 = I.sub I.ik (I.of_bigint o) i1 in + let i2 = I.sub I.ik i1 (I.of_bigint o) in let i3 = I.div I.ik i2 (I.of_bigint coeff) in let i_transformed = i3 in if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Interval.show i) (Interval.show i1) (Interval.show i2) (Interval.show i3); @@ -299,7 +359,11 @@ struct | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise EConj.Contradiction else ts, is (* o/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_h1 = (o*d1-o1*d)/(d*c1) /\ x_i = o/d *) - | None , (Some (coeff1,h1), o1, divi1) -> subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) + | None , (Some (coeff1,h1), o1, divi1) -> + if not @@ Interval.contains (get_interval (ts,is) i ) (Z.div offs divi) then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj var_%d: meeting Constant: %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Interval.show (get_interval (ts,is) i )); + raise EConj.Contradiction) + else subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) (* (c*x_j+o)/d = x_i = o1/d1 *) (* ======> x_j = (o1*d-o*d1)/(d1*c) /\ x_i = o1/d1 *) | Some (coeff,j), (None , o1, divi1) -> subst_var (ts, is) j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) @@ -332,7 +396,10 @@ struct let meet_with_one_interval var interval t = let new_interval = I.meet I.ik interval (get_interval t var) - in set_interval t var new_interval + in if new_interval = None then raise EConj.Contradiction else + let res = set_interval t var new_interval + in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Interval.show @@ get_interval t var) (Interval.show interval) (Interval.show new_interval) (show t) (show res); + res end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -536,7 +603,15 @@ struct let pretty () (x:t) = text (show x) let printXml f x = BatPrintf.fprintf f "\n\n\nequalities\n\n\n%s\n\nenv\n\n\n%a\n\n\n" (XmlUtil.escape (show x)) Environment.printXml x.env - let eval_interval ask = Bounds.bound_texpr + let eval_interval ask t texpr = + let from_top = function + | TopIntOps.Int x -> Some x + | _ -> None + in let i = eval_texpr t (Texpr1.to_expr texpr) + in if M.tracing then M.tracel "eval_interval" "evaluating %a in %s to %s" Texpr1.pretty texpr (show t) (Interval.show i); + match i with + | None -> (None, None) + | Some (l, u) -> (from_top l, from_top u) let meet_with_one_conj t i (var, o, divi) = match t.d with @@ -545,7 +620,7 @@ struct try { d = Some (EConjI.meet_with_one_conj d i (var, o, divi)); env = t.env} with EConj.Contradiction -> - if M.tracing then M.trace "meet" " -> Contradiction\n"; + if M.tracing then M.trace "meet" " -> Contradiction with conj\n"; { d = None; env = t.env} let meet_with_one_conj t i e = @@ -557,7 +632,11 @@ struct let res = match t.d with | None -> t | Some d -> - { d = Some (EConjI.meet_with_one_interval i interval d ); env = t.env} + try + { d = Some (EConjI.meet_with_one_interval i interval d ); env = t.env} + with EConj.Contradiction -> + if M.tracing then M.trace "meet" " -> Contradiction with interval\n"; + { d = None; env = t.env} in if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Interval.show interval) (show res); res @@ -624,7 +703,7 @@ struct match econj' with None -> None | Some econj'' -> - let is' = collect_intervals x y econj'' ((fst @@ fst x) - 1) (EConjI.IntMap.empty) in + let is' = collect_intervals x y econj'' ((Environment.size env)-1) (EConjI.IntMap.empty) in Some (econj'', is') in (*Normalize the two domains a and b such that both talk about the same variables*) @@ -649,6 +728,8 @@ struct let join a b = let res = join a b in if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; + assert(leq a res); + assert(leq b res); res let widen = join' (Interval.widen Interval.ik) @@ -810,7 +891,7 @@ struct | Some d -> let expr = (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) in (* meet EConj*) - let t = match simplified_monomials_from_texp t expr with + let t' = match simplified_monomials_from_texp t expr with | None -> t | Some (sum_of_terms, (constant,divisor)) ->( match sum_of_terms with @@ -841,25 +922,21 @@ struct | _-> t (* Not supported in equality based 2vars without coeffiients *) end | _ -> t (* For equalities of more then 2 vars we just return t *)) - in (*meet interval*) (*TODO this should be extended much further, should reuse some code from base -> meet with CIL expression instead?*) - (* currently only supports simple assertions x > c*) - (*match expr, Tcons1.get_typ tcons with - | Var v, SUP -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval match" ; - meet_with_one_interval (Environment.dim_of_var t.env v) (Interval.of_bigint Z.zero) t - | _, _ -> t *) - (*match expr with - | Binop (Sub,Var v,Cst (Scalar c),_,_) -> - begin match SharedFunctions.int_of_scalar ?round:None c with - | None -> t - | Some c -> begin match Tcons1.get_typ tcons with - | SUP -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons meet interval"; - meet_with_one_interval (Environment.dim_of_var t.env v) (Some (Int (Z.add Z.one (Z.neg c)), Top Pos)) t - | _ -> t - end - end - | _ ->*) t + in if t'.d = None then t' else + (*meet interval*) (*TODO this should be extended much further, should reuse some code from base -> meet with CIL expression instead?*) + (* currently only supports simple assertions x > c*) + match expr with + | Binop (Sub,Var v,Cst (Scalar c),_,_) -> + begin match SharedFunctions.int_of_scalar ?round:None c with + | None -> t' + | Some c -> begin match Tcons1.get_typ tcons with + | SUP -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons meet interval %s - %s > 0 env: %s " (Var.to_string v) (Z.to_string c) (Environment.show t'.env); + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos)) t' + | _ -> t' + end + end + | _ -> t' let meet_tcons ask t tcons original_expr no_ov = From 5bdf17fa0240cd16e893708da21305722cc9f8e2 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 10 Feb 2025 16:31:09 +0100 Subject: [PATCH 04/86] extended conditions + small cleanup --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 35 ++++++++++++++----- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 2940cb2684..54ba18bf75 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -180,7 +180,7 @@ module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOp let range _ = (Top Neg, Top Pos) let top_of ik = Some (range ik) - let bot_of ik = None + let bot_of _ = None let norm ?(suppress_ovwarn=false) ?(cast=false) ik t = let t = match t with @@ -228,7 +228,6 @@ struct let is_top_con (e, is) = EConj.is_top_con e && IntMap.is_empty is - (**TODO Test this code*) let modify_variables_in_domain_intervals map indexes op = if Array.length indexes = 0 then map else let rec bumpentry k v = function @@ -321,8 +320,6 @@ struct if M.tracing then M.tracel "modify_pentagon" "set_interval before: %s eq: var_%d=%s -> %s " (show t) lhs (Interval.show i) (show res); res - - (**Assumes that values of variables and all other rhs stay the same. TODO can it happen that multiple rhs update at the same time? Problem if a variable is removed from the group in the same step?*) let set_rhs (econ, is) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with @@ -923,20 +920,40 @@ struct end | _ -> t (* For equalities of more then 2 vars we just return t *)) in if t'.d = None then t' else - (*meet interval*) (*TODO this should be extended much further, should reuse some code from base -> meet with CIL expression instead?*) - (* currently only supports simple assertions x > c*) + (*meet interval*) (*TODO this could be extended much further, maybe reuse some code from base -> meet with CIL expression instead?*) + (* currently only supports simple assertions x > c (x - c > 0)*) match expr with | Binop (Sub,Var v,Cst (Scalar c),_,_) -> begin match SharedFunctions.int_of_scalar ?round:None c with | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons meet interval %s - %s > 0 env: %s " (Var.to_string v) (Z.to_string c) (Environment.show t'.env); meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos)) t' - | _ -> t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos)) t' + | EQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c)) t' (*Should already be matched by the conjuction above?*) + | _ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; + t' (*NEQ and EQMOD do not have any usefull interval representations*) + (*TODO If we have e.g. y = 5x + 2 and condition y == 14 (or y != 14), we know this can't (must) be correct*) + end + end + | Binop (Sub,Cst (Scalar c), Var v,_,_) -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching structure 1"; + begin match SharedFunctions.int_of_scalar ?round:None c with + | None -> t' + | Some c -> begin match Tcons1.get_typ tcons with + | SUP -> + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one))) t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c)) t' + | EQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c)) t' (*Should already be matched by the conjuction above?*) + | _ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; + t' (*NEQ and EQMOD do not have any usefull interval representations*) end end - | _ -> t' + | _ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure"; + t' let meet_tcons ask t tcons original_expr no_ov = From f2e1fb6aa9a1f258f781c1569ad41a38f82083ac Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 12 Feb 2025 23:55:13 +0100 Subject: [PATCH 05/86] Add config for gobcron testing --- conf/svcomp25_testing.json | 119 +++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 conf/svcomp25_testing.json diff --git a/conf/svcomp25_testing.json b/conf/svcomp25_testing.json new file mode 100644 index 0000000000..250760fc51 --- /dev/null +++ b/conf/svcomp25_testing.json @@ -0,0 +1,119 @@ +{ + "ana": { + "sv-comp": { + "enabled": true, + "functions": true + }, + "int": { + "def_exc": true, + "enums": false, + "interval": true + }, + "float": { + "interval": true, + "evaluate_math_functions": true + }, + "activated": [ + "base", + "threadid", + "threadflag", + "threadreturn", + "mallocWrapper", + "mutexEvents", + "mutex", + "access", + "race", + "escape", + "expRelation", + "mhp", + "assert", + "var_eq", + "symb_locks", + "region", + "thread", + "threadJoins", + "abortUnless", + "lin2vareq_p" + ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "memLeak", + "threadflag" + ], + "context": { + "widen": false + }, + "base": { + "arrays": { + "domain": "partitioned" + } + }, + "race": { + "free": false, + "call": false + }, + "autotune": { + "enabled": false, + "activated": [ + "singleThreaded", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "congruence", + "octagon", + "wideningThresholds", + "loopUnrollHeuristic", + "memsafetySpecification", + "noOverflows", + "termination", + "tmpSpecialAnalysis" + ] + } + }, + "exp": { + "region-offsets": true + }, + "solver": "td3", + "sem": { + "unknown_function": { + "spawn": false + }, + "int": { + "signed_overflow": "assume_none" + }, + "null-pointer": { + "dereference": "assume_none" + } + }, + "witness": { + "graphml": { + "enabled": true, + "id": "enumerate", + "unknown": false + }, + "yaml": { + "enabled": true, + "format-version": "2.0", + "entry-types": [ + "invariant_set" + ], + "invariant-types": [ + "loop_invariant" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": false, + "other": false, + "accessed": false, + "exact": true + } + }, + "pre": { + "enabled": false + } +} From 003f3321c56d01bcb3160f8f8ba0351729d6701f Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 14 Feb 2025 01:08:03 +0100 Subject: [PATCH 06/86] second conf for testing --- conf/svcomp25_testing2.json | 119 ++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 conf/svcomp25_testing2.json diff --git a/conf/svcomp25_testing2.json b/conf/svcomp25_testing2.json new file mode 100644 index 0000000000..d7d6cec70e --- /dev/null +++ b/conf/svcomp25_testing2.json @@ -0,0 +1,119 @@ +{ + "ana": { + "sv-comp": { + "enabled": true, + "functions": true + }, + "int": { + "def_exc": true, + "enums": false, + "interval": true + }, + "float": { + "interval": true, + "evaluate_math_functions": true + }, + "activated": [ + "base", + "threadid", + "threadflag", + "threadreturn", + "mallocWrapper", + "mutexEvents", + "mutex", + "access", + "race", + "escape", + "expRelation", + "mhp", + "assert", + "var_eq", + "symb_locks", + "region", + "thread", + "threadJoins", + "abortUnless", + "lin2vareq" + ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "memLeak", + "threadflag" + ], + "context": { + "widen": false + }, + "base": { + "arrays": { + "domain": "partitioned" + } + }, + "race": { + "free": false, + "call": false + }, + "autotune": { + "enabled": false, + "activated": [ + "singleThreaded", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "congruence", + "octagon", + "wideningThresholds", + "loopUnrollHeuristic", + "memsafetySpecification", + "noOverflows", + "termination", + "tmpSpecialAnalysis" + ] + } + }, + "exp": { + "region-offsets": true + }, + "solver": "td3", + "sem": { + "unknown_function": { + "spawn": false + }, + "int": { + "signed_overflow": "assume_none" + }, + "null-pointer": { + "dereference": "assume_none" + } + }, + "witness": { + "graphml": { + "enabled": true, + "id": "enumerate", + "unknown": false + }, + "yaml": { + "enabled": true, + "format-version": "2.0", + "entry-types": [ + "invariant_set" + ], + "invariant-types": [ + "loop_invariant" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": false, + "other": false, + "accessed": false, + "exact": true + } + }, + "pre": { + "enabled": false + } +} From 8e5ff628dcde3283007cc06a2409a65a2508bfee Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 15 Feb 2025 20:31:04 +0100 Subject: [PATCH 07/86] Take advantage of congruence information for refinement and asserts --- .../int/congruenceDomainNormFunctor.ml | 532 ++++++++++++++++++ ...inearTwoVarEqualityDomainPentagon.apron.ml | 212 +++++-- 2 files changed, 682 insertions(+), 62 deletions(-) create mode 100644 src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml diff --git a/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml b/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml new file mode 100644 index 0000000000..0ea6f350e8 --- /dev/null +++ b/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml @@ -0,0 +1,532 @@ +open IntDomain0 +open GoblintCil + +(*TODO Test and remove code duplication*) +module type Norm = sig + val normalize : ikind -> (Z.t * Z.t) option -> (Z.t * Z.t) option +end + +module Wrapping : Norm = struct + + let (%:) = Z.rem + let (=:) = Z.equal + let (+:) = Z.add + let (<:) x y = Z.compare x y < 0 + + 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') +end + +module NoWrapping : Norm = struct + + let (%:) = Z.rem + let (=:) = Z.equal + let (+:) = Z.add + let (<:) x y = Z.compare x y < 0 + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + 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') +end + +module Congruence (Norm : Norm): 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 = Norm.normalize + + 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 diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 54ba18bf75..4654980fad 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -193,28 +193,83 @@ module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOp end (*TODO add wrapper to remove ikind parameter or not? *) -module Interval = struct - include IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) +module IntervalAndCongruence = struct + module I = IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) + module C = CongruenceDomainNormFunctor.Congruence(CongruenceDomainNormFunctor.NoWrapping) - let ik = IChar (*Placeholder for all functions that need one*) - let of_bigint x = of_int ik (TopIntOps.of_bigint x) + type t = I.t * C.t [@@deriving eq, ord, hash] + + let show (i,c) = I.show i ^ "," ^ C.show c + + let ik = IChar (*Placeholder for all functions that need one. Should not matter, but choosen small so that errors are detected with smaller numbers already*) + + let top = I.top_of ik, C.top_of ik + + let is_top = equal top + + let is_bot = function + | None, None -> true + | _,_ -> false + + let of_bigint x = (I.of_int ik (TopIntOps.of_bigint x), C.of_int ik x) + + let leq (i1,c1) (i2,c2) = I.leq i1 i2 && C.leq c1 c2 + + let contains t v = leq (of_bigint v) t + + let contains t v = + let res = contains t v in + if M.tracing then M.tracel "contains" "is %s conained in %s -> %b" (Z.to_string v) (show t) (res); + res + + let refine t = + let refine_step (i,c) = + let c' = match i with + | Some (TopIntOps.Int x, TopIntOps.Int y) -> C.refine_with_interval ik c (Some (x,y)) + | Some _ -> c (*No refinement possible if one side is infinite*) + | _ -> None + in + (I.refine_with_congruence ik i (BatOption.map (fun (x,y) -> (TopIntOps.Int x,TopIntOps.Int y)) c) ), c' + in + let t' = refine_step t in + if t' = t then t else refine_step t' (*The second refinement is necessary if the refinement leads to a constant, otherwise not*) + + let add (i1,c1) (i2,c2) = refine (I.add ~no_ov:true ik i1 i2, C.add ~no_ov:true ik c1 c2) + + let sub (i1,c1) (i2,c2) = refine (I.sub ~no_ov:true ik i1 i2, C.sub ~no_ov:true ik c1 c2) + + let mul (i1,c1) (i2,c2) = refine (I.mul ~no_ov:true ik i1 i2, C.mul ~no_ov:true ik c1 c2) + + let div (i1,c1) (i2,c2) = refine (I.div ~no_ov:true ik i1 i2, C.div ~no_ov:true ik c1 c2) + + let rem (i1,c1) (i2,c2) = refine (I.rem ik i1 i2, C.rem ik c1 c2) + + let neg (i,c) = refine (I.neg ~no_ov:true ik i, C.neg ~no_ov:true ik c) + + let to_int (i,_) = I.to_int i + + let meet (i1,c1) (i2,c2) = refine (I.meet ik i1 i2, C.meet ik c1 c2) + let join (i1,c1) (i2,c2) = refine (I.join ik i1 i2, C.join ik c1 c2) + let widen (i1,c1) (i2,c2) = refine (I.widen ik i1 i2, C.widen ik c1 c2) + + let of_congruence c = refine (I.top_of ik, C.of_congruence ik c) - let contains t i = leq (of_bigint i) t end +module Value = IntervalAndCongruence + module EqualitiesConjunctionWithIntervals = struct module IntMap = EConj.IntMap - module I = Interval - type t = EConj.t * (Interval.t IntMap.t) [@@deriving eq, ord] + type t = EConj.t * (Value.t IntMap.t) [@@deriving eq, ord] - let hash (econj, x) = EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + I.hash value) x 0 + let hash (econj, x) = EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Value.hash value) x 0 let show_intervals formatter is = if IntMap.is_empty is then "{}" else - let str = IntMap.fold (fun k v acc -> Printf.sprintf "%s=%s , %s" (formatter k) (I.show v) acc) is "" in + let str = IntMap.fold (fun k v acc -> Printf.sprintf "%s=%s , %s" (formatter k) (Value.show v) acc) is "" in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" let show_formatted formatter ((dim, econj), is) = Printf.sprintf "(%s, %s)" (EConj.show_formatted formatter econj) (show_intervals formatter is) @@ -274,26 +329,44 @@ struct Some i -> i | None -> (*If there is no interval saved, we have calculate it*) let (v,o,d) = get_rhs (econ, is) lhs in - if (v,o,d) = Rhs.var_zero lhs then I.top_of I.ik (*uninitialised -> Tot*) + if (v,o,d) = Rhs.var_zero lhs then Value.top (*no relation -> Top*) else match v with - None -> I.div I.ik (I.of_bigint o) (I.of_bigint d)(*constant*) (*TODO is divisor always 1?*) + None -> Value.div (Value.of_bigint o) (Value.of_bigint d)(*constant*) (*TODO is divisor always 1?*) | Some (coeff,v) -> match IntMap.find_opt v is with - None -> I.top_of I.ik(*uninitialised*) - | Some i -> I.div I.ik (I.add I.ik (I.of_bigint o) @@ I.mul I.ik (I.of_bigint coeff) i) (I.of_bigint d) + None -> Value.top (*uninitialised*) + | Some i -> Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) let get_interval t lhs = let res = get_interval t lhs in - if M.tracing then M.tracel "get_interval" "reading var_%d from %s -> %s" lhs (show t) (Interval.show res); + if M.tracing then M.tracel "get_interval" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); res - let set_interval ((econ, is):t) lhs i = - let refine _ _ = identity in (**TODO do some refinement based on the fact that all variables must be integers*) + let refine econ lhs i =(**TODO do not recalculate this every time?*) + (*calculate the congruence constraint for x from a single equation (cx + o) / d *) + let congruence_of_rhs (c, o, d) = + (*adapted euclids extended algorithm for calculating the modular multiplicative inverse*) + let rec inverse t r t_old r_old = + if Z.equal r Z.zero + then t_old + else + let q = Z.div r_old r in + inverse (Z.sub t_old (Z.mul q t)) (Z.sub r_old (Z.mul q r)) t r + in let inverse a n = inverse Z.one a Z.zero n + (* x = -o c^-1 (mod d) *) + in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) + in + let meet_with_rhs _ rhs i = match rhs with + | (Some (c, v), o, d) when v = lhs -> Value.meet i (congruence_of_rhs (c, o, d)) + | _ -> i + in + IntMap.fold meet_with_rhs (snd econ) i + in let set_interval_for_root lhs i = let i = refine econ lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Interval.show i); - if i = Interval.top_of Interval.ik then (econ, IntMap.remove lhs is) (*stay sparse*) - else match I.to_int i with + if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Value.show i); + if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) + else match Value.to_int i with | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) let update_references = function | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) @@ -308,18 +381,19 @@ struct match v with | None -> (econ, is) (*For a constant, we do not need to save an interval*) (*TODO should we check for equality?*) | Some (coeff, v) -> - let i1 = I.mul I.ik (I.of_bigint d) i in - let i2 = I.sub I.ik i1 (I.of_bigint o) in - let i3 = I.div I.ik i2 (I.of_bigint coeff) in + let i1 = Value.mul (Value.of_bigint d) i in + let i2 = Value.sub i1 (Value.of_bigint o) in + let i3 = Value.div i2 (Value.of_bigint coeff) in let i_transformed = i3 in - if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Interval.show i) (Interval.show i1) (Interval.show i2) (Interval.show i3); + if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Value.show i) (Value.show i1) (Value.show i2) (Value.show i3); set_interval_for_root v i_transformed let set_interval t lhs i = let res = set_interval t lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_interval before: %s eq: var_%d=%s -> %s " (show t) lhs (Interval.show i) (show res); + if M.tracing then M.tracel "modify_pentagon" "set_interval before: %s eq: var_%d=%s -> %s " (show t) lhs (Value.show i) (show res); res + (*TODO: If we are uptdating a variable, we will overwrite the interval again -> maybe skip setting it here, because of performance?*) let set_rhs (econ, is) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with @@ -327,7 +401,7 @@ struct | _ -> let new_constraint = get_interval (econ', is) lhs in let old_constraint = get_interval (econ, is) lhs in - let new_interval = I.meet I.ik new_constraint old_constraint in + let new_interval = Value.meet new_constraint old_constraint in set_interval (econ', is) lhs new_interval let set_rhs t lhs rhs = @@ -339,6 +413,7 @@ struct let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = let subst_var ((dim,econj), is) x (vary, o, d) = + let (vary, o, d) = Rhs.canonicalize (vary, o, d) in (* [[x substby (cy+o)/d ]] ((c'x+o')/d') *) (* =====> (c'cy + c'o+o'd)/(dd') *) let adjust = function @@ -346,10 +421,18 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + (match vary with + | None when d <> Z.one -> (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); + raise EConj.Contradiction) + | _ -> () + ); let interval = get_interval (ts, is) x in - let is' = IntMap.remove x is in - set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + if not @@ Value.contains interval (Z.div offs divi) then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show interval); + raise EConj.Contradiction) + else + let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -357,10 +440,7 @@ struct (* o/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_h1 = (o*d1-o1*d)/(d*c1) /\ x_i = o/d *) | None , (Some (coeff1,h1), o1, divi1) -> - if not @@ Interval.contains (get_interval (ts,is) i ) (Z.div offs divi) then - (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj var_%d: meeting Constant: %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Interval.show (get_interval (ts,is) i )); - raise EConj.Contradiction) - else subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) + subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) (* (c*x_j+o)/d = x_i = o1/d1 *) (* ======> x_j = (o1*d-o*d1)/(d1*c) /\ x_i = o1/d1 *) | Some (coeff,j), (None , o1, divi1) -> subst_var (ts, is) j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) @@ -391,11 +471,12 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res - let meet_with_one_interval var interval t = - let new_interval = I.meet I.ik interval (get_interval t var) - in if new_interval = None then raise EConj.Contradiction else + let meet_with_one_interval var interval t = + let refined_interval = Value.refine interval in + let new_interval = Value.meet refined_interval (get_interval t var) + in if Value.is_bot new_interval then raise EConj.Contradiction else let res = set_interval t var new_interval - in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Interval.show @@ get_interval t var) (Interval.show interval) (Interval.show new_interval) (show t) (show res); + in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_interval t var) (Value.show interval) (Value.show new_interval) (show t) (show res); res end @@ -489,35 +570,35 @@ struct let eval_texpr (t:t) texp = let open Apron.Texpr1 in let binop_function = function - | Add -> Interval.add Interval.ik - | Sub -> Interval.sub Interval.ik - | Mul -> Interval.mul Interval.ik - | Div -> Interval.div Interval.ik - | Mod -> Interval.rem Interval.ik + | Add -> Value.add + | Sub -> Value.sub + | Mul -> Value.mul + | Div -> Value.div + | Mod -> Value.rem | Pow -> failwith "power is not supported" (*TODO should this be supported*) in let unop_function = function - | Neg -> Interval.neg Interval.ik + | Neg -> Value.neg | Cast -> identity | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) in let rec eval = function | Cst (Scalar x) -> begin match SharedFunctions.int_of_scalar ?round:None x with - | Some x -> Interval.of_bigint x - | None -> Interval.top_of Interval.ik + | Some x -> Value.of_bigint x + | None -> Value.top end | Cst (Interval _) -> failwith "constant was an interval; this is not supported" (*TODO monomials_from_texp does not support this as well, but maybe we should*) | Var x -> let var_dim = Environment.dim_of_var t.env x in begin match t.d with - | None -> Interval.top_of Interval.ik + | None -> Value.top | Some d -> EConjI.get_interval d var_dim end | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) | Unop (op, a, Int, _) -> (unop_function op) (eval a) - | _ -> Interval.top_of Interval.ik (*not integers*) + | _ -> Value.top (*not integers*) in let res = eval texp in - if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Interval.show res); + if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Value.show res); res @@ -605,8 +686,8 @@ struct | TopIntOps.Int x -> Some x | _ -> None in let i = eval_texpr t (Texpr1.to_expr texpr) - in if M.tracing then M.tracel "eval_interval" "evaluating %a in %s to %s" Texpr1.pretty texpr (show t) (Interval.show i); - match i with + in if M.tracing then M.tracel "eval_interval" "evaluating %a in %s to %s" Texpr1.pretty texpr (show t) (Value.show i); + match fst i with | None -> (None, None) | Some (l, u) -> (from_top l, from_top u) @@ -635,7 +716,7 @@ struct if M.tracing then M.trace "meet" " -> Contradiction with interval\n"; { d = None; env = t.env} in - if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Interval.show interval) (show res); + if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Value.show interval) (show res); res let meet t1 t2 = @@ -665,7 +746,7 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in - let implies_interval v i interval = Interval.leq (EConjI.get_interval v i) interval + let implies_interval v i interval = Value.leq (EConjI.get_interval v i) interval in if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true @@ -691,7 +772,7 @@ struct if vars < 0 then is else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) is (*we only need intervals for roots of the connected components*) else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in (*TODO: if we tighten the interval in set_interval, we also should do that here.*) - if Interval.is_top_of Interval.ik joined_interval + if Value.is_top joined_interval then collect_intervals x y econj_joined (vars-1) is (*DO not add top intervals*) else collect_intervals x y econj_joined (vars-1) (EConjI.IntMap.add vars joined_interval is) in @@ -719,7 +800,7 @@ struct | Some x, Some y -> {d = join_d x y a.env; env = a.env} - let join = join' (Interval.join Interval.ik) + let join = join' (Value.join) let join a b = timing_wrap "join" (join a) b let join a b = @@ -729,7 +810,7 @@ struct assert(leq b res); res - let widen = join' (Interval.widen Interval.ik) + let widen = join' (Value.widen) let widen a b = let res = widen a b in @@ -919,18 +1000,21 @@ struct | _-> t (* Not supported in equality based 2vars without coeffiients *) end | _ -> t (* For equalities of more then 2 vars we just return t *)) - in if t'.d = None then t' else + in if t'.d = None then (if M.tracing then M.tracel "meet_tcons" "meet_conj resulted in None (expr: %s)" (Tcons1.show tcons); t') else begin (*meet interval*) (*TODO this could be extended much further, maybe reuse some code from base -> meet with CIL expression instead?*) (* currently only supports simple assertions x > c (x - c > 0)*) + if M.tracing then M.tracel "meet_tcons" "after conj: %s (expr: %s)" (show t') (Tcons1.show tcons); match expr with | Binop (Sub,Var v,Cst (Scalar c),_,_) -> begin match SharedFunctions.int_of_scalar ?round:None c with | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos)) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos)) t' - | EQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c)) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top_of Value.ik) t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top_of Value.ik) t' + | EQ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq" ; + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top_of Value.ik) t' (*Should already be matched by the conjuction above?*) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; t' (*NEQ and EQMOD do not have any usefull interval representations*) @@ -943,17 +1027,20 @@ struct | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one))) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c)) t' - | EQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c)) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top_of Value.ik) t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top_of Value.ik) t' + | EQ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq (expr %s)" (Tcons1.show tcons); + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top_of Value.ik) t' (*Should already be matched by the conjuction above?*) | _ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op (expr %s)" (Tcons1.show tcons); t' (*NEQ and EQMOD do not have any usefull interval representations*) end end | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure"; t' + end let meet_tcons ask t tcons original_expr no_ov = @@ -992,6 +1079,7 @@ struct let relift t = t + (*TODO add value information to invariants?*) (** representation as C expression This function returns all the equalities that are saved in our datastructure t. From 1d6ebc28f9530805cc5fd48a26258873dab70df0 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 17 Feb 2025 14:21:53 +0100 Subject: [PATCH 08/86] Fixes for meeting returning bot, Small cleanup --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 44 +++++++++---------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 4654980fad..e29fc383c7 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -192,7 +192,7 @@ module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOp in (t,IntDomain0.{underflow=false; overflow=false}) end -(*TODO add wrapper to remove ikind parameter or not? *) +(*TODO can I use the domain tuple? seems rather complicated*) module IntervalAndCongruence = struct module I = IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) module C = CongruenceDomainNormFunctor.Congruence(CongruenceDomainNormFunctor.NoWrapping) @@ -254,7 +254,6 @@ module IntervalAndCongruence = struct let of_congruence c = refine (I.top_of ik, C.of_congruence ik c) - end module Value = IntervalAndCongruence @@ -421,18 +420,17 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - (match vary with - | None when d <> Z.one -> (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); - raise EConj.Contradiction) - | _ -> () - ); - let interval = get_interval (ts, is) x in - if not @@ Value.contains interval (Z.div offs divi) then - (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show interval); - raise EConj.Contradiction) - else - let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) - set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + let interval= get_interval (ts, is) x in + if vary = None then begin + if d <> Z.one then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); + raise EConj.Contradiction); + if not @@ Value.contains interval (Z.div offs divi) then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show interval); + raise EConj.Contradiction) + end; + let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -865,7 +863,8 @@ struct | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) - in begin match t'.d with None -> bot_env + in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); + bot_env | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t' texp)); env = t'.env} end | None -> bot_env @@ -1010,15 +1009,14 @@ struct | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top_of Value.ik) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top_of Value.ik) t' + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top ()) t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top ()) t' | EQ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq" ; - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top_of Value.ik) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; t' (*NEQ and EQMOD do not have any usefull interval representations*) - (*TODO If we have e.g. y = 5x + 2 and condition y == 14 (or y != 14), we know this can't (must) be correct*) end end | Binop (Sub,Cst (Scalar c), Var v,_,_) -> @@ -1027,18 +1025,18 @@ struct | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top_of Value.ik) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top_of Value.ik) t' + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top ()) t' + | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top ()) t' | EQ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq (expr %s)" (Tcons1.show tcons); - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top_of Value.ik) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op (expr %s)" (Tcons1.show tcons); t' (*NEQ and EQMOD do not have any usefull interval representations*) end end | _ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure"; + if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure (expr %s)" (Tcons1.show tcons); t' end From a1b3eba0e389d1b58e86e8d856332a28cf495862 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 17 Feb 2025 15:24:11 +0100 Subject: [PATCH 09/86] Fix refinement leading to bot, but not propagating --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index e29fc383c7..679832b0d3 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -356,15 +356,22 @@ struct in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) in let meet_with_rhs _ rhs i = match rhs with - | (Some (c, v), o, d) when v = lhs -> Value.meet i (congruence_of_rhs (c, o, d)) + | (Some (c, v), o, d) when v = lhs -> begin + let cong = (congruence_of_rhs (c, o, d)) in + let res = Value.meet i cong in + if M.tracing then M.tracel "refine_pentagon" "refining %s with rhs %s (constraint: %s) -> %s" (Value.show i) (Rhs.show rhs) (Value.show cong) (Value.show res); + res + end | _ -> i in IntMap.fold meet_with_rhs (snd econ) i in let set_interval_for_root lhs i = - let i = refine econ lhs i in if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Value.show i); + let i = refine econ lhs i in + if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root refined to %s" (Value.show i); if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) + else if Value.is_bot i then raise EConj.Contradiction else match Value.to_int i with | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) let update_references = function From e77e800f09fa3148b7a8212221202f05fa9b0422 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 18 Feb 2025 00:51:38 +0100 Subject: [PATCH 10/86] Fix evaluation using new context allow for narrowing of intervals --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 60 ++++++++++--------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 679832b0d3..650f68a230 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -249,6 +249,9 @@ module IntervalAndCongruence = struct let to_int (i,_) = I.to_int i let meet (i1,c1) (i2,c2) = refine (I.meet ik i1 i2, C.meet ik c1 c2) + + let narrow (i1,c1) (i2,c2) = refine (I.narrow ik i1 i2, C.narrow ik c1 c2) + let join (i1,c1) (i2,c2) = refine (I.join ik i1 i2, C.join ik c1 c2) let widen (i1,c1) (i2,c2) = refine (I.widen ik i1 i2, C.widen ik c1 c2) @@ -367,7 +370,7 @@ struct IntMap.fold meet_with_rhs (snd econ) i in let set_interval_for_root lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s" lhs (Value.show i); + if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); let i = refine econ lhs i in if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root refined to %s" (Value.show i); if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) @@ -400,7 +403,7 @@ struct res (*TODO: If we are uptdating a variable, we will overwrite the interval again -> maybe skip setting it here, because of performance?*) - let set_rhs (econ, is) lhs rhs = + let set_rhs (econ, is) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with | (None, _, _) -> econ', IntMap.remove lhs is (*when setting as a constant, we do not need a separate interval *) @@ -476,9 +479,9 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res - let meet_with_one_interval var interval t = + let meet_with_one_interval var interval t meet_function = let refined_interval = Value.refine interval in - let new_interval = Value.meet refined_interval (get_interval t var) + let new_interval = meet_function refined_interval (get_interval t var) in if Value.is_bot new_interval then raise EConj.Contradiction else let res = set_interval t var new_interval in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_interval t var) (Value.show interval) (Value.show new_interval) (show t) (show res); @@ -711,12 +714,12 @@ struct if M.tracing then M.tracel "meet" "%s with single eq %s=%s -> %s" (show t) (Z.(to_string @@ Tuple3.third e)^ show_var t.env i) (Rhs.show_rhs_formatted (show_var t.env) e) (show res); res - let meet_with_one_interval i interval t = + let meet_with_one_interval meet_function i interval t = let res = match t.d with | None -> t | Some d -> try - { d = Some (EConjI.meet_with_one_interval i interval d ); env = t.env} + { d = Some (EConjI.meet_with_one_interval i interval d meet_function); env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction with interval\n"; { d = None; env = t.env} @@ -724,16 +727,19 @@ struct if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Value.show interval) (show res); res - let meet t1 t2 = + let meet' t1 t2 meet_function = let sup_env = Environment.lce t1.env t2.env in let t1 = change_d t1 sup_env ~add:true ~del:false in let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with | Some d1', Some d2' -> let conj_met = EConjI.IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd @@ fst d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) - in EConjI.IntMap.fold meet_with_one_interval (snd d2') conj_met + in EConjI.IntMap.fold (meet_with_one_interval meet_function) (snd d2') conj_met | _ -> {d = None; env = sup_env} + let meet t1 t2 = + meet' t1 t2 Value.meet + let meet t1 t2 = let res = meet t1 t2 in if M.tracing then M.tracel "meet" "meet a: %s\n U \n b: %s \n -> %s" (show t1) (show t2) (show res) ; @@ -773,21 +779,18 @@ struct let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d in (*Check all variables (up to index vars) if we need to save an interval for them*) - let rec collect_intervals x y econj_joined vars is = - if vars < 0 then is - else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) is (*we only need intervals for roots of the connected components*) - else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in (*TODO: if we tighten the interval in set_interval, we also should do that here.*) - if Value.is_top joined_interval - then collect_intervals x y econj_joined (vars-1) is (*DO not add top intervals*) - else collect_intervals x y econj_joined (vars-1) (EConjI.IntMap.add vars joined_interval is) + let rec collect_intervals x y econj_joined vars t = + if vars < 0 then t + else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) t (*we only need intervals for roots of the connected components*) + else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in + collect_intervals x y econj_joined (vars-1) (EConjI.set_interval t vars joined_interval ) in let join_d x y env = let econj' = join_econj (fst x) (fst y) env in match econj' with None -> None | Some econj'' -> - let is' = collect_intervals x y econj'' ((Environment.size env)-1) (EConjI.IntMap.empty) in - Some (econj'', is') + Some (collect_intervals x y econj'' ((Environment.size env)-1) (econj'', EConjI.IntMap.empty)) in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with @@ -822,7 +825,7 @@ struct if M.tracing then M.tracel "widen" "widen a: %s b: %s -> %s" (show a) (show b) (show res) ; res - let narrow a b = meet a b (*TODO use narrow for intervals!*) + let narrow a b = meet' a b Value.narrow let narrow a b = let res = narrow a b in @@ -866,13 +869,14 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } + {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) - in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); - bot_env - | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t' texp)); env = t'.env} + in begin match t'.d with + None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); + bot_env + | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} end | None -> bot_env @@ -1016,11 +1020,11 @@ struct | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top ()) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top ()) t' + meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top ()) t' + | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top ()) t' | EQ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq" ; - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; t' (*NEQ and EQMOD do not have any usefull interval representations*) @@ -1032,11 +1036,11 @@ struct | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top ()) t' - | SUPEQ -> meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top ()) t' + meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top ()) t' + | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top ()) t' | EQ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq (expr %s)" (Tcons1.show tcons); - meet_with_one_interval (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op (expr %s)" (Tcons1.show tcons); t' (*NEQ and EQMOD do not have any usefull interval representations*) From e30d79f446621d151997bd5e0ef3be6e7f2fdc09 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 18 Feb 2025 02:07:46 +0100 Subject: [PATCH 11/86] Modulo conditions supported --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 46 +++++++++++++++---- 1 file changed, 37 insertions(+), 9 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 650f68a230..187928d12b 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1022,29 +1022,57 @@ struct | SUP -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top ()) t' | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top ()) t' - | EQ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq" ; - meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + | DISEQ -> + if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_bigint c) + then {d=None; env=t'.env} else t' (*TODO: if at interval bounds, we could refine the interval *) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; - t' (*NEQ and EQMOD do not have any usefull interval representations*) + t' end end | Binop (Sub,Cst (Scalar c), Var v,_,_) -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching structure 1"; begin match SharedFunctions.int_of_scalar ?round:None c with | None -> t' | Some c -> begin match Tcons1.get_typ tcons with | SUP -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top ()) t' | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top ()) t' - | EQ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval matching eq (expr %s)" (Tcons1.show tcons); - meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) + | DISEQ -> + if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_bigint c) + then {d=None; env=t'.env} else t' (*TODO: if at interval bounds, we could refine the interval *) | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op (expr %s)" (Tcons1.show tcons); - t' (*NEQ and EQMOD do not have any usefull interval representations*) + t' + end + end + (*x % m == o *) + | Binop (Sub, Binop (Mod, Var v, Cst (Scalar m), _, _) , Cst (Scalar o),_,_) -> + begin match SharedFunctions.int_of_scalar ?round:None m, SharedFunctions.int_of_scalar ?round:None o with + | Some m, Some o -> begin match Tcons1.get_typ tcons with + | EQ -> + if M.tracing then M.tracel "meet_tcons" "meet_tcons matched x %% m == o (expr %s)" (Tcons1.show tcons); + meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Value.of_congruence (o,m)) t' + | DISEQ -> + (*If the saved congruence implies this one, we have a contradiction*) + if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_congruence (o,m)) + then {d=None; env=t'.env} else t' + | _ -> t' + end + | _, _-> t' + end + | Binop (Sub, Cst (Scalar o), Binop (Mod, Var v, Cst (Scalar m), _, _) ,_,_) -> + begin match SharedFunctions.int_of_scalar ?round:None m, SharedFunctions.int_of_scalar ?round:None o with + | Some m, Some o -> begin match Tcons1.get_typ tcons with + | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Value.of_congruence (o,m)) t' + | DISEQ -> + (*If the saved congruence implies this one, we have a contradiction*) + if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_congruence (o,m)) + then {d=None; env=t'.env} else t' + | _ -> t' end + | _, _-> t' end | _ -> if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure (expr %s)" (Tcons1.show tcons); From e31836a2a8e36a7795fba37330f3d39e50a04451 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 18 Feb 2025 15:50:10 +0100 Subject: [PATCH 12/86] Fixed join not considering congruence constraints generated by rhs --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 59 ++++++++++--------- 1 file changed, 32 insertions(+), 27 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 187928d12b..8db6491a21 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -343,35 +343,35 @@ struct if M.tracing then M.tracel "get_interval" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); res + let constrain_with_congruence_from_rhs econ lhs i =(**TODO do not recalculate this every time?*) + (*calculate the congruence constraint for x from a single equation (cx + o) / d *) + let congruence_of_rhs (c, o, d) = + (*adapted euclids extended algorithm for calculating the modular multiplicative inverse*) + let rec inverse t r t_old r_old = + if Z.equal r Z.zero + then t_old + else + let q = Z.div r_old r in + inverse (Z.sub t_old (Z.mul q t)) (Z.sub r_old (Z.mul q r)) t r + in let inverse a n = inverse Z.one a Z.zero n + (* x = -o c^-1 (mod d) *) + in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) + in + let meet_with_rhs _ rhs i = match rhs with + | (Some (c, v), o, d) when v = lhs -> begin + let cong = (congruence_of_rhs (c, o, d)) in + let res = Value.meet i cong in + if M.tracing then M.tracel "refine_pentagon" "refining %s with rhs %s (constraint: %s) -> %s" (Value.show i) (Rhs.show rhs) (Value.show cong) (Value.show res); + res + end + | _ -> i + in + IntMap.fold meet_with_rhs (snd econ) i + let set_interval ((econ, is):t) lhs i = - let refine econ lhs i =(**TODO do not recalculate this every time?*) - (*calculate the congruence constraint for x from a single equation (cx + o) / d *) - let congruence_of_rhs (c, o, d) = - (*adapted euclids extended algorithm for calculating the modular multiplicative inverse*) - let rec inverse t r t_old r_old = - if Z.equal r Z.zero - then t_old - else - let q = Z.div r_old r in - inverse (Z.sub t_old (Z.mul q t)) (Z.sub r_old (Z.mul q r)) t r - in let inverse a n = inverse Z.one a Z.zero n - (* x = -o c^-1 (mod d) *) - in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) - in - let meet_with_rhs _ rhs i = match rhs with - | (Some (c, v), o, d) when v = lhs -> begin - let cong = (congruence_of_rhs (c, o, d)) in - let res = Value.meet i cong in - if M.tracing then M.tracel "refine_pentagon" "refining %s with rhs %s (constraint: %s) -> %s" (Value.show i) (Rhs.show rhs) (Value.show cong) (Value.show res); - res - end - | _ -> i - in - IntMap.fold meet_with_rhs (snd econ) i - in let set_interval_for_root lhs i = if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); - let i = refine econ lhs i in + let i = constrain_with_congruence_from_rhs econ lhs i in if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root refined to %s" (Value.show i); if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) else if Value.is_bot i then raise EConj.Contradiction @@ -486,6 +486,11 @@ struct let res = set_interval t var new_interval in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_interval t var) (Value.show interval) (Value.show new_interval) (show t) (show res); res + + let join_with_one_value var value (t:t) = + let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in + let value' = Value.join value (Value.I.bot (), cong) in + set_interval t var value' end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -783,7 +788,7 @@ struct if vars < 0 then t else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) t (*we only need intervals for roots of the connected components*) else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in - collect_intervals x y econj_joined (vars-1) (EConjI.set_interval t vars joined_interval ) + collect_intervals x y econj_joined (vars-1) (EConjI.join_with_one_value vars joined_interval t) in let join_d x y env = let econj' = join_econj (fst x) (fst y) env in From f21556533f5a98d9522683e42015c18c727a5c7d Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 19 Feb 2025 20:26:03 +0100 Subject: [PATCH 13/86] Fixed modular inverse for negative numbers, small adaptations --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 41 +++++++++++++++---- 1 file changed, 32 insertions(+), 9 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 8db6491a21..276ea9c3ce 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -130,11 +130,11 @@ struct let of_int64 i = Int (Int_t.of_int64 i) let to_int64 t = Int_t.to_int64 @@ get_int_t t - let of_string s = if s = "+⊤" then Top Pos else (if s = "-⊤" then Top Pos else Int (Int_t.of_string s)) + let of_string s = if s = "+∞" then Top Pos else (if s = "-∞" then Top Pos else Int (Int_t.of_string s)) let to_string = function | Int i -> Int_t.to_string i - | Top Pos -> "+⊤" - | Top Neg -> "-⊤" + | Top Pos -> "+∞" + | Top Neg -> "-∞" let of_bigint i = Int (Int_t.of_bigint i) let to_bigint t = Int_t.to_bigint @@ get_int_t t @@ -353,7 +353,10 @@ struct else let q = Z.div r_old r in inverse (Z.sub t_old (Z.mul q t)) (Z.sub r_old (Z.mul q r)) t r - in let inverse a n = inverse Z.one a Z.zero n + in let inverse a n = + let a = Z.rem a n in + let a = if Z.lt a Z.zero then Z.add a n else a + in inverse Z.one a Z.zero n (* x = -o c^-1 (mod d) *) in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) in @@ -430,7 +433,7 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - let interval= get_interval (ts, is) x in + let interval = get_interval (ts, is) x in if vary = None then begin if d <> Z.one then (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); @@ -439,8 +442,9 @@ struct (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show interval); raise EConj.Contradiction) end; - let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) - set_interval ( (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' ) x interval (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + let t' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + set_interval t' x interval in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -479,6 +483,24 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res + let affine_transform econ i (coeff, j, offs, divi) = + if EConj.nontrivial (fst econ) i then (* i cannot occur on any other rhs apart from itself *) + set_rhs econ i (Rhs.subst (get_rhs econ i) i (Some (coeff,j), offs, divi)) + else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) + (* so now, we transform with the inverse of the transformer: *) + let inv = snd (EConj.inverse i (coeff,j,offs,divi)) in + IntMap.fold (fun k v acc -> + match v with + | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) + | _ -> acc + ) (snd @@ fst econ) econ + + let affine_transform econ i rhs = + let res = affine_transform econ i rhs in + if M.tracing then M.tracel "modify_pentagon" "affine_transform %s -> %s " (show econ) (show res); + res + + let meet_with_one_interval var interval t meet_function = let refined_interval = Value.refine interval in let new_interval = meet_function refined_interval (get_interval t var) @@ -488,7 +510,7 @@ struct res let join_with_one_value var value (t:t) = - let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in + let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in (*TODO probably should be a flag in set_interval to do a join instead of meet so we do not do this twice*) let value' = Value.join value (Value.I.bot (), cong) in set_interval t var value' end @@ -795,6 +817,7 @@ struct match econj' with None -> None | Some econj'' -> + if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj'') ; Some (collect_intervals x y econj'' ((Environment.size env)-1) (econj'', EConjI.IntMap.empty)) in (*Normalize the two domains a and b such that both talk about the same variables*) @@ -874,7 +897,7 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } + {d=Some (EConjI.affine_transform d var_i (coeff_var, var_i, off, divi)); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) From 5542e79ff67f597d16576c20f76ec17b625e9411 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 19 Feb 2025 20:27:41 +0100 Subject: [PATCH 14/86] Indentation --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 276ea9c3ce..a70a371e7e 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -354,10 +354,10 @@ struct let q = Z.div r_old r in inverse (Z.sub t_old (Z.mul q t)) (Z.sub r_old (Z.mul q r)) t r in let inverse a n = - let a = Z.rem a n in - let a = if Z.lt a Z.zero then Z.add a n else a - in inverse Z.one a Z.zero n - (* x = -o c^-1 (mod d) *) + let a = Z.rem a n in + let a = if Z.lt a Z.zero then Z.add a n else a + in inverse Z.one a Z.zero n + (* x = -o c^-1 (mod d) *) in Value.of_congruence @@ (Z.mul (Z.neg o) (inverse c d), d) in let meet_with_rhs _ rhs i = match rhs with From 6da779781189b60c242fb7c341752e2b95faf260 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 20 Feb 2025 00:32:34 +0100 Subject: [PATCH 15/86] Revert changes to affine_transform --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 24 ++++--------------- 1 file changed, 4 insertions(+), 20 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a70a371e7e..05b41cc12d 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -372,6 +372,7 @@ struct IntMap.fold meet_with_rhs (snd econ) i let set_interval ((econ, is):t) lhs i = + if M.tracing then M.tracel "modify_pentagon" "set_interval var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); let set_interval_for_root lhs i = if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); let i = constrain_with_congruence_from_rhs econ lhs i in @@ -414,7 +415,8 @@ struct let new_constraint = get_interval (econ', is) lhs in let old_constraint = get_interval (econ, is) lhs in let new_interval = Value.meet new_constraint old_constraint in - set_interval (econ', is) lhs new_interval + if Value.is_bot new_interval then raise EConj.Contradiction + else set_interval (econ', is) lhs new_interval let set_rhs t lhs rhs = let res = set_rhs t lhs rhs in @@ -483,24 +485,6 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res - let affine_transform econ i (coeff, j, offs, divi) = - if EConj.nontrivial (fst econ) i then (* i cannot occur on any other rhs apart from itself *) - set_rhs econ i (Rhs.subst (get_rhs econ i) i (Some (coeff,j), offs, divi)) - else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) - (* so now, we transform with the inverse of the transformer: *) - let inv = snd (EConj.inverse i (coeff,j,offs,divi)) in - IntMap.fold (fun k v acc -> - match v with - | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) - | _ -> acc - ) (snd @@ fst econ) econ - - let affine_transform econ i rhs = - let res = affine_transform econ i rhs in - if M.tracing then M.tracel "modify_pentagon" "affine_transform %s -> %s " (show econ) (show res); - res - - let meet_with_one_interval var interval t meet_function = let refined_interval = Value.refine interval in let new_interval = meet_function refined_interval (get_interval t var) @@ -897,7 +881,7 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConjI.affine_transform d var_i (coeff_var, var_i, off, divi)); env=t.env } + {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) From a84c202a4d003d6fe706bd90d83194e79bf92fba Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 22 Feb 2025 05:05:59 +0100 Subject: [PATCH 16/86] More flexible invariant handling, refining all occuring vars --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 244 +++++++++++++----- 1 file changed, 177 insertions(+), 67 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 05b41cc12d..e695c6b4a9 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -257,6 +257,17 @@ module IntervalAndCongruence = struct let of_congruence c = refine (I.top_of ik, C.of_congruence ik c) + let must_be_pos (i,_) = I.leq i (I.starting ik (Int Z.one)) + + let must_be_neg (i,_) = I.leq i (I.ending ik (Int (Z.neg Z.one))) + + let starting x = refine (I.starting ik (Int x), C.top_of ik) + + let ending x = refine (I.ending ik (Int x), C.top_of ik) + + let maximal (i,_) = I.maximal i + let minimal (i,_) = I.minimal i + end module Value = IntervalAndCongruence @@ -620,11 +631,11 @@ struct if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Value.show res); res - let assign_const t var const divi = match t.d with | None -> t | Some t_d -> {d = Some (EConjI.set_rhs t_d var (None, const, divi)); env = t.env} + end @@ -632,6 +643,7 @@ module ExpressionBounds: (SharedFunctions.ConvBounds with type t = VarManagement struct include VarManagement + (*TODO improve with eval_texpr!! used to exclude overflows*) let bound_texpr t texpr = if t.d = None then None, None else @@ -710,6 +722,136 @@ struct | None -> (None, None) | Some (l, u) -> (from_top l, from_top u) + let refine_with_tcons t tcons = + match t.d with + | None -> t + | Some d -> + let initial_value = match Tcons1.get_typ tcons with + | EQ | DISEQ -> Value.of_bigint Z.zero + | SUP -> Some (Int Z.one, Top Pos), Value.C.top () + | SUPEQ -> Some (Int Z.zero, Top Pos), Value.C.top () + | EQMOD (n) -> + begin match SharedFunctions.int_of_scalar ?round:None n with + None -> Value.top + | Some n -> Value.of_congruence (Z.zero, n) + end + in + let is_inequality = Tcons1.get_typ tcons = DISEQ in + let refine_var d var value = + let dim = Environment.dim_of_var t.env var in + if is_inequality then begin + match Value.to_int value, Value.to_int (EConjI.get_interval d dim) with + | Some v, Some i when TopIntOps.equal v i -> + if M.tracing then M.trace "refine_tcons" "inequality %s <> %s must be wrong" (Var.to_string var) (Value.show value); + raise EConj.Contradiction + | _ -> d (*TODO if value is a constant, we sometimes could do some refinement*) + end else ( + if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; + EConjI.meet_with_one_interval dim value d Value.meet ) + in + let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in + let open Texpr1 in + let rec refine_expr d value expr = + if M.tracing then M.trace "refine_tcons" "refining expr %s with %s" (GobFormat.asprint print_expr expr) (Value.show value) ; + match expr with + | Binop (op,a,b,_,_) -> + let refine_both op_a op_b = + let b_val = eval d b in + let d' = refine_expr d (op_a value b_val) a in + let a_val = eval d' a in + refine_expr d' (op_b value a_val) b + in begin + match op with + | Add -> refine_both (Value.sub) (Value.sub) + | Sub -> refine_both (Value.add) (Fun.flip Value.sub) + (*Because the overflow handeling in SharedFunctions guarantees us no wrapping behaviour, this is always invertible *) + | Mul -> refine_both (Value.div) (Value.div) + (*DIV and MOD are largely inspired by BaseInvariant*) + | Div -> + (* Integer division means we need to add the remainder, so instead of just `a = c*b` we have `a = c*b + a%b`. + * However, a%b will give [-b+1, b-1] for a=top, but we only want the positive/negative side depending on the sign of c*b. + * If c*b = 0 or it can be positive or negative, we need the full range for the remainder. *) + let b_val = eval d b in + if Value.to_int b_val = Some (Int Z.zero) then begin + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + d + end else + let a_val = eval d a in + let b_c = Value.mul b_val value in + let rem = + let is_pos = Value.must_be_pos b_c in + let is_neg = Value.must_be_neg b_c in + let full = Value.rem a_val b_val in + if is_pos then Value.meet (Value.starting Z.zero) full + else if is_neg then Value.meet (Value.ending Z.zero) full + else full + in let d' = refine_expr d (Value.add b_c rem) a in + refine_expr d' (Value.div (Value.sub a_val rem) value) b + | Mod -> + (* a' = a/b*b + c and derived from it b' = (a-c)/(a/b) + * The idea is to formulate a' as quotient * divisor + remainder. *) + let a_val = eval d a in + let b_val = eval d b in + if Value.to_int b_val = Some (Int Z.zero) then begin + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + d + end else + let a' = Value.add (Value.mul (Value.div a_val b_val) b_val) value in + let b' = Value.div (Value.sub a_val value) (Value.div a_val value) in + (* However, for [2,4]%2 == 1 this only gives [3,4]. + * If the upper bound of a is divisible by b, we can also meet with the result of a/b*b - c to get the precise [3,3]. + * If b is negative we have to look at the lower bound. *) + let is_divisible bound = + match bound a_val with + | Some (TopIntOps.Int ba) -> Value.rem (Value.of_bigint ba) b_val |> Value.to_int = Some (Int Z.zero) + | _ -> false + in + let max_pos = match Value.maximal b_val with None -> true | Some x -> TopIntOps.compare x TopIntOps.zero >= 0 in + let min_neg = match Value.minimal b_val with None -> true | Some x -> TopIntOps.compare x TopIntOps.zero < 0 in + let implies a b = not a || b in + let a'' = + if implies max_pos (is_divisible Value.maximal) && implies min_neg (is_divisible Value.minimal) then + Value.meet a' (Value.sub (Value.mul (Value.div a_val b_val) b_val) value) + else a' + in + let a''' = + (* if both b and c are definite, we can get a precise value in the congruence domain *) + match Value.to_int b_val, Value.to_int value with + | Some (TopIntOps.Int b), Some (TopIntOps.Int c) -> + (* a%b == c -> a: c+bℤ *) + let t = Value.of_congruence (c, b) in + (*If the calculated congruence implies this one, we have a contradiction*) + (*TODO we could check for definite values and contradictions at every step, not just in MOD / Variable assignment*) + if is_inequality && Value.leq a_val (Value.of_congruence (c,b)) then raise EConj.Contradiction; + Value.meet a'' t + | _, _ -> a'' + in + let d' = refine_expr d (b') b in + refine_expr d' (a''') a + | Pow -> failwith "refine_with tcons: pow unsupported" + end + | Unop (op, e,_,_) -> begin match op with + | Neg -> refine_expr d (Value.neg value) e + | Cast -> refine_expr d value e + | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) + end + | Cst (Scalar x) -> + begin match SharedFunctions.int_of_scalar ?round:None x with + | Some x -> (if Value.contains value x || is_inequality then d else raise EConj.Contradiction) + | None -> d + end + | Cst (Interval _) -> failwith "constant was an interval; this is not supported" + | Var v -> refine_var d v value + in try + let d' = refine_expr d initial_value (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) in + {d=Some d';env=t.env} + with EConj.Contradiction -> bot_env + + let refine_with_tcons t tcons = + let res = refine_with_tcons t tcons in + if M.tracing then M.tracel "refine_tcons" "before: %s \n refined with %s\n result: %s " (show t) (Tcons1.show tcons) (show res) ; + res + let meet_with_one_conj t i (var, o, divi) = match t.d with | None -> t @@ -888,7 +1030,7 @@ struct in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env - | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} + | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} (*TODO query instead?! *) end | None -> bot_env @@ -1023,72 +1165,8 @@ struct end | _ -> t (* For equalities of more then 2 vars we just return t *)) in if t'.d = None then (if M.tracing then M.tracel "meet_tcons" "meet_conj resulted in None (expr: %s)" (Tcons1.show tcons); t') else begin - (*meet interval*) (*TODO this could be extended much further, maybe reuse some code from base -> meet with CIL expression instead?*) - (* currently only supports simple assertions x > c (x - c > 0)*) if M.tracing then M.tracel "meet_tcons" "after conj: %s (expr: %s)" (show t') (Tcons1.show tcons); - match expr with - | Binop (Sub,Var v,Cst (Scalar c),_,_) -> - begin match SharedFunctions.int_of_scalar ?round:None c with - | None -> t' - | Some c -> begin match Tcons1.get_typ tcons with - | SUP -> - meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int (Z.add Z.one c), Top Pos), Value.C.top ()) t' - | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Top Pos), Value.C.top ()) t' - | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) - | DISEQ -> - if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_bigint c) - then {d=None; env=t'.env} else t' (*TODO: if at interval bounds, we could refine the interval *) - | _ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op"; - t' - end - end - | Binop (Sub,Cst (Scalar c), Var v,_,_) -> - begin match SharedFunctions.int_of_scalar ?round:None c with - | None -> t' - | Some c -> begin match Tcons1.get_typ tcons with - | SUP -> - meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int (Z.sub c Z.one)), Value.C.top ()) t' - | SUPEQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Top Neg, Int c), Value.C.top ()) t' - | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Some (Int c, Int c), Value.C.top ()) t' (*Should already be matched by the conjuction above?*) - | DISEQ -> - if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_bigint c) - then {d=None; env=t'.env} else t' (*TODO: if at interval bounds, we could refine the interval *) - | _ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching comparison op (expr %s)" (Tcons1.show tcons); - t' - end - end - (*x % m == o *) - | Binop (Sub, Binop (Mod, Var v, Cst (Scalar m), _, _) , Cst (Scalar o),_,_) -> - begin match SharedFunctions.int_of_scalar ?round:None m, SharedFunctions.int_of_scalar ?round:None o with - | Some m, Some o -> begin match Tcons1.get_typ tcons with - | EQ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons matched x %% m == o (expr %s)" (Tcons1.show tcons); - meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Value.of_congruence (o,m)) t' - | DISEQ -> - (*If the saved congruence implies this one, we have a contradiction*) - if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_congruence (o,m)) - then {d=None; env=t'.env} else t' - | _ -> t' - end - | _, _-> t' - end - | Binop (Sub, Cst (Scalar o), Binop (Mod, Var v, Cst (Scalar m), _, _) ,_,_) -> - begin match SharedFunctions.int_of_scalar ?round:None m, SharedFunctions.int_of_scalar ?round:None o with - | Some m, Some o -> begin match Tcons1.get_typ tcons with - | EQ -> meet_with_one_interval Value.meet (Environment.dim_of_var t'.env v) (Value.of_congruence (o,m)) t' - | DISEQ -> - (*If the saved congruence implies this one, we have a contradiction*) - if Value.leq (EConjI.get_interval (Option.get t.d) (Environment.dim_of_var t'.env v)) (Value.of_congruence (o,m)) - then {d=None; env=t'.env} else t' - | _ -> t' - end - | _, _-> t' - end - | _ -> - if M.tracing then M.tracel "meet_tcons" "meet_tcons interval not matching structure (expr %s)" (Tcons1.show tcons); - t' + refine_with_tcons t' tcons end @@ -1175,4 +1253,36 @@ struct end include SharedFunctions.AssertionModule (D.V) (D) (ConvArg) include D + + (*We can be more precise than the function from the AssertionModule by including congruence information*) + let eval_int ask d e no_ov = + let module ID = Queries.ID in + match Cilfacade.get_ikind_exp e with + | exception Cilfacade.TypeOfError _ + | exception Invalid_argument _ -> + ID.top () (* real top, not a top of any ikind because we don't even know the ikind *) + | ik -> + if M.tracing then M.trace "relation" "eval_int: exp_is_constraint %a = %B" d_plainexp e (exp_is_constraint e); + if exp_is_constraint e then + match check_assert ask d e no_ov with + | `True -> ID.of_bool ik true + | `False -> ID.of_bool ik false + | `Top -> ID.top_of ik + else + (*TODO we could also provide information for non-linear expressions*) + match Convert.texpr1_of_cil_exp ask d (env d) e no_ov with + | texpr1 -> + let (i, c) = eval_texpr d (Texpr1.to_expr texpr1) in + let c = match c with + | None -> ID.bot_of ik + | Some c -> ID.of_congruence ik c + in let i = match i with + | None -> ID.bot_of ik + | Some (TopIntOps.Int l, TopIntOps.Int u) -> ID.of_interval ik (l,u) + | Some (TopIntOps.Int l, _) -> ID.starting ik l + | Some (_, TopIntOps.Int u) -> ID.ending ik u + | _ -> ID.top_of ik + in ID.meet c i + | exception Convert.Unsupported_CilExp _ -> ID.top_of ik + end \ No newline at end of file From 7b7e55f10ad8af9a975bd37b5098fbe619da749d Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 25 Feb 2025 16:13:34 +0100 Subject: [PATCH 17/86] Better bounds checking for overflow, regression tests --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 15 ++++++++------- .../82-lin2vareq_p/37-intervals_propagation.c | 12 ++++++++++++ .../82-lin2vareq_p/38-simple_congruence.c | 16 ++++++++++++++++ .../82-lin2vareq_p/39-congruence_from_equation.c | 16 ++++++++++++++++ 4 files changed, 52 insertions(+), 7 deletions(-) create mode 100644 tests/regression/82-lin2vareq_p/37-intervals_propagation.c create mode 100644 tests/regression/82-lin2vareq_p/38-simple_congruence.c create mode 100644 tests/regression/82-lin2vareq_p/39-congruence_from_equation.c diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index e695c6b4a9..831e42462f 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -645,13 +645,14 @@ struct (*TODO improve with eval_texpr!! used to exclude overflows*) let bound_texpr t texpr = - if t.d = None then None, None - else - match simplify_to_ref_and_offset t (Texpr1.to_expr texpr) with - | Some (None, offset, divisor) when Z.equal (Z.rem offset divisor) Z.zero -> let res = Z.div offset divisor in - (if M.tracing then M.tracel "bounds" "min: %a max: %a" GobZ.pretty res GobZ.pretty res; - Some res, Some res) - | _ -> None, None + let v = eval_texpr t (Texpr1.to_expr texpr) in + let from_top = function + | TopIntOps.Int x -> Some x + | _ -> None + in let min = BatOption.bind (Value.minimal v) (from_top) + in let max = BatOption.bind (Value.maximal v) (from_top) in + (if M.tracing then M.tracel "bounds" "min: %s max: %s" (BatOption.map_default Z.to_string "None" min) (BatOption.map_default Z.to_string "None" max); + min, max) let bound_texpr d texpr1 = timing_wrap "bounds calculation" (bound_texpr d) texpr1 end diff --git a/tests/regression/82-lin2vareq_p/37-intervals_propagation.c b/tests/regression/82-lin2vareq_p/37-intervals_propagation.c new file mode 100644 index 0000000000..dc9d76983a --- /dev/null +++ b/tests/regression/82-lin2vareq_p/37-intervals_propagation.c @@ -0,0 +1,12 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +int main() { + int x, y, z; + x = 3*y + 1; // a + z = 5*x + 7; // b + if (x>0) { + __goblint_check( x > 0 ); + __goblint_check( y > -1 ); // A + __goblint_check( z > 7 ); // B + } +} \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/38-simple_congruence.c b/tests/regression/82-lin2vareq_p/38-simple_congruence.c new file mode 100644 index 0000000000..b2fbc2112d --- /dev/null +++ b/tests/regression/82-lin2vareq_p/38-simple_congruence.c @@ -0,0 +1,16 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +int main() { + int x, y, z; + x = 3 * y + 1; // a + z = 5 * x + 7; // b + if (y < 14) + { + __goblint_check( x <= 42); + __goblint_check(y < 14); // A + __goblint_check(z != 500); // B + __goblint_check(z != 14); // Because of eqution for z + __goblint_check(z != 17); // Because of combination of equation for z and x + + } +} \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c new file mode 100644 index 0000000000..b2fbc2112d --- /dev/null +++ b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c @@ -0,0 +1,16 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +int main() { + int x, y, z; + x = 3 * y + 1; // a + z = 5 * x + 7; // b + if (y < 14) + { + __goblint_check( x <= 42); + __goblint_check(y < 14); // A + __goblint_check(z != 500); // B + __goblint_check(z != 14); // Because of eqution for z + __goblint_check(z != 17); // Because of combination of equation for z and x + + } +} \ No newline at end of file From d5ec239ee5d03d7431963d78478b516c59769f29 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 26 Feb 2025 04:20:42 +0100 Subject: [PATCH 18/86] Splitting Subdomains into a separate file. Change function names mentioning intervals. Fixed small bug in TopIntOps.div --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 411 +++--------------- .../apron/pentagonSubDomains.apron.ml | 270 ++++++++++++ .../apron/pentagonSubDomains.no-apron.ml | 3 + src/dune | 4 + 4 files changed, 349 insertions(+), 339 deletions(-) create mode 100644 src/cdomains/apron/pentagonSubDomains.apron.ml create mode 100644 src/cdomains/apron/pentagonSubDomains.no-apron.ml diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 831e42462f..05f2041406 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1,291 +1,25 @@ -(**Extending the LinearTwoVarDomain with Intervals for the representative interval *) +(**TODO short description*) open Batteries open GoblintCil open Pretty -module M = Messages open GobApron open VectorMatrix - -module Mpqf = SharedFunctions.Mpqf - -module Rhs = LinearTwoVarEqualityDomain.Rhs - -module EConj = LinearTwoVarEqualityDomain.EqualitiesConjunction - -module TopIntBase (Int_t : IntOps.IntOpsBase) = -struct - type sign = Pos | Neg [@@deriving eq, hash] - type t = Int of Int_t.t - | Top of sign [@@deriving eq, hash] - - let compare a b = match a, b with - | Int a, Int b -> Int_t.compare a b - | Top Neg, Top Neg - | Top Pos, Top Pos -> 0 - | _ , Top Pos - | Top Neg, _ -> -1 - | _ , Top Neg - | Top Pos, _ -> 1 - - let get_int_t = function - | Int i -> i - | _ -> failwith "get_int_t on top value" - - let neg_s = function - | Pos -> Neg - | Neg -> Pos - - - let lift2 op t1 t2 = match t1, t2 with - Int t1, Int t2 -> Int (op t1 t2) - | Top Neg, Top Pos - | Top Pos, Top Neg -> Top Neg - | Top s, _ - | _, Top s -> Top s - - let lift2_1 op t1 t2 = match t1 with - | Int t1 -> Int (op t1 t2) - | t -> t - - let name () = Int_t.name () ^ " with top" - - let zero = Int (Int_t.zero) - let one = Int (Int_t.one) - - let lower_bound = Some (Top Neg) - let upper_bound = Some (Top Pos) - - let neg = function - | Int i -> Int (Int_t.neg i) - | Top Pos -> Top Neg - | Top Neg -> Top Pos - let abs = function - | Int i -> Int (Int_t.abs i) - | Top _ -> Top Pos - - let add a b = match a,b with - | Int a, Int b -> Int (Int_t.add a b) - | Top s, _ - | _, Top s -> Top s - let sub a b = match a,b with - | Int a, Int b -> Int (Int_t.sub a b) - | Top s, _ -> Top s - | Int _, Top Pos -> Top Neg - | Int _, Top Neg -> Top Pos - - - let mul a b = match a,b with - | Int a, Int b -> Int (Int_t.mul a b) - | Top s, Int x - | Int x, Top s -> - let comp = Int_t.compare x Int_t.zero in - if comp = 0 then Int (Int_t.zero) - else if comp < 0 then Top (neg_s s) - else Top s - | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) - let div a b = match a,b with - | Int a, Int b -> Int (Int_t.div a b) - | Top s, Int x - | Int x, Top s -> - let comp = Int_t.compare x Int_t.zero in - if comp = 0 then Int (Int_t.zero) - else if comp < 0 then Top (neg_s s) - else Top s - | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) - - (*TODO will rem/gcd/shift/logical functions lead to problems??*) - let rem = lift2 Int_t.rem - let gcd = lift2 Int_t.gcd - - let shift_left = lift2_1 Int_t.shift_left - let shift_right = lift2_1 Int_t.shift_right - let logand = lift2 Int_t.logand - let logor = lift2 Int_t.logor - let logxor = lift2 Int_t.logxor - let lognot = function - | Int i -> Int (Int_t.lognot i) - | t -> t - - (**TODO not clear what this should do*) - let top_range _ _ = false - let max a b = - match a,b with - | Top Neg, m - | m, Top Neg -> m - | Top Pos, _ - | _, Top Pos -> Top Pos - | Int a, Int b -> Int (Int_t.max a b) - let min a b = - match a,b with - | Top Pos, m - | m, Top Pos -> m - | Top Neg, _ - | _, Top Neg -> Top Neg - | Int a, Int b -> Int (Int_t.min a b) - - let of_int i = Int (Int_t.of_int i) - let to_int t = Int_t.to_int @@ get_int_t t - - let of_int64 i = Int (Int_t.of_int64 i) - let to_int64 t = Int_t.to_int64 @@ get_int_t t - - let of_string s = if s = "+∞" then Top Pos else (if s = "-∞" then Top Pos else Int (Int_t.of_string s)) - let to_string = function - | Int i -> Int_t.to_string i - | Top Pos -> "+∞" - | Top Neg -> "-∞" - - let of_bigint i = Int (Int_t.of_bigint i) - let to_bigint t = Int_t.to_bigint @@ get_int_t t - - (*TODO*) - let arbitrary () = failwith "arbitrary not implemented yet" -end - -(*TODO this is a copy of the IntOpsDecorator, but we keep the constructor of type t -> is there a better way??*) -module TopIntOps = struct - - include Printable.StdLeaf - include TopIntBase(IntOps.BigIntOpsBase) - let show = to_string - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = to_string - end - ) - let pred x = sub x one - let of_bool x = if x then one else zero - let to_bool x = x <> zero - - (* These are logical operations in the C sense! *) - let log_op op a b = of_bool @@ op (to_bool a) (to_bool b) - let c_lognot x = of_bool (x = zero) - let c_logand = log_op (&&) - let c_logor = log_op (||) - let c_logxor = log_op (<>) - - let lt x y = of_bool (compare x y < 0) - let gt x y = of_bool (compare x y > 0) - let le x y = of_bool (compare x y <= 0) - let ge x y = of_bool (compare x y >= 0) - -end - -module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOps.t = struct - include TopIntOps - - type t_interval = (t * t) option [@@deriving eq, ord, hash] - - let range _ = (Top Neg, Top Pos) - let top_of ik = Some (range ik) - let bot_of _ = None - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik t = - let t = match t with - | Some (Top Pos, Top Neg) -> Some (Top Neg, Top Pos) - | Some (l, Top Neg) -> Some (l, Top Pos) - | Some (Top Pos, u) -> Some (Top Neg, u) - | Some (Int a, Int b) when Z.compare a b > 0 -> None - | _ -> t - in (t,IntDomain0.{underflow=false; overflow=false}) -end - -(*TODO can I use the domain tuple? seems rather complicated*) -module IntervalAndCongruence = struct - module I = IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) - module C = CongruenceDomainNormFunctor.Congruence(CongruenceDomainNormFunctor.NoWrapping) - - type t = I.t * C.t [@@deriving eq, ord, hash] - - let show (i,c) = I.show i ^ "," ^ C.show c - - let ik = IChar (*Placeholder for all functions that need one. Should not matter, but choosen small so that errors are detected with smaller numbers already*) - - let top = I.top_of ik, C.top_of ik - - let is_top = equal top - - let is_bot = function - | None, None -> true - | _,_ -> false - - let of_bigint x = (I.of_int ik (TopIntOps.of_bigint x), C.of_int ik x) - - let leq (i1,c1) (i2,c2) = I.leq i1 i2 && C.leq c1 c2 - - let contains t v = leq (of_bigint v) t - - let contains t v = - let res = contains t v in - if M.tracing then M.tracel "contains" "is %s conained in %s -> %b" (Z.to_string v) (show t) (res); - res - - let refine t = - let refine_step (i,c) = - let c' = match i with - | Some (TopIntOps.Int x, TopIntOps.Int y) -> C.refine_with_interval ik c (Some (x,y)) - | Some _ -> c (*No refinement possible if one side is infinite*) - | _ -> None - in - (I.refine_with_congruence ik i (BatOption.map (fun (x,y) -> (TopIntOps.Int x,TopIntOps.Int y)) c) ), c' - in - let t' = refine_step t in - if t' = t then t else refine_step t' (*The second refinement is necessary if the refinement leads to a constant, otherwise not*) - - let add (i1,c1) (i2,c2) = refine (I.add ~no_ov:true ik i1 i2, C.add ~no_ov:true ik c1 c2) - - let sub (i1,c1) (i2,c2) = refine (I.sub ~no_ov:true ik i1 i2, C.sub ~no_ov:true ik c1 c2) - - let mul (i1,c1) (i2,c2) = refine (I.mul ~no_ov:true ik i1 i2, C.mul ~no_ov:true ik c1 c2) - - let div (i1,c1) (i2,c2) = refine (I.div ~no_ov:true ik i1 i2, C.div ~no_ov:true ik c1 c2) - - let rem (i1,c1) (i2,c2) = refine (I.rem ik i1 i2, C.rem ik c1 c2) - - let neg (i,c) = refine (I.neg ~no_ov:true ik i, C.neg ~no_ov:true ik c) - - let to_int (i,_) = I.to_int i - - let meet (i1,c1) (i2,c2) = refine (I.meet ik i1 i2, C.meet ik c1 c2) - - let narrow (i1,c1) (i2,c2) = refine (I.narrow ik i1 i2, C.narrow ik c1 c2) - - let join (i1,c1) (i2,c2) = refine (I.join ik i1 i2, C.join ik c1 c2) - let widen (i1,c1) (i2,c2) = refine (I.widen ik i1 i2, C.widen ik c1 c2) - - let of_congruence c = refine (I.top_of ik, C.of_congruence ik c) - - let must_be_pos (i,_) = I.leq i (I.starting ik (Int Z.one)) - - let must_be_neg (i,_) = I.leq i (I.ending ik (Int (Z.neg Z.one))) - - let starting x = refine (I.starting ik (Int x), C.top_of ik) - - let ending x = refine (I.ending ik (Int x), C.top_of ik) - - let maximal (i,_) = I.maximal i - let minimal (i,_) = I.minimal i - -end - -module Value = IntervalAndCongruence +open PentagonSubDomains module EqualitiesConjunctionWithIntervals = struct - module IntMap = EConj.IntMap type t = EConj.t * (Value.t IntMap.t) [@@deriving eq, ord] let hash (econj, x) = EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Value.hash value) x 0 - let show_intervals formatter is = + let show_values formatter is = if IntMap.is_empty is then "{}" else let str = IntMap.fold (fun k v acc -> Printf.sprintf "%s=%s , %s" (formatter k) (Value.show v) acc) is "" in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" - let show_formatted formatter ((dim, econj), is) = Printf.sprintf "(%s, %s)" (EConj.show_formatted formatter econj) (show_intervals formatter is) + let show_formatted formatter ((dim, econj), is) = Printf.sprintf "(%s, %s)" (EConj.show_formatted formatter econj) (show_values formatter is) let show = show_formatted (Printf.sprintf "var_%d") @@ -296,7 +30,7 @@ struct let is_top_con (e, is) = EConj.is_top_con e && IntMap.is_empty is - let modify_variables_in_domain_intervals map indexes op = + let modify_variables_in_domain_values map indexes op = if Array.length indexes = 0 then map else let rec bumpentry k v = function | (tbl,delta,head::rest) when k>=head -> bumpentry k v (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) @@ -305,20 +39,20 @@ struct let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,Array.to_list indexes) in (* Build new map during fold with bumped keys *) a - let modify_variables_in_domain_intervals map indexes op = - let res = modify_variables_in_domain_intervals map indexes op in if M.tracing then + let modify_variables_in_domain_values map indexes op = + let res = modify_variables_in_domain_values map indexes op in if M.tracing then M.tracel "modify_dims" "dimarray bumping with (fun x -> x + %d) at positions [%s] in { %s } -> { %s }" (op 0 1) (Array.fold_right (fun i str -> (string_of_int i) ^ ", " ^ str) indexes "") - (show_intervals (Printf.sprintf "var_%d") map) - (show_intervals (Printf.sprintf "var_%d") res); + (show_values (Printf.sprintf "var_%d") map) + (show_values (Printf.sprintf "var_%d") res); res let make_empty_with_size size = (EConj.make_empty_conj size, IntMap.empty) let dim_add (ch: Apron.Dim.change) (econj, i) = - (EConj.dim_add ch econj, modify_variables_in_domain_intervals i ch.dim (+)) + (EConj.dim_add ch econj, modify_variables_in_domain_values i ch.dim (+)) let forget_variable (econj, is) var = (EConj.forget_variable econj var, IntMap.remove var is) @@ -331,16 +65,16 @@ struct Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) let (econj', i') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, i) cpy in (* clear m' from relations concerning ch.dim *) let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in - let i'' = modify_variables_in_domain_intervals i' cpy (-) in + let i'' = modify_variables_in_domain_values i' cpy (-) in (econj'', i'')) let get_rhs t = EConj.get_rhs (fst t) - let get_interval (econ, is) lhs = + let get_value (econ, is) lhs = match IntMap.find_opt lhs is with Some i -> i - | None -> (*If there is no interval saved, we have calculate it*) + | None -> (*If there is no value saved, we have calculate it*) let (v,o,d) = get_rhs (econ, is) lhs in if (v,o,d) = Rhs.var_zero lhs then Value.top (*no relation -> Top*) else match v with @@ -349,9 +83,9 @@ struct None -> Value.top (*uninitialised*) | Some i -> Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) - let get_interval t lhs = - let res = get_interval t lhs in - if M.tracing then M.tracel "get_interval" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); + let get_value t lhs = + let res = get_value t lhs in + if M.tracing then M.tracel "get_value" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); res let constrain_with_congruence_from_rhs econ lhs i =(**TODO do not recalculate this every time?*) @@ -382,12 +116,12 @@ struct in IntMap.fold meet_with_rhs (snd econ) i - let set_interval ((econ, is):t) lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_interval var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); - let set_interval_for_root lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); + let set_value ((econ, is):t) lhs i = + if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); + let set_value_for_root lhs i = + if M.tracing then M.tracel "modify_pentagon" "set_value_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); let i = constrain_with_congruence_from_rhs econ lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_interval_for_root refined to %s" (Value.show i); + if M.tracing then M.tracel "modify_pentagon" "set_value_for_root refined to %s" (Value.show i); if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) else if Value.is_bot i then raise EConj.Contradiction else match Value.to_int i with @@ -400,34 +134,34 @@ struct | _ -> (econ, IntMap.add lhs i is) (*Not a constant*) in let (v,o,d) = get_rhs (econ, is) lhs in if (v,o,d) = Rhs.var_zero lhs then - set_interval_for_root lhs i + set_value_for_root lhs i else match v with - | None -> (econ, is) (*For a constant, we do not need to save an interval*) (*TODO should we check for equality?*) + | None -> (econ, is) (*For a constant, we do not need to save an value*) (*TODO should we check for equality?*) | Some (coeff, v) -> let i1 = Value.mul (Value.of_bigint d) i in let i2 = Value.sub i1 (Value.of_bigint o) in let i3 = Value.div i2 (Value.of_bigint coeff) in let i_transformed = i3 in if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Value.show i) (Value.show i1) (Value.show i2) (Value.show i3); - set_interval_for_root v i_transformed + set_value_for_root v i_transformed - let set_interval t lhs i = - let res = set_interval t lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_interval before: %s eq: var_%d=%s -> %s " (show t) lhs (Value.show i) (show res); + let set_value t lhs i = + let res = set_value t lhs i in + if M.tracing then M.tracel "modify_pentagon" "set_value before: %s eq: var_%d=%s -> %s " (show t) lhs (Value.show i) (show res); res - (*TODO: If we are uptdating a variable, we will overwrite the interval again -> maybe skip setting it here, because of performance?*) + (*TODO: If we are uptdating a variable, we will overwrite the value again -> maybe skip setting it here, because of performance?*) let set_rhs (econ, is) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with - | (None, _, _) -> econ', IntMap.remove lhs is (*when setting as a constant, we do not need a separate interval *) + | (None, _, _) -> econ', IntMap.remove lhs is (*when setting as a constant, we do not need a separate value *) | _ -> - let new_constraint = get_interval (econ', is) lhs in - let old_constraint = get_interval (econ, is) lhs in - let new_interval = Value.meet new_constraint old_constraint in - if Value.is_bot new_interval then raise EConj.Contradiction - else set_interval (econ', is) lhs new_interval + let new_constraint = get_value (econ', is) lhs in + let old_constraint = get_value (econ, is) lhs in + let new_value = Value.meet new_constraint old_constraint in + if Value.is_bot new_value then raise EConj.Contradiction + else set_value (econ', is) lhs new_value let set_rhs t lhs rhs = let res = set_rhs t lhs rhs in @@ -446,18 +180,18 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - let interval = get_interval (ts, is) x in + let value = get_value (ts, is) x in if vary = None then begin if d <> Z.one then (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); raise EConj.Contradiction); - if not @@ Value.contains interval (Z.div offs divi) then - (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show interval); + if not @@ Value.contains value (Z.div offs divi) then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show value); raise EConj.Contradiction) end; - let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove interval and add it back afterwards*) + let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove value and add it back afterwards*) let t' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) - set_interval t' x interval + set_value t' x value in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -496,18 +230,18 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) ; res - let meet_with_one_interval var interval t meet_function = - let refined_interval = Value.refine interval in - let new_interval = meet_function refined_interval (get_interval t var) - in if Value.is_bot new_interval then raise EConj.Contradiction else - let res = set_interval t var new_interval - in if M.tracing then M.tracel "meet_interval" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_interval t var) (Value.show interval) (Value.show new_interval) (show t) (show res); + let meet_with_one_value var value t meet_function = + let refined_value = Value.refine value in + let new_value = meet_function refined_value (get_value t var) + in if Value.is_bot new_value then raise EConj.Contradiction else + let res = set_value t var new_value + in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res let join_with_one_value var value (t:t) = - let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in (*TODO probably should be a flag in set_interval to do a join instead of meet so we do not do this twice*) + let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in (*TODO probably should be a flag in set_value to do a join instead of meet so we do not do this twice*) let value' = Value.join value (Value.I.bot (), cong) in - set_interval t var value' + set_value t var value' end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -569,7 +303,7 @@ struct BatOption.bind (monomials_from_texp t texp) (fun monomiallist -> let d = Option.get t.d in - let module IMap = EConjI.IntMap in + let module IMap = IntMap in let accumulate_constants (exprcache,(aconst,adiv)) (v,offs,divi) = match v with | None -> let gcdee = Z.gcd adiv divi in exprcache,(Z.(aconst*divi/gcdee + offs*adiv/gcdee),Z.lcm adiv divi) | Some (coeff,idx) -> let (somevar,someoffs,somedivi)=Rhs.subst (EConjI.get_rhs d idx) idx (v,offs,divi) in (* normalize! *) @@ -621,7 +355,7 @@ struct let var_dim = Environment.dim_of_var t.env x in begin match t.d with | None -> Value.top - | Some d -> EConjI.get_interval d var_dim + | Some d -> EConjI.get_value d var_dim end | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) | Unop (op, a, Int, _) -> (unop_function op) (eval a) @@ -643,7 +377,6 @@ module ExpressionBounds: (SharedFunctions.ConvBounds with type t = VarManagement struct include VarManagement - (*TODO improve with eval_texpr!! used to exclude overflows*) let bound_texpr t texpr = let v = eval_texpr t (Texpr1.to_expr texpr) in let from_top = function @@ -660,7 +393,7 @@ end module D = struct include Printable.Std - include ConvenienceOps (Mpqf) + include ConvenienceOps (SharedFunctions.Mpqf) include VarManagement module Bounds = ExpressionBounds @@ -741,14 +474,14 @@ struct let refine_var d var value = let dim = Environment.dim_of_var t.env var in if is_inequality then begin - match Value.to_int value, Value.to_int (EConjI.get_interval d dim) with + match Value.to_int value, Value.to_int (EConjI.get_value d dim) with | Some v, Some i when TopIntOps.equal v i -> if M.tracing then M.trace "refine_tcons" "inequality %s <> %s must be wrong" (Var.to_string var) (Value.show value); raise EConj.Contradiction | _ -> d (*TODO if value is a constant, we sometimes could do some refinement*) end else ( if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; - EConjI.meet_with_one_interval dim value d Value.meet ) + EConjI.meet_with_one_value dim value d Value.meet ) in let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in let open Texpr1 in @@ -774,7 +507,7 @@ struct * If c*b = 0 or it can be positive or negative, we need the full range for the remainder. *) let b_val = eval d b in if Value.to_int b_val = Some (Int Z.zero) then begin - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; d end else let a_val = eval d a in @@ -794,7 +527,7 @@ struct let a_val = eval d a in let b_val = eval d b in if Value.to_int b_val = Some (Int Z.zero) then begin - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; d end else let a' = Value.add (Value.mul (Value.div a_val b_val) b_val) value in @@ -868,17 +601,17 @@ struct if M.tracing then M.tracel "meet" "%s with single eq %s=%s -> %s" (show t) (Z.(to_string @@ Tuple3.third e)^ show_var t.env i) (Rhs.show_rhs_formatted (show_var t.env) e) (show res); res - let meet_with_one_interval meet_function i interval t = + let meet_with_one_value meet_function i value t = let res = match t.d with | None -> t | Some d -> try - { d = Some (EConjI.meet_with_one_interval i interval d meet_function); env = t.env} + { d = Some (EConjI.meet_with_one_value i value d meet_function); env = t.env} with EConj.Contradiction -> - if M.tracing then M.trace "meet" " -> Contradiction with interval\n"; + if M.tracing then M.trace "meet" " -> Contradiction with value\n"; { d = None; env = t.env} in - if M.tracing then M.tracel "meet" "%s with single interval %s=%s -> %s" (show t) (show_var t.env i) (Value.show interval) (show res); + if M.tracing then M.tracel "meet" "%s with single value %s=%s -> %s" (show t) (show_var t.env i) (Value.show value) (show res); res let meet' t1 t2 meet_function = @@ -887,8 +620,8 @@ struct let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with | Some d1', Some d2' -> - let conj_met = EConjI.IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd @@ fst d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) - in EConjI.IntMap.fold (meet_with_one_interval meet_function) (snd d2') conj_met + let conj_met = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd @@ fst d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + in IntMap.fold (meet_with_one_value meet_function) (snd d2') conj_met | _ -> {d = None; env = sup_env} let meet t1 t2 = @@ -911,15 +644,15 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in - let implies_interval v i interval = Value.leq (EConjI.get_interval v i) interval + let implies_value v i value = Value.leq (EConjI.get_value v i) value in if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true else if is_bot_env t2 || is_top t1 then false else let m1, m2 = Option.get t1.d, Option.get t2.d in let m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in - EConj.IntMap.for_all (implies @@ fst m1') (snd @@ fst m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) - && EConj.IntMap.for_all (implies_interval m1') (snd m2) + IntMap.for_all (implies @@ fst m1') (snd @@ fst m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + && IntMap.for_all (implies_value m1') (snd m2) let leq a b = timing_wrap "leq" (leq a) b @@ -928,16 +661,16 @@ struct if M.tracing then M.tracel "leq" "leq a: %s b: %s -> %b" (show t1) (show t2) res ; res - (*The first parameter is the function used to join two intervals. Different uses for join / widen*) + (*The first parameter is the function used to join two values. Different uses for join / widen*) let join' join_function a b = let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d in - (*Check all variables (up to index vars) if we need to save an interval for them*) - let rec collect_intervals x y econj_joined vars t = + (*Check all variables (up to index vars) if we need to save an value for them*) + let rec collect_values x y econj_joined vars t = if vars < 0 then t - else if EConj.nontrivial econj_joined vars then collect_intervals x y econj_joined (vars-1) t (*we only need intervals for roots of the connected components*) - else let joined_interval = join_function (EConjI.get_interval x vars) (EConjI.get_interval y vars) in - collect_intervals x y econj_joined (vars-1) (EConjI.join_with_one_value vars joined_interval t) + else if EConj.nontrivial econj_joined vars then collect_values x y econj_joined (vars-1) t (*we only need values for roots of the connected components*) + else let joined_value = join_function (EConjI.get_value x vars) (EConjI.get_value y vars) in + collect_values x y econj_joined (vars-1) (EConjI.join_with_one_value vars joined_value t) in let join_d x y env = let econj' = join_econj (fst x) (fst y) env in @@ -945,7 +678,7 @@ struct None -> None | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj'') ; - Some (collect_intervals x y econj'' ((Environment.size env)-1) (econj'', EConjI.IntMap.empty)) + Some (collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty)) in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with @@ -1031,7 +764,7 @@ struct in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env - | Some d' -> {d = Some (EConjI.set_interval d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} (*TODO query instead?! *) + | Some d' -> {d = Some (EConjI.set_value d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} (*TODO query instead?! *) end | None -> bot_env @@ -1232,7 +965,7 @@ struct let ri = Environment.var_of_dim t.env r in of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi); (GobApron.Coeff.s_of_z c, ri)] o :: acc in - BatOption.get t.d |> fun ((_,map),_) -> EConj.IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + BatOption.get t.d |> fun ((_,map),_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml new file mode 100644 index 0000000000..e97a0453a3 --- /dev/null +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -0,0 +1,270 @@ +open Batteries +open GoblintCil +module M = Messages + + +module Rhs = LinearTwoVarEqualityDomain.Rhs + +module EConj = LinearTwoVarEqualityDomain.EqualitiesConjunction + +module IntMap = EConj.IntMap + +(*MOdules for creating an unbounded interval arithmethic with the existing interval domain*) +module TopIntBase (Int_t : IntOps.IntOpsBase) = +struct + type sign = Pos | Neg [@@deriving eq, hash] + type t = Int of Int_t.t + | Top of sign [@@deriving eq, hash] + + let compare a b = match a, b with + | Int a, Int b -> Int_t.compare a b + | Top Neg, Top Neg + | Top Pos, Top Pos -> 0 + | _ , Top Pos + | Top Neg, _ -> -1 + | _ , Top Neg + | Top Pos, _ -> 1 + + let get_int_t = function + | Int i -> i + | _ -> failwith "get_int_t on top value" + + let neg_s = function + | Pos -> Neg + | Neg -> Pos + + + let lift2 op t1 t2 = match t1, t2 with + Int t1, Int t2 -> Int (op t1 t2) + | Top Neg, Top Pos + | Top Pos, Top Neg -> Top Neg + | Top s, _ + | _, Top s -> Top s + + let lift2_1 op t1 t2 = match t1 with + | Int t1 -> Int (op t1 t2) + | t -> t + + let name () = Int_t.name () ^ " with top" + + let zero = Int (Int_t.zero) + let one = Int (Int_t.one) + + let lower_bound = Some (Top Neg) + let upper_bound = Some (Top Pos) + + let neg = function + | Int i -> Int (Int_t.neg i) + | Top Pos -> Top Neg + | Top Neg -> Top Pos + let abs = function + | Int i -> Int (Int_t.abs i) + | Top _ -> Top Pos + + let add a b = match a,b with + | Int a, Int b -> Int (Int_t.add a b) + | Top s, _ + | _, Top s -> Top s + let sub a b = match a,b with + | Int a, Int b -> Int (Int_t.sub a b) + | Top s, _ -> Top s + | Int _, Top Pos -> Top Neg + | Int _, Top Neg -> Top Pos + + + let mul a b = match a,b with + | Int a, Int b -> Int (Int_t.mul a b) + | Top s, Int x + | Int x, Top s -> + let comp = Int_t.compare x Int_t.zero in + if comp = 0 then Int (Int_t.zero) + else if comp < 0 then Top (neg_s s) + else Top s + | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) + let div a b = match a,b with + | Int a, Int b -> Int (Int_t.div a b) + | Top s, Int x -> + let comp = Int_t.compare x Int_t.zero in + if comp = 0 then Int (Int_t.zero) + else if comp < 0 then Top (neg_s s) + else Top s + | Int x, Top s -> Int (Int_t.zero) + | Top _, Top _ -> Top Pos (*TODO: Does not make sense. Does it need to?*) + + (*TODO will rem/gcd/shift/logical functions lead to problems??*) + let rem = lift2 Int_t.rem + let gcd = lift2 Int_t.gcd + + let shift_left = lift2_1 Int_t.shift_left + let shift_right = lift2_1 Int_t.shift_right + let logand = lift2 Int_t.logand + let logor = lift2 Int_t.logor + let logxor = lift2 Int_t.logxor + let lognot = function + | Int i -> Int (Int_t.lognot i) + | t -> t + + (**TODO not clear what this should do*) + let top_range _ _ = false + let max a b = + match a,b with + | Top Neg, m + | m, Top Neg -> m + | Top Pos, _ + | _, Top Pos -> Top Pos + | Int a, Int b -> Int (Int_t.max a b) + let min a b = + match a,b with + | Top Pos, m + | m, Top Pos -> m + | Top Neg, _ + | _, Top Neg -> Top Neg + | Int a, Int b -> Int (Int_t.min a b) + + let of_int i = Int (Int_t.of_int i) + let to_int t = Int_t.to_int @@ get_int_t t + + let of_int64 i = Int (Int_t.of_int64 i) + let to_int64 t = Int_t.to_int64 @@ get_int_t t + + let of_string s = if s = "+∞" then Top Pos else (if s = "-∞" then Top Pos else Int (Int_t.of_string s)) + let to_string = function + | Int i -> Int_t.to_string i + | Top Pos -> "+∞" + | Top Neg -> "-∞" + + let of_bigint i = Int (Int_t.of_bigint i) + let to_bigint t = Int_t.to_bigint @@ get_int_t t + + (*TODO*) + let arbitrary () = failwith "arbitrary not implemented yet" +end + +(*TODO this is a copy of the IntOpsDecorator, but we keep the constructor of type t -> is there a better way??*) +module TopIntOps = struct + + include Printable.StdLeaf + include TopIntBase(IntOps.BigIntOpsBase) + let show = to_string + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = to_string + end + ) + let pred x = sub x one + let of_bool x = if x then one else zero + let to_bool x = x <> zero + + (* These are logical operations in the C sense! *) + let log_op op a b = of_bool @@ op (to_bool a) (to_bool b) + let c_lognot x = of_bool (x = zero) + let c_logand = log_op (&&) + let c_logor = log_op (||) + let c_logxor = log_op (<>) + + let lt x y = of_bool (compare x y < 0) + let gt x y = of_bool (compare x y > 0) + let le x y = of_bool (compare x y <= 0) + let ge x y = of_bool (compare x y >= 0) + +end + +module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOps.t = struct + include TopIntOps + + type t_interval = (t * t) option [@@deriving eq, ord, hash] + + let range _ = (Top Neg, Top Pos) + let top_of ik = Some (range ik) + let bot_of _ = None + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik t = + let t = match t with + | Some (Top Pos, Top Neg) -> Some (Top Neg, Top Pos) + | Some (l, Top Neg) -> Some (l, Top Pos) + | Some (Top Pos, u) -> Some (Top Neg, u) + | Some (Int a, Int b) when Z.compare a b > 0 -> None + | _ -> t + in (t,IntDomain0.{underflow=false; overflow=false}) +end + +(*Combining operations into one reduced product for values*) +module IntervalAndCongruence = struct + module I = IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) + module C = CongruenceDomainNormFunctor.Congruence(CongruenceDomainNormFunctor.NoWrapping) + + type t = I.t * C.t [@@deriving eq, ord, hash] + + let show (i,c) = I.show i ^ "," ^ C.show c + + let ik = IChar (*Placeholder for all functions that need one. Should not matter, but choosen small so that errors are detected with smaller numbers already*) + + let top = I.top_of ik, C.top_of ik + + let is_top = equal top + + let is_bot = function + | None, None -> true + | _,_ -> false + + let of_bigint x = (I.of_int ik (TopIntOps.of_bigint x), C.of_int ik x) + + let leq (i1,c1) (i2,c2) = I.leq i1 i2 && C.leq c1 c2 + + let contains t v = leq (of_bigint v) t + + let contains t v = + let res = contains t v in + if M.tracing then M.tracel "contains" "is %s conained in %s -> %b" (Z.to_string v) (show t) (res); + res + + let refine t = + let refine_step (i,c) = + let c' = match i with + | Some (TopIntOps.Int x, TopIntOps.Int y) -> C.refine_with_interval ik c (Some (x,y)) + | Some _ -> c (*No refinement possible if one side is infinite*) + | _ -> None + in + (I.refine_with_congruence ik i (BatOption.map (fun (x,y) -> (TopIntOps.Int x,TopIntOps.Int y)) c) ), c' + in + let t' = refine_step t in + if t' = t then t else refine_step t' (*The second refinement is necessary if the refinement leads to a constant, otherwise not*) + + let add (i1,c1) (i2,c2) = refine (I.add ~no_ov:true ik i1 i2, C.add ~no_ov:true ik c1 c2) + + let sub (i1,c1) (i2,c2) = refine (I.sub ~no_ov:true ik i1 i2, C.sub ~no_ov:true ik c1 c2) + + let mul (i1,c1) (i2,c2) = refine (I.mul ~no_ov:true ik i1 i2, C.mul ~no_ov:true ik c1 c2) + + let div (i1,c1) (i2,c2) = refine (I.div ~no_ov:true ik i1 i2, C.div ~no_ov:true ik c1 c2) + + let rem (i1,c1) (i2,c2) = refine (I.rem ik i1 i2, C.rem ik c1 c2) + + let neg (i,c) = refine (I.neg ~no_ov:true ik i, C.neg ~no_ov:true ik c) + + let to_int (i,_) = I.to_int i + + let meet (i1,c1) (i2,c2) = refine (I.meet ik i1 i2, C.meet ik c1 c2) + + let narrow (i1,c1) (i2,c2) = refine (I.narrow ik i1 i2, C.narrow ik c1 c2) + + let join (i1,c1) (i2,c2) = refine (I.join ik i1 i2, C.join ik c1 c2) + let widen (i1,c1) (i2,c2) = refine (I.widen ik i1 i2, C.widen ik c1 c2) + + let of_congruence c = refine (I.top_of ik, C.of_congruence ik c) + + let must_be_pos (i,_) = I.leq i (I.starting ik (Int Z.one)) + + let must_be_neg (i,_) = I.leq i (I.ending ik (Int (Z.neg Z.one))) + + let starting x = refine (I.starting ik (Int x), C.top_of ik) + + let ending x = refine (I.ending ik (Int x), C.top_of ik) + + let maximal (i,_) = I.maximal i + let minimal (i,_) = I.minimal i + +end + +module Value = IntervalAndCongruence diff --git a/src/cdomains/apron/pentagonSubDomains.no-apron.ml b/src/cdomains/apron/pentagonSubDomains.no-apron.ml new file mode 100644 index 0000000000..76eb4a698a --- /dev/null +++ b/src/cdomains/apron/pentagonSubDomains.no-apron.ml @@ -0,0 +1,3 @@ +(* This domain is empty on purpose. It serves only as an alternative dependency + in cases where the actual domain can't be used because of a missing library. + It was added because we don't want to fully depend on Apron. *) diff --git a/src/dune b/src/dune index d11d7ad3da..548a9dddd6 100644 --- a/src/dune +++ b/src/dune @@ -47,6 +47,10 @@ (apron -> linearTwoVarEqualityAnalysisPentagon.apron.ml) (-> linearTwoVarEqualityAnalysisPentagon.no-apron.ml) ) + (select pentagonSubDomains.ml from + (apron -> pentagonSubDomains.apron.ml) + (-> pentagonSubDomains.no-apron.ml) + ) (select linearTwoVarEqualityDomainPentagon.ml from (apron -> linearTwoVarEqualityDomainPentagon.apron.ml) (-> linearTwoVarEqualityDomainPentagon.no-apron.ml) From ce074dee26489669d95106fdd283eca555f96c79 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 28 Feb 2025 04:14:39 +0100 Subject: [PATCH 19/86] Added Interface for Inequalities and integrated it into the lin2var_p domain --- ...earTwoVarEqualityAnalysisPentagon.apron.ml | 2 +- ...inearTwoVarEqualityDomainPentagon.apron.ml | 354 +++++++++++++----- .../apron/pentagonSubDomains.apron.ml | 57 +++ 3 files changed, 323 insertions(+), 90 deletions(-) diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml index 6b6087de02..36ef7a6057 100644 --- a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -7,7 +7,7 @@ include RelationAnalysis let spec_module: (module MCPSpec) Lazy.t = lazy ( - let module AD = LinearTwoVarEqualityDomainPentagon.D2 + let module AD = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.NoInequalties) in let module Priv = (val RelationPriv.get_priv ()) in let module Spec = diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 05f2041406..2369792611 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -7,11 +7,11 @@ open GobApron open VectorMatrix open PentagonSubDomains -module EqualitiesConjunctionWithIntervals = +module EqualitiesConjunctionWithIntervals (Ineq : TwoVarInequalities) = struct - type t = EConj.t * (Value.t IntMap.t) [@@deriving eq, ord] + type t = EConj.t * (Value.t IntMap.t ) * Ineq.t [@@deriving eq, ord] - let hash (econj, x) = EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Value.hash value) x 0 + let hash (econj, v, ineq) = 5 * EConj.hash econj + 13* IntMap.fold (fun k value acc -> 13 * 13 * acc + 31 * k + Value.hash value) v 0 + 7 * Ineq.hash ineq let show_values formatter is = if IntMap.is_empty is then "{}" @@ -19,16 +19,17 @@ struct let str = IntMap.fold (fun k v acc -> Printf.sprintf "%s=%s , %s" (formatter k) (Value.show v) acc) is "" in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" - let show_formatted formatter ((dim, econj), is) = Printf.sprintf "(%s, %s)" (EConj.show_formatted formatter econj) (show_values formatter is) + let show_formatted formatter ((dim, econj), is, ineq) = Printf.sprintf "(%s, %s, %s)" (EConj.show_formatted formatter econj) (show_values formatter is) (Ineq.show_formatted formatter ineq) let show = show_formatted (Printf.sprintf "var_%d") let copy = identity - let empty () = (EConj.empty (), IntMap.empty) - let is_empty (e,is) = EConj.is_empty e && IntMap.is_empty is + let empty () = (EConj.empty (), IntMap.empty, Ineq.empty) + let is_empty (e,is, ineq) = EConj.is_empty e && IntMap.is_empty is && Ineq.is_empty ineq + let make_empty_with_size size = (EConj.make_empty_conj size, IntMap.empty, Ineq.empty) - let is_top_con (e, is) = EConj.is_top_con e && IntMap.is_empty is + let is_top_con (e, is, ineq) = EConj.is_top_con e && IntMap.is_empty is && Ineq.is_empty ineq let modify_variables_in_domain_values map indexes op = if Array.length indexes = 0 then map else @@ -48,41 +49,51 @@ struct (show_values (Printf.sprintf "var_%d") res); res + let dim_add (ch: Apron.Dim.change) (econj, i, ineq) = + (EConj.dim_add ch econj, modify_variables_in_domain_values i ch.dim (+), Ineq.modify_variables_in_domain ineq ch.dim (+)) - let make_empty_with_size size = (EConj.make_empty_conj size, IntMap.empty) - let dim_add (ch: Apron.Dim.change) (econj, i) = - (EConj.dim_add ch econj, modify_variables_in_domain_values i ch.dim (+)) + let forget_variable (econj, is, ineq) var = (EConj.forget_variable econj var, IntMap.remove var is, Ineq.forget_variable ineq var) - let forget_variable (econj, is) var = (EConj.forget_variable econj var, IntMap.remove var is) - - - let dim_remove (ch: Apron.Dim.change) (econj, i) ~del = - if Array.length ch.dim = 0 || EConj.is_empty econj then - (econj, i) + let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = + if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then + (econj, v, ineq) else ( let cpy = Array.copy ch.dim in Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) - let (econj', i') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, i) cpy in (* clear m' from relations concerning ch.dim *) + let (econj', v', ineq') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, v, ineq) cpy in (* clear m' from relations concerning ch.dim *) let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in - let i'' = modify_variables_in_domain_values i' cpy (-) in - (econj'', i'')) + let v'' = modify_variables_in_domain_values v' cpy (-) in + let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in + (econj'', v'', ineq'')) - let get_rhs t = EConj.get_rhs (fst t) + let get_rhs (econ, _, _) = EConj.get_rhs econ - let get_value (econ, is) lhs = - match IntMap.find_opt lhs is with + let get_value ((econ, vs, _) as t) lhs = + match IntMap.find_opt lhs vs with Some i -> i | None -> (*If there is no value saved, we have calculate it*) - let (v,o,d) = get_rhs (econ, is) lhs in + let (v,o,d) = get_rhs t lhs in if (v,o,d) = Rhs.var_zero lhs then Value.top (*no relation -> Top*) else match v with None -> Value.div (Value.of_bigint o) (Value.of_bigint d)(*constant*) (*TODO is divisor always 1?*) - | Some (coeff,v) -> match IntMap.find_opt v is with + | Some (coeff,v) -> match IntMap.find_opt v vs with None -> Value.top (*uninitialised*) | Some i -> Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) + + let is_less_than ((_,vs,ineq) as t) x y = + + let get_information lhs = + let rhs = get_rhs t lhs in + match rhs with + | (Some (_,var), _ ,_) -> (Either.Left rhs, get_value t var) + | (_,o,_) -> (Either.Right lhs, Value.of_bigint o) + in + Ineq.is_less_than (get_information x) (get_information y) ineq + + let get_value t lhs = let res = get_value t lhs in if M.tracing then M.tracel "get_value" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); @@ -116,13 +127,13 @@ struct in IntMap.fold meet_with_rhs (snd econ) i - let set_value ((econ, is):t) lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); + let set_value ((econ, is, ineq) as t:t) lhs i = + if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show t); let set_value_for_root lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_value_for_root var_%d=%s, before: %s" lhs (Value.show i) (show (econ, is)); + if M.tracing then M.tracel "modify_pentagon" "set_value_for_root var_%d=%s, before: %s" lhs (Value.show i) (show t); let i = constrain_with_congruence_from_rhs econ lhs i in if M.tracing then M.tracel "modify_pentagon" "set_value_for_root refined to %s" (Value.show i); - if i = Value.top then (econ, IntMap.remove lhs is) (*stay sparse*) + if i = Value.top then (econ, IntMap.remove lhs is, ineq) (*stay sparse*) else if Value.is_bot i then raise EConj.Contradiction else match Value.to_int i with | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) @@ -130,14 +141,15 @@ struct | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) | t -> t in - ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is) - | _ -> (econ, IntMap.add lhs i is) (*Not a constant*) - in let (v,o,d) = get_rhs (econ, is) lhs in + ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is, ineq) + | _ -> (econ, IntMap.add lhs i is, ineq) (*Not a constant*) + in + let (v,o,d) = get_rhs t lhs in if (v,o,d) = Rhs.var_zero lhs then set_value_for_root lhs i else match v with - | None -> (econ, is) (*For a constant, we do not need to save an value*) (*TODO should we check for equality?*) + | None -> (econ, is, ineq) (*For a constant, we do not need to save an value*) (*TODO should we check for equality?*) | Some (coeff, v) -> let i1 = Value.mul (Value.of_bigint d) i in let i2 = Value.sub i1 (Value.of_bigint o) in @@ -152,26 +164,26 @@ struct res (*TODO: If we are uptdating a variable, we will overwrite the value again -> maybe skip setting it here, because of performance?*) - let set_rhs (econ, is) lhs rhs = + let set_rhs (econ, is, ineq) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with - | (None, _, _) -> econ', IntMap.remove lhs is (*when setting as a constant, we do not need a separate value *) + | (None, _, _) -> econ', IntMap.remove lhs is, ineq (*when setting as a constant, we do not need a separate value *) | _ -> - let new_constraint = get_value (econ', is) lhs in - let old_constraint = get_value (econ, is) lhs in + let new_constraint = get_value (econ', is, ineq) lhs in + let old_constraint = get_value (econ, is, ineq) lhs in let new_value = Value.meet new_constraint old_constraint in if Value.is_bot new_value then raise EConj.Contradiction - else set_value (econ', is) lhs new_value + else set_value (econ', is, ineq) lhs new_value let set_rhs t lhs rhs = let res = set_rhs t lhs rhs in if M.tracing then M.tracel "modify_pentagon" "set_rhs before: %s eq: var_%d=%s -> %s " (show t) lhs (Rhs.show rhs) (show res); res - let meet_with_one_conj ((ts, is):t) i (var, offs, divi) = + let meet_with_one_conj ((ts, is, ineq) as t:t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = - let subst_var ((dim,econj), is) x (vary, o, d) = + let subst_var ((dim,econj), is, ineq) x (vary, o, d) = let (vary, o, d) = Rhs.canonicalize (vary, o, d) in (* [[x substby (cy+o)/d ]] ((c'x+o')/d') *) (* =====> (c'cy + c'o+o'd)/(dd') *) @@ -180,7 +192,7 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - let value = get_value (ts, is) x in + let value = get_value (ts, is, ineq) x in if vary = None then begin if d <> Z.one then (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); @@ -190,19 +202,19 @@ struct raise EConj.Contradiction) end; let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove value and add it back afterwards*) - let t' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is' in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + let t' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is', ineq in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) set_value t' x value in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) - | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise EConj.Contradiction else ts, is + | None , (None , o1, divi1) -> if not @@ (Z.equal offs o1 && Z.equal divi divi1) then raise EConj.Contradiction else t (* o/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_h1 = (o*d1-o1*d)/(d*c1) /\ x_i = o/d *) | None , (Some (coeff1,h1), o1, divi1) -> - subst_var (ts, is) h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) + subst_var t h1 (None, Z.(offs*divi1 - o1*divi),Z.(divi*coeff1)) (* (c*x_j+o)/d = x_i = o1/d1 *) (* ======> x_j = (o1*d-o*d1)/(d1*c) /\ x_i = o1/d1 *) - | Some (coeff,j), (None , o1, divi1) -> subst_var (ts, is) j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) + | Some (coeff,j), (None , o1, divi1) -> subst_var t j (None, Z.(o1*divi - offs*divi1),Z.(divi1*coeff)) (* (c*x_j+o)/d = x_i = (c1*x_h1+o1)/d1 *) (* ======> x_j needs normalization wrt. ts *) | Some (coeff,j), ((Some (coeff1,h1), o1, divi1) as oldi)-> @@ -212,22 +224,22 @@ struct let newxi = Rhs.subst (None,o2,divi2) j (Some (coeff,j),offs,divi) in let newxh1 = snd @@ EConj.inverse i (coeff1,h1,o1,divi1) in let newxh1 = Rhs.subst newxi i newxh1 in - subst_var (ts, is) h1 newxh1 + subst_var t h1 newxh1 (* ts[x_j]=(c2*x_h2+o2)/d2 ========> ... *) | (Some (coeff2,h2), o2, divi2) as normalizedj -> if h1 = h2 then (* this is the case where x_i and x_j already where in the same equivalence class; let's see whether the new equality contradicts the old one *) let normalizedi= Rhs.subst normalizedj j (Some(coeff,j),offs,divi) in - if not @@ Rhs.equal normalizedi oldi then raise EConj.Contradiction else (ts, is) + if not @@ Rhs.equal normalizedi oldi then raise EConj.Contradiction else t else if h1 < h2 (* good, we now unite the two equvalence classes; let's decide upon the representative *) then (* express h2 in terms of h1: *) let (_,newh2)= EConj.inverse j (coeff2,h2,o2,divi2) in let newh2 = Rhs.subst oldi i (Rhs.subst (snd @@ EConj.inverse i (coeff,j,offs,divi)) j newh2) in - subst_var (ts, is) h2 newh2 + subst_var t h2 newh2 else (* express h1 in terms of h2: *) let (_,newh1)= EConj.inverse i (coeff1,h1,o1,divi1) in let newh1 = Rhs.subst normalizedj j (Rhs.subst (Some(coeff,j),offs,divi) i newh1) in - subst_var (ts, is) h1 newh1)) in - if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show (ts,is)) i (Rhs.show (var,offs,divi)) (show res) + subst_var t h1 newh1)) in + if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show t) i (Rhs.show (var,offs,divi)) (show res) ; res let meet_with_one_value var value t meet_function = @@ -238,21 +250,21 @@ struct in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res - let join_with_one_value var value (t:t) = - let (_,cong) = constrain_with_congruence_from_rhs (fst t) var (Value.top) in (*TODO probably should be a flag in set_value to do a join instead of meet so we do not do this twice*) + let join_with_one_value var value ((ts, _, _) as t:t) = + let (_,cong) = constrain_with_congruence_from_rhs ts var (Value.top) in (*TODO probably should be a flag in set_value to do a join instead of meet so we do not do this twice*) let value' = Value.join value (Value.I.bot (), cong) in set_value t var value' end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. Furthermore, it provides the function [simplified_monomials_from_texp] that converts an apron expression into a list of monomials of reference variables and a constant offset *) -module VarManagement = +module VarManagement (Ineq : TwoVarInequalities) = struct - module EConjI = EqualitiesConjunctionWithIntervals - include SharedFunctions.VarManagementOps (EConjI) + module EConjI = EqualitiesConjunctionWithIntervals(Ineq) + include SharedFunctions.VarManagementOps (EqualitiesConjunctionWithIntervals(Ineq)) let dim_add = EConjI.dim_add - let size t = BatOption.map_default (fun ((d,_),_) -> d) 0 t.d + let size t = BatOption.map_default (fun ((d,_),_,_) -> d) 0 t.d (** Parses a Texpr to obtain a (coefficient, variable) pair list to repr. a sum of a variables that have a coefficient. If variable is None, the coefficient represents a constant offset. *) let monomials_from_texp (t: t) texp = @@ -357,6 +369,19 @@ struct | None -> Value.top | Some d -> EConjI.get_value d var_dim end + | Binop (Sub, Var a , Var b, Int, _) -> + (*TODO are there more locations where we can use the inequality information? What if we allow Ineq to return more precise information? (e.g. 5a < 4b + 11)*) + let dim_a = Environment.dim_of_var t.env a in + let dim_b = Environment.dim_of_var t.env b in + begin match t.d with + | None -> Value.top + | Some d -> + let v = Value.sub (EConjI.get_value d dim_a) (EConjI.get_value d dim_b) in + match EConjI.is_less_than d dim_a dim_b with + | None -> v + | Some true -> Value.meet v (Value.ending Z.minus_one) + | Some false -> Value.meet v (Value.starting Z.one) + end | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) | Unop (op, a, Int, _) -> (unop_function op) (eval a) | _ -> Value.top (*not integers*) @@ -365,6 +390,109 @@ struct if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Value.show res); res + (*TODO Could be more precise with query*) + let rec to_inequalities (t:t) texpr = + let open Apron.Texpr1 in + let inequality_from_add var expr = + let v = eval_texpr t expr in (*TODO we evaluate some subexpressions twice when calling this in assign_texpr -> bad for performance??*) + if Value.must_be_pos v then + [(Ineq.Gt, var)] + else if Value.must_be_neg v then + [(Ineq.Lt, var)] + else if Value.leq v (Value.of_bigint Z.zero) then + [(Ineq.Eq, var)] + else if Value.leq v (Value.starting Z.zero) then + [(Ineq.Ge, var)] + else if Value.leq v (Value.ending Z.zero) then + [(Ineq.Le, var)] + else + [] + in let inequality_from_mul var expr = + let v_expr = eval_texpr t expr in + let v_var = eval_texpr t (Var var) in + if Value.leq v_expr (Value.of_bigint Z.one) + || Value.leq v_var (Value.of_bigint Z.zero) + then [(Ineq.Eq, var)] + else + match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with + | true, _ , true, _ -> if Value.contains v_expr Z.one then [Ineq.Ge, var] else [Ineq.Gt, var] + | _, true, _ , true -> [Ineq.Gt, var] + | true, _ , _ , true -> if Value.contains v_expr Z.one then [Ineq.Le, var] else [Ineq.Lt, var] + | _ , true, true, _ -> [Ineq.Lt, var] + | _ , _ , _ , _ -> [] + in match texpr with + | Binop (Add, Var x, Var y, _, _) -> inequality_from_add x (Var y) @ inequality_from_add y (Var x) + | Binop (Add, e, Var y, _, _) + | Binop (Add, Var y, e, _, _) -> inequality_from_add y e + | Binop (Mul, Var x, Var y, _, _) -> inequality_from_mul x (Var y) @ inequality_from_mul y (Var x) + | Binop (Mul, e, Var y, _, _) + | Binop (Mul, Var y, e, _, _) -> inequality_from_add y e + | Binop (Sub, Var y, e, _, _) -> + let v = eval_texpr t e in + if Value.must_be_pos v then + [(Ineq.Lt, y)] + else if Value.must_be_neg v then + [(Ineq.Gt, y)] + else if Value.leq v (Value.of_bigint Z.zero) then + [(Ineq.Eq, y)] + else if Value.leq v (Value.starting Z.zero) then + [(Ineq.Le, y)] + else if Value.leq v (Value.ending Z.zero) then + [(Ineq.Ge, y)] + else + [] + | Binop (Div, Var y, e, _, _) -> begin + let v_expr = eval_texpr t e in + let v_var = eval_texpr t (Var y) in + if Value.leq v_expr (Value.of_bigint Z.one) + || Value.leq v_var (Value.of_bigint Z.zero) + then [(Ineq.Eq, y)] + else + match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with + | true, _ , true, _ -> if Value.contains v_expr Z.one then [Ineq.Le, y] else [Ineq.Lt, y] + | _, true, _ , true -> [Ineq.Gt, y] + | true, _ , _ , true -> if Value.contains v_expr Z.one then [Ineq.Ge, y] else [Ineq.Gt, y] + | _ , true, true, _ -> [Ineq.Lt, y] + | _ , _ , _ , _ -> [] + end + | Binop (Mod, e, Var y, _, _) -> + let v_var = eval_texpr t (Var y) in + if Value.must_be_pos v_var then + [Ineq.Lt, y] + else if Value.must_be_neg v_var then + [Ineq.Gt, y] + else [] + | Unop (Neg, e, _, _) -> + let v = eval_texpr t e in + let negate (cond, var) = + if Value.must_be_pos v then + match cond with + | Ineq.Lt | Ineq.Le | Ineq.Eq -> Some (Ineq.Lt, var) + | _ -> None + else if Value.must_be_neg v then + match cond with + | Ineq.Gt | Ineq.Ge | Ineq.Eq -> Some (Ineq.Gt, var) + | _ -> None + else if Value.leq v (Value.of_bigint Z.zero) then + Some (cond, var) + else if Value.leq v (Value.starting Z.zero) then + match cond with + | Ineq.Lt -> Some (Ineq.Lt, var) + | Ineq.Le | Ineq.Eq -> Some (Ineq.Le, var) + | _ -> None + else if Value.leq v (Value.ending Z.zero) then + match cond with + | Ineq.Gt -> Some (Ineq.Gt, var) + | Ineq.Ge | Ineq.Eq -> Some (Ineq.Ge, var) + | _ -> None + else + None + in List.filter_map negate (to_inequalities t e) + | Unop (Cast, e, _, _) -> to_inequalities t e + | Var x -> [(Ineq.Eq, x)] + | _ -> [] + + let assign_const t var const divi = match t.d with | None -> t | Some t_d -> {d = Some (EConjI.set_rhs t_d var (None, const, divi)); env = t.env} @@ -373,9 +501,9 @@ struct end -module ExpressionBounds: (SharedFunctions.ConvBounds with type t = VarManagement.t) = +module ExpressionBounds (Ineq : TwoVarInequalities): (SharedFunctions.ConvBounds with type t = VarManagement(Ineq).t) = struct - include VarManagement + include VarManagement (Ineq) let bound_texpr t texpr = let v = eval_texpr t (Texpr1.to_expr texpr) in @@ -390,13 +518,14 @@ struct let bound_texpr d texpr1 = timing_wrap "bounds calculation" (bound_texpr d) texpr1 end -module D = +module D (Ineq : TwoVarInequalities) = struct include Printable.Std include ConvenienceOps (SharedFunctions.Mpqf) + module VarManagement = VarManagement(Ineq) include VarManagement - module Bounds = ExpressionBounds + module Bounds = ExpressionBounds(Ineq) module V = RelationDomain.V module Arg = struct let allow_global = true @@ -438,11 +567,11 @@ struct let show varM = match varM.d with | None -> "⊥\n" - | Some arr -> + | Some (((dim,_), _, _) as arr) -> if is_bot varM then "Bot \n" else - EConjI.show_formatted (show_var varM.env) arr ^ (to_subscript @@ fst @@ fst arr) + EConjI.show_formatted (show_var varM.env) arr ^ (to_subscript dim) let pretty () (x:t) = text (show x) let printXml f x = BatPrintf.fprintf f "\n\n\nequalities\n\n\n%s\n\nenv\n\n\n%a\n\n\n" (XmlUtil.escape (show x)) Environment.printXml x.env @@ -485,15 +614,15 @@ struct in let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in let open Texpr1 in - let rec refine_expr d value expr = + let rec refine_values d value expr = if M.tracing then M.trace "refine_tcons" "refining expr %s with %s" (GobFormat.asprint print_expr expr) (Value.show value) ; match expr with | Binop (op,a,b,_,_) -> let refine_both op_a op_b = let b_val = eval d b in - let d' = refine_expr d (op_a value b_val) a in + let d' = refine_values d (op_a value b_val) a in let a_val = eval d' a in - refine_expr d' (op_b value a_val) b + refine_values d' (op_b value a_val) b in begin match op with | Add -> refine_both (Value.sub) (Value.sub) @@ -519,8 +648,8 @@ struct if is_pos then Value.meet (Value.starting Z.zero) full else if is_neg then Value.meet (Value.ending Z.zero) full else full - in let d' = refine_expr d (Value.add b_c rem) a in - refine_expr d' (Value.div (Value.sub a_val rem) value) b + in let d' = refine_values d (Value.add b_c rem) a in + refine_values d' (Value.div (Value.sub a_val rem) value) b | Mod -> (* a' = a/b*b + c and derived from it b' = (a-c)/(a/b) * The idea is to formulate a' as quotient * divisor + remainder. *) @@ -560,13 +689,13 @@ struct Value.meet a'' t | _, _ -> a'' in - let d' = refine_expr d (b') b in - refine_expr d' (a''') a + let d' = refine_values d (b') b in + refine_values d' (a''') a | Pow -> failwith "refine_with tcons: pow unsupported" end | Unop (op, e,_,_) -> begin match op with - | Neg -> refine_expr d (Value.neg value) e - | Cast -> refine_expr d value e + | Neg -> refine_values d (Value.neg value) e + | Cast -> refine_values d value e | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) end | Cst (Scalar x) -> @@ -576,9 +705,27 @@ struct end | Cst (Interval _) -> failwith "constant was an interval; this is not supported" | Var v -> refine_var d v value + in let refine_inequalities ((econ, vs, ineq) as d) expr = + let rhss = EConjI.get_rhs d in + let vss = EConjI.get_value d in + match expr with + | Binop (Sub, Var a, Var b, Int, _) -> + begin + let dim_a = Environment.dim_of_var t.env a in + let dim_b = Environment.dim_of_var t.env a in + let ineq' = match Tcons1.get_typ tcons with + | EQ -> Ineq.meet_condition dim_a dim_b Ineq.Eq rhss vss ineq + | SUP -> Ineq.meet_condition dim_b dim_a Ineq.Lt rhss vss ineq + | SUPEQ -> Ineq.meet_condition dim_b dim_a Ineq.Le rhss vss ineq + | _ -> ineq + in (econ, vs, ineq') + end + | _ -> d in try - let d' = refine_expr d initial_value (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) in - {d=Some d';env=t.env} + let expr = Texpr1.to_expr @@ Tcons1.get_texpr1 tcons in + let d' = refine_values d initial_value expr in + let d'' = refine_inequalities d' expr in + {d=Some d'';env=t.env} with EConj.Contradiction -> bot_env let refine_with_tcons t tcons = @@ -614,14 +761,31 @@ struct if M.tracing then M.tracel "meet" "%s with single value %s=%s -> %s" (show t) (show_var t.env i) (Value.show value) (show res); res + (*TODO do I need a narrow function??*) + let meet_with_inequalities ineq t = + match t.d with + | None -> t + | Some ((econ, vs, ineq2) as d) -> + try + { d = Some (econ, vs, Ineq.meet (EConjI.get_rhs d) (EConjI.get_value d) ineq ineq2); env = t.env} + with EConj.Contradiction -> + if M.tracing then M.trace "meet" " -> Contradiction with inequalities\n"; + { d = None; env = t.env} + + let meet_with_inequalities ineq t = + let res = meet_with_inequalities ineq t in + if M.tracing then M.tracel "meet" "%s with inequalities %s -> %s" (show t) (Ineq.show_formatted (show_var t.env) ineq) (show res); + res + let meet' t1 t2 meet_function = let sup_env = Environment.lce t1.env t2.env in let t1 = change_d t1 sup_env ~add:true ~del:false in let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with - | Some d1', Some d2' -> - let conj_met = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd @@ fst d2') t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) - in IntMap.fold (meet_with_one_value meet_function) (snd d2') conj_met + | Some d1', Some (econ, vs, ineq) -> + let conj_met = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd econ) t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + in let vals_met = IntMap.fold (meet_with_one_value meet_function) vs conj_met + in meet_with_inequalities ineq vals_met | _ -> {d = None; env = sup_env} let meet t1 t2 = @@ -644,15 +808,17 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in + (*TODO allow congruence implied by Rhs? or fix bug that some aren't always set*) let implies_value v i value = Value.leq (EConjI.get_value v i) value in if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true else if is_bot_env t2 || is_top t1 then false else - let m1, m2 = Option.get t1.d, Option.get t2.d in - let m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in - IntMap.for_all (implies @@ fst m1') (snd @@ fst m2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) - && IntMap.for_all (implies_value m1') (snd m2) + let m1, (econ2, vs2, ineq2) = Option.get t1.d, Option.get t2.d in + let (econ1, _, ineq1) as m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in + IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + && IntMap.for_all (implies_value m1') (vs2) + && Ineq.leq ineq1 (EConjI.get_value m1') ineq2 let leq a b = timing_wrap "leq" (leq a) b @@ -662,6 +828,7 @@ struct res (*The first parameter is the function used to join two values. Different uses for join / widen*) + (*TODO do wee need the same for the inequalities?*) let join' join_function a b = let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d in @@ -672,13 +839,14 @@ struct else let joined_value = join_function (EConjI.get_value x vars) (EConjI.get_value y vars) in collect_values x y econj_joined (vars-1) (EConjI.join_with_one_value vars joined_value t) in - let join_d x y env = - let econj' = join_econj (fst x) (fst y) env in + let join_d ((econ_x, _, ineq_x) as x) ((econ_y, _, ineq_y) as y) env = + let econj' = join_econj (econ_x) (econ_y) env in match econj' with None -> None | Some econj'' -> - if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj'') ; - Some (collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty)) + if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); + let ineq' = Ineq.join ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in + Some (collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq')) in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with @@ -746,7 +914,7 @@ struct This makes a copy of the data structure, it doesn't change it in-place. *) let assign_texpr (t: VarManagement.t) var texp = match t.d with - | Some d -> + | Some ((econj, vs, ineq) as d) -> let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in let t' = match simplify_to_ref_and_offset t texp with | None -> @@ -757,14 +925,22 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform (fst d) var_i (coeff_var, var_i, off, divi), snd d); env=t.env } + {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), vs, ineq); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env - | Some d' -> {d = Some (EConjI.set_value d' var_i (VarManagement.eval_texpr t texp)); env = t'.env} (*TODO query instead?! *) + | Some d' -> + (*TODO use query for more precision instead?!*) + let (econ, vs, ineq) = EConjI.set_value d' var_i (VarManagement.eval_texpr t texp) in + let meet_cond ineq (cond, var) = + let dim = Environment.dim_of_var t.env var in + Ineq.meet_condition var_i dim cond (EConjI.get_rhs d) (EConjI.get_value d) ineq + in + let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in + {d = Some (econ, vs, ineq'); env = t'.env} end | None -> bot_env @@ -965,7 +1141,7 @@ struct let ri = Environment.var_of_dim t.env r in of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi); (GobApron.Coeff.s_of_z c, ri)] o :: acc in - BatOption.get t.d |> fun ((_,map),_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + BatOption.get t.d |> fun ((_,map),_,_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 @@ -979,9 +1155,9 @@ struct end -module D2: RelationDomain.RD with type var = Var.t = +module D2 (Ineq : TwoVarInequalities): RelationDomain.RD with type var = Var.t = struct - module D = D + module D = D(Ineq) module ConvArg = struct let allow_global = false end diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index e97a0453a3..5a6414f7cc 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -268,3 +268,60 @@ module IntervalAndCongruence = struct end module Value = IntervalAndCongruence + +module type TwoVarInequalities = sig + type t + type cond = Lt | Le | Eq | Gt | Ge + + (*We need to know which root a constant is referring to, so we use Either *) + val is_less_than : ((Rhs.t, int) Either.t * Value.t) -> ((Rhs.t, int) Either.t * Value.t) -> t -> bool option + + (*meet x' < y' (or with = / <= *) + val meet_condition : int -> int -> cond -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t + + val meet : (int -> Rhs.t) -> (int -> Value.t) -> t -> t -> t + + val leq : t -> (int -> Value.t) -> t -> bool + + val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t + + val show_formatted : (int -> string) -> t -> string + val hash : t -> int + val empty : t + val is_empty : t -> bool + val equal : t -> t -> bool + val compare : t -> t -> int + val modify_variables_in_domain : t -> int array -> (int -> int -> int) -> t + val forget_variable : t -> int -> t +end + +module NoInequalties : TwoVarInequalities = struct + type t = unit + type cond = Lt | Le | Eq | Gt | Ge + + let is_less_than _ _ _ = None + let meet_condition _ _ _ _ _ _ = () + + let meet _ _ _ _ = () + + let leq _ _ _ = true + let join _ _ _ _ = () + + let show_formatted _ _ = "{}" + let hash _ = 3 + let empty = () + let is_empty _ = true + let equal _ _ = true + let compare _ _ = 0 + let modify_variables_in_domain _ _ _ = () + let forget_variable _ _ = () +end + +module type Coeffs = sig + type t +end + +module CommonActions (Coeffs : Coeffs) = struct + type t = Coeffs.t IntMap.t IntMap.t + +end From 9e61ceceb60fbb5403f159e00fc4e8bcb5ab1df5 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 3 Mar 2025 16:32:59 +0100 Subject: [PATCH 20/86] Simple Inequalities implemented, but not completely tested --- ...earTwoVarEqualityAnalysisPentagon.apron.ml | 5 +- .../apron/linearTwoVarEqualityDomain.apron.ml | 18 +- ...inearTwoVarEqualityDomainPentagon.apron.ml | 45 ++-- .../apron/pentagonSubDomains.apron.ml | 226 +++++++++++++++++- src/config/options.schema.json | 7 + 5 files changed, 272 insertions(+), 29 deletions(-) diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml index 36ef7a6057..399c7a5515 100644 --- a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -5,9 +5,12 @@ open Analyses include RelationAnalysis +module NoIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.NoInequalties) +module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.SimpleInequalities) + let spec_module: (module MCPSpec) Lazy.t = lazy ( - let module AD = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.NoInequalties) + let (module AD) = if GobConfig.get_bool "ana.lin2vareq_p" then (module WithIneq : RelationDomain.RD) else (module NoIneq : RelationDomain.RD) in let module Priv = (val RelationPriv.get_priv ()) in let module Spec = diff --git a/src/cdomains/apron/linearTwoVarEqualityDomain.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomain.apron.ml index 6af7030a51..e722e4effc 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomain.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomain.apron.ml @@ -98,8 +98,9 @@ module EqualitiesConjunction = struct (** add/remove new variables to domain with particular indices; translates old indices to keep consistency add if op = (+), remove if op = (-) the semantics of indexes can be retrieved from apron: https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html *) - let modify_variables_in_domain (dim,map) indexes op = - if Array.length indexes = 0 then (dim,map) else + + let modify_variables_in_domain_general map map_value indexes op = + if Array.length indexes = 0 then map else let offsetlist = Array.to_list indexes in let rec bumpvar delta i = function (* bump the variable i by delta; find delta by counting indices in offsetlist until we reach a larger index then our current parameter *) | head::rest when i>=head -> bumpvar (delta+1) i rest (* rec call even when =, in order to correctly interpret double bumps *) @@ -116,13 +117,18 @@ module EqualitiesConjunction = struct IntHashtbl.add h x r; r) in - let rec bumpentry k (refvar,offset,divi) = function (* directly bumps lhs-variable during a run through indexes, bumping refvar explicitly with a new lookup in indexes *) + let rec bumpentry k value = function (* directly bumps lhs-variable during a run through indexes, bumping refvar explicitly with a new lookup in indexes *) - | (tbl,delta,head::rest) when k>=head -> bumpentry k (refvar,offset,divi) (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) - | (tbl,delta,lyst) (* k (IntMap.add (op k delta) (BatOption.map (fun (c,v) -> (c,memobumpvar v)) refvar,offset,divi) tbl, delta, lyst) + | (tbl,delta,head::rest) when k>=head -> bumpentry k value (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) + | (tbl,delta,lyst) (* k (IntMap.add (op k delta) (map_value memobumpvar value) tbl, delta, lyst) in let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,offsetlist) in (* Build new map during fold with bumped key/vals *) - (op dim (Array.length indexes), a) + a + + let modify_variables_in_domain (dim,map) indexes op = + let map_value bumpvar (refvar,offset,divi) = (BatOption.map (fun (c,v) -> (c,bumpvar v)) refvar,offset,divi) in + (op dim (Array.length indexes), modify_variables_in_domain_general map map_value indexes op) + let modify_variables_in_domain m cols op = let res = modify_variables_in_domain m cols op in if M.tracing then M.tracel "modify_dims" "dimarray bumping with (fun x -> x + %d) at positions [%s] in { %s } -> { %s }" diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 2369792611..a0b260e6c3 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -32,13 +32,7 @@ struct let is_top_con (e, is, ineq) = EConj.is_top_con e && IntMap.is_empty is && Ineq.is_empty ineq let modify_variables_in_domain_values map indexes op = - if Array.length indexes = 0 then map else - let rec bumpentry k v = function - | (tbl,delta,head::rest) when k>=head -> bumpentry k v (tbl,delta+1,rest) (* rec call even when =, in order to correctly interpret double bumps *) - | (tbl,delta,lyst) (* k (IntMap.add (op k delta) v tbl, delta, lyst) - in - let (a,_,_) = IntMap.fold bumpentry map (IntMap.empty,0,Array.to_list indexes) in (* Build new map during fold with bumped keys *) - a + let map_value _ = identity in EConj.modify_variables_in_domain_general map map_value indexes op let modify_variables_in_domain_values map indexes op = let res = modify_variables_in_domain_values map indexes op in if M.tracing then @@ -49,6 +43,7 @@ struct (show_values (Printf.sprintf "var_%d") res); res + (*TODO we now potentially create the memo_bumpvar function three times (using it twice)-> inefficient?*) let dim_add (ch: Apron.Dim.change) (econj, i, ineq) = (EConj.dim_add ch econj, modify_variables_in_domain_values i ch.dim (+), Ineq.modify_variables_in_domain ineq ch.dim (+)) @@ -83,13 +78,14 @@ struct | Some i -> Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) + (*Does not check the values directly, only the inequality domain, so we can use this to detect contradictions *) let is_less_than ((_,vs,ineq) as t) x y = - let get_information lhs = let rhs = get_rhs t lhs in match rhs with - | (Some (_,var), _ ,_) -> (Either.Left rhs, get_value t var) - | (_,o,_) -> (Either.Right lhs, Value.of_bigint o) + | (Some (_,var), _ ,_) -> (rhs, get_value t var) + (*We need to know which root a constant is referring to, so we use this the trivial equation to carry that information*) + | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) in Ineq.is_less_than (get_information x) (get_information y) ineq @@ -391,6 +387,7 @@ struct res (*TODO Could be more precise with query*) + (*TODO We also only catch variables on the first level, but miss e.g. (x+7)+7 -> use more recursion similar to negate?*) let rec to_inequalities (t:t) texpr = let open Apron.Texpr1 in let inequality_from_add var expr = @@ -492,6 +489,12 @@ struct | Var x -> [(Ineq.Eq, x)] | _ -> [] + let to_inequalities (t:t) texpr = + let res = to_inequalities t texpr in + let show_ineq (cond, var) = Ineq.show_cond cond ^ " " ^ Var.show var ^ ", " + in if M.tracing then M.tracel "inequalities" "expr: %a ineq: %s" Texpr1.Expr.pretty texpr (List.fold (^) "" @@ List.map show_ineq res); + res + let assign_const t var const divi = match t.d with | None -> t @@ -709,10 +712,12 @@ struct let rhss = EConjI.get_rhs d in let vss = EConjI.get_value d in match expr with + (*TODO we could use to_inequalities for more flexible handeling?*) | Binop (Sub, Var a, Var b, Int, _) -> begin let dim_a = Environment.dim_of_var t.env a in - let dim_b = Environment.dim_of_var t.env a in + let dim_b = Environment.dim_of_var t.env b in + if M.tracing then M.tracel "meet_condition" "calling from refine inside %s" (EConjI.show d) ; let ineq' = match Tcons1.get_typ tcons with | EQ -> Ineq.meet_condition dim_a dim_b Ineq.Eq rhss vss ineq | SUP -> Ineq.meet_condition dim_b dim_a Ineq.Lt rhss vss ineq @@ -722,7 +727,7 @@ struct end | _ -> d in try - let expr = Texpr1.to_expr @@ Tcons1.get_texpr1 tcons in + let expr = to_expr @@ Tcons1.get_texpr1 tcons in let d' = refine_values d initial_value expr in let d'' = refine_inequalities d' expr in {d=Some d'';env=t.env} @@ -808,7 +813,7 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in - (*TODO allow congruence implied by Rhs? or fix bug that some aren't always set*) + (*TODO allow congruence implied by Rhs? or fix bug that some aren't always set!!*) let implies_value v i value = Value.leq (EConjI.get_value v i) value in if env_comp = -2 || env_comp > 0 then false else @@ -828,7 +833,7 @@ struct res (*The first parameter is the function used to join two values. Different uses for join / widen*) - (*TODO do wee need the same for the inequalities?*) + (*TODO do we need the same for the inequalities? not for simple inequalities, but for more complex ones*) let join' join_function a b = let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d in @@ -914,7 +919,7 @@ struct This makes a copy of the data structure, it doesn't change it in-place. *) let assign_texpr (t: VarManagement.t) var texp = match t.d with - | Some ((econj, vs, ineq) as d) -> + | Some (econj, vs, ineq) -> let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in let t' = match simplify_to_ref_and_offset t texp with | None -> @@ -934,12 +939,16 @@ struct bot_env | Some d' -> (*TODO use query for more precision instead?!*) - let (econ, vs, ineq) = EConjI.set_value d' var_i (VarManagement.eval_texpr t texp) in + let (econ, vs, ineq) as d'' = EConjI.set_value d' var_i (VarManagement.eval_texpr t texp) in + if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some (econ, vs, ineq); env = t.env}); let meet_cond ineq (cond, var) = let dim = Environment.dim_of_var t.env var in - Ineq.meet_condition var_i dim cond (EConjI.get_rhs d) (EConjI.get_value d) ineq + if dim <> var_i then (*TODO If cond = Eq, we could restore the previous state before forgetting the variable*) + Ineq.meet_condition var_i dim cond (EConjI.get_rhs d'') (EConjI.get_value d'') ineq + else ineq in let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in + if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some (econ, vs, ineq'); env = t.env}); {d = Some (econ, vs, ineq'); env = t'.env} end | None -> bot_env @@ -1116,7 +1125,7 @@ struct let relift t = t - (*TODO add value information to invariants?*) + (*TODO add inequalities (and value information?) to invariants*) (** representation as C expression This function returns all the equalities that are saved in our datastructure t. diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 5a6414f7cc..741034ef54 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -9,7 +9,7 @@ module EConj = LinearTwoVarEqualityDomain.EqualitiesConjunction module IntMap = EConj.IntMap -(*MOdules for creating an unbounded interval arithmethic with the existing interval domain*) +(*Modules for creating an unbounded interval arithmethic with the existing interval domain*) module TopIntBase (Int_t : IntOps.IntOpsBase) = struct type sign = Pos | Neg [@@deriving eq, hash] @@ -273,8 +273,9 @@ module type TwoVarInequalities = sig type t type cond = Lt | Le | Eq | Gt | Ge - (*We need to know which root a constant is referring to, so we use Either *) - val is_less_than : ((Rhs.t, int) Either.t * Value.t) -> ((Rhs.t, int) Either.t * Value.t) -> t -> bool option + val show_cond : cond -> string + + val is_less_than : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> bool option (*meet x' < y' (or with = / <= *) val meet_condition : int -> int -> cond -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t @@ -299,6 +300,13 @@ module NoInequalties : TwoVarInequalities = struct type t = unit type cond = Lt | Le | Eq | Gt | Ge + let show_cond c = match c with + | Le -> "<=" + | Lt -> "<" + | Eq -> "=" + | Gt -> ">" + | Ge -> ">=" + let is_less_than _ _ _ = None let meet_condition _ _ _ _ _ _ = () @@ -319,9 +327,219 @@ end module type Coeffs = sig type t + val implies : Value.t -> Value.t -> t option -> t -> bool + val meet : Value.t -> Value.t -> t -> t -> t + val hash : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val show_formatted : string -> string -> t -> string + end module CommonActions (Coeffs : Coeffs) = struct - type t = Coeffs.t IntMap.t IntMap.t + type cond = Lt | Le | Eq | Gt | Ge + + type t = Coeffs.t IntMap.t IntMap.t [@@deriving eq, ord ] + + let show_cond c = match c with + | Le -> "<=" + | Lt -> "<" + | Eq -> "=" + | Gt -> ">" + | Ge -> ">=" + + let empty = IntMap.empty + let is_empty = IntMap.is_empty + let hash t = IntMap.fold (fun _ ys acc -> IntMap.fold (fun _ coeff acc -> Coeffs.hash coeff + 3*acc) ys (5*acc)) t 0 + + let show_formatted formatter t = + if IntMap.is_empty t then "{}" else + let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (Coeffs.show_formatted (formatter x) (formatter y) coeff) acc) ys acc) t "" + in "{" ^ (*String.sub str 0 (String.length str - 3) *) str ^ "}" (*TODO why does this not work when removing the things?*) + + let show = show_formatted (Printf.sprintf "var_%d") + + let forget_variable t v = + IntMap.map (fun ys -> IntMap.remove v ys) (IntMap.remove v t) + + let modify_variables_in_domain map indexes op = + let map_fun bump_var ys = IntMap.fold (fun y -> IntMap.add (bump_var y) ) ys IntMap.empty in + EConj.modify_variables_in_domain_general map map_fun indexes op + + let get_coeff x y t = BatOption.bind (IntMap.find_opt x t) (fun ys -> IntMap.find_opt y ys) + + let set_coeff x y coeff t = + IntMap.add x (IntMap.add y coeff @@ IntMap.find_default IntMap.empty x t ) t + + let remove_coeff x y t = + IntMap.add x (IntMap.remove y @@ IntMap.find_default IntMap.empty x t ) t + + let leq t1 get_value_t1 t2 = + let implies x y t2_coeff = + let t1_coeff = get_coeff x y t1 in + Coeffs.implies (get_value_t1 x) (get_value_t1 y) t1_coeff t2_coeff + in + IntMap.for_all (fun x ys -> IntMap.for_all (implies x) ys) t2 + + let meet_one_coeff get_value x y coeff t = + let coeff_t = get_coeff x y t in + let coeff_met = match coeff_t with + | None -> coeff + | Some coeff_t -> Coeffs.meet (get_value x) (get_value y) coeff coeff_t + in set_coeff x y coeff_met t + + (*TODO I do not see an obvious way that an inequalitiy between roots could contradict a rhs. Is there one?*) + let meet get_rhs get_value t1 t2 = + IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff get_value x) ys t) t2 t1 end + +(*Equations of the type x < y*) +module NoCoeffs = struct + type t = unit [@@deriving eq, ord, hash ] + + let implies x y t1_opt _ = match t1_opt with + | Some _ -> true + | None -> match Value.maximal x, Value.minimal y with + | Some x, Some y -> TopIntOps.compare x y < 0 + | _, _ -> false + + let meet x y _ _ = + match Value.minimal x, Value.maximal y with + | Some x, Some y when TopIntOps.compare x y > 0 -> raise EConj.Contradiction + | _, _ -> () + + let show_formatted x y t = x ^ " < " ^ y + +end + +(*Semantics: x -> y -> () => x < y*) +module SimpleInequalities : TwoVarInequalities = struct + module Coeffs = NoCoeffs + include CommonActions(Coeffs) + + let join t1 get_val_t1 t2 get_val_t2 = + let merge_y x y c1 c2 = + let of_bool b = if b then Some () else None in + match c1 with + | Some c1 -> of_bool (Coeffs.implies (get_val_t2 x) (get_val_t2 y) c2 c1) + | None -> match c2 with + | Some c2 -> of_bool (Coeffs.implies (get_val_t1 x) (get_val_t1 y) c1 c2) + | None -> None + in let merge_x x ys1 ys2 = + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + in match ys1, ys2 with + | Some ys1, None -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t2 x) (get_val_t2 y) None coeff ) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t1 x) (get_val_t1 y) None coeff ) ys2) + | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) + | _, _ -> None in + IntMap.merge (merge_x) t1 t2 + + let is_less_than x y t = + let check_inequality ((var_x,o_x,d_x), val_x) ((var_y,o_y,d_y), val_y) = + if M.tracing then M.trace "is_less_than" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); + match var_x, var_y with + | Some (c_x, x), Some (c_y, y) -> begin + match get_coeff x y t with + | None -> + if M.tracing then M.trace "is_less_than" "no inequality for roots"; + None (*No information*) + | Some _ -> (*we know x < y -> check if this translates to x' < y' or x' > y'*) + let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in + let d_o = Z.sub (Z.mul o_x d_y) (Z.mul o_y d_x) in + let x_d_c = Value.mul val_x (Value.of_bigint d_c) in + if Z.lt c_y Z.zero && Value.leq x_d_c (Value.ending d_o) (* c_y < 0, x * d_c <= d_o*) + then Some false (*x' > y '*) + else if Z.gt c_y Z.zero && Value.leq x_d_c (Value.starting d_o) (* c_y > 0, x * d_c >= d_o*) + then Some true (*x' < y '*) + else + let d_c' = Z.neg d_c in + let d_o' = Z.neg d_o in + let y_d_c = Value.mul val_y (Value.of_bigint d_c') in + if Z.lt c_x Z.zero && Value.leq y_d_c (Value.starting d_o') (* c_x < 0, y * d_c >= d_o*) + then Some false (*x' > y '*) + else if Z.gt c_x Z.zero && Value.leq y_d_c (Value.ending d_o') (* c_x > 0, y * d_c <= d_o*) + then Some true (*x' < y '*) + else None + end + | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) + in + let res = check_inequality x y in + if res = None then BatOption.map not @@ check_inequality y x + else res + + let is_less_than x y t = + let res = is_less_than x y t in + if M.tracing then M.trace "is_less_than" "result: %s" (BatOption.map_default (Bool.to_string) "unknown" res); + res + + (**) + let meet_condition x' y' cond get_rhs get_value t = + (*TODO should we check values for contradictions?*) + (*strict: if the inequality is strict *) + let meet_less_root x y strict t = + if M.tracing then M.tracel "meet_condition" "meet_less_root x: %d y: %d strict: %b " x y strict; + let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) + in let union' = if strict then IntMap.add y () union else union + in if IntMap.mem x union then raise EConj.Contradiction + else IntMap.add x union' t + in + let meet_less x' y' strict t = + if M.tracing then M.tracel "meet_condition" "meet_less x': %d y': %d strict: %b" x' y' strict; + let get_rhs' lhs = + match get_rhs lhs with + | (Some (c,v),o,d) -> c,v,o,d + | (None, o, d) -> Z.one, lhs, Z.zero, Z.one + in let (c_x, x, o_x, d_x) = get_rhs' x' + in let (c_y, y, o_y, d_y) = get_rhs' y' + in if M.tracing then M.tracel "meet_condition" "x' = %s, y' = %s " (Rhs.show (Some (c_x, x),o_x,d_x)) (Rhs.show (Some (c_y,y),o_y,d_y)); + let val_x = get_value x + in let val_y = get_value y in + let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in + let d_o = Z.sub (Z.mul o_x d_y) (Z.mul o_y d_x) in + let x_d_c = Value.mul val_x (Value.of_bigint d_c) in + if Value.leq x_d_c (Value.ending d_o) then (*x * d_c <= d_o*) + (*We are strict iff we have been strict before or this bound is strict*) + if Z.lt c_y Z.zero then meet_less_root y x (strict || Value.leq x_d_c (Value.ending (Z.sub d_o Z.one))) t + else meet_less_root x y (strict || Value.leq x_d_c (Value.ending (Z.sub d_o Z.one))) t + else + let d_c' = Z.neg d_c in + let d_o' = Z.neg d_o in + let y_d_c = Value.mul val_y (Value.of_bigint d_c') in + if Value.leq y_d_c (Value.starting d_o') then (*x * d_c >= d_o*) + (*We are strict iff we have been strict before or this bound is strict*) + if Z.gt c_y Z.zero then meet_less_root x y (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t + else meet_less_root y x (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t + else t + in + match cond with + | Gt -> meet_less y' x' true t + | Ge -> meet_less y' x' false t + | Eq -> + let rhs_x = get_rhs x' in + let rhs_y = get_rhs y' in + if M.tracing then M.tracel "meet_condition" "in equality: x' (var_%d) = %s, y' (var_%d)= %s " x' (Rhs.show rhs_x) y' (Rhs.show rhs_y); + if Rhs.equal rhs_x rhs_y then begin + if M.tracing then M.tracel "meet_condition" "equality with same rhs"; + let x,y = match rhs_x, rhs_y with + | (Some (_,x), _,_), (Some (_,y), _,_) -> (x,y) + | (None,_,_), (None, _,_) -> x',y' + | _,_ -> failwith "Should never happen" + in + let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in + if IntMap.mem x union || IntMap.mem y union then raise EConj.Contradiction + else IntMap.add x union @@ IntMap.add y union t + end else + meet_less x' y' false @@ meet_less y' x' false t (*TODO skip repeat calculations?*) + | Le -> meet_less x' y' false t + | Lt -> meet_less x' y' true t + + let meet_condition x y c r v t = + if M.tracing then M.tracel "meet_condition" "meeting %s with x': %d y': %d cond %s" (show t) x y (show_cond c); + let res = meet_condition x y c r v t in + if M.tracing then M.tracel "meet_condition" "result: %s " (show res); + res + +end \ No newline at end of file diff --git a/src/config/options.schema.json b/src/config/options.schema.json index 39c863ad49..e01d6c8416 100644 --- a/src/config/options.schema.json +++ b/src/config/options.schema.json @@ -995,6 +995,13 @@ }, "additionalProperties": false }, + "lin2vareq_p": { + "title": "ana.lin2vareq_p", + "description": + "Use inequalities", + "type": "boolean", + "default": true + }, "context": { "title": "ana.context", "type": "object", From 17047fa9578284273703d892af96fcb64a5e6b27 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 6 Mar 2025 01:32:55 +0100 Subject: [PATCH 21/86] transfering inequalities when assigning, bug fix in to_inequalities --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 12 ++--- .../apron/pentagonSubDomains.apron.ml | 45 ++++++++++++++++++- 2 files changed, 51 insertions(+), 6 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a0b260e6c3..a928c65a49 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -423,7 +423,7 @@ struct | Binop (Add, Var y, e, _, _) -> inequality_from_add y e | Binop (Mul, Var x, Var y, _, _) -> inequality_from_mul x (Var y) @ inequality_from_mul y (Var x) | Binop (Mul, e, Var y, _, _) - | Binop (Mul, Var y, e, _, _) -> inequality_from_add y e + | Binop (Mul, Var y, e, _, _) -> inequality_from_mul y e | Binop (Sub, Var y, e, _, _) -> let v = eval_texpr t e in if Value.must_be_pos v then @@ -919,7 +919,7 @@ struct This makes a copy of the data structure, it doesn't change it in-place. *) let assign_texpr (t: VarManagement.t) var texp = match t.d with - | Some (econj, vs, ineq) -> + | Some ((econj, vs, ineq_old) as d) -> let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in let t' = match simplify_to_ref_and_offset t texp with | None -> @@ -930,7 +930,7 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), vs, ineq); env=t.env } + {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), vs, Ineq.forget_variable ineq_old var_i); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) @@ -943,9 +943,11 @@ struct if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some (econ, vs, ineq); env = t.env}); let meet_cond ineq (cond, var) = let dim = Environment.dim_of_var t.env var in - if dim <> var_i then (*TODO If cond = Eq, we could restore the previous state before forgetting the variable*) + if dim <> var_i then Ineq.meet_condition var_i dim cond (EConjI.get_rhs d'') (EConjI.get_value d'') ineq - else ineq + else + (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen?*) + Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d'') (EConjI.get_value d'') in let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some (econ, vs, ineq'); env = t.env}); diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 741034ef54..ab866778b4 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -286,6 +286,9 @@ module type TwoVarInequalities = sig val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t + (*copy all constraints for some variable to a different t if they still hold for a new x' with x' (cond) x *) + val transfer : int -> cond -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t + val show_formatted : (int -> string) -> t -> string val hash : t -> int val empty : t @@ -294,6 +297,7 @@ module type TwoVarInequalities = sig val compare : t -> t -> int val modify_variables_in_domain : t -> int array -> (int -> int -> int) -> t val forget_variable : t -> int -> t + end module NoInequalties : TwoVarInequalities = struct @@ -323,6 +327,8 @@ module NoInequalties : TwoVarInequalities = struct let compare _ _ = 0 let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () + + let transfer _ _ _ _ _ _ _ _ = () end module type Coeffs = sig @@ -483,7 +489,7 @@ module SimpleInequalities : TwoVarInequalities = struct if M.tracing then M.tracel "meet_condition" "meet_less_root x: %d y: %d strict: %b " x y strict; let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in let union' = if strict then IntMap.add y () union else union - in if IntMap.mem x union then raise EConj.Contradiction + in if IntMap.mem x union' then raise EConj.Contradiction else IntMap.add x union' t in let meet_less x' y' strict t = @@ -542,4 +548,41 @@ module SimpleInequalities : TwoVarInequalities = struct if M.tracing then M.tracel "meet_condition" "result: %s " (show res); res + (*TODO I think this will be the same (or at least almost) for all the domain, but depends on is_less_than / meet_condition -> make it general?*) + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + let was_less_than x y = + let get_information lhs = + let rhs = get_rhs_old lhs in + match rhs with + | (Some (_,var), _ ,_) -> (rhs, get_value_old var) + (*We need to know which root a constant is referring to, so we use this the trivial equation to carry that information*) + | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) + in + is_less_than (get_information x) (get_information y) t_old + in let vars_to_check = + let root = match get_rhs_old x with + | (Some (_,var), _ ,_) -> var + | (_,o,_) -> x + (*we need to check all y with root -> y -> coeff or y -> root -> coeff*) + in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) + in let keep_less = match cond with + | Eq | Lt | Le -> true + | _ -> false + in let keep_greater = match cond with + | Eq | Gt | Ge -> true + | _ -> false + in let transfer_single_var t' y = + match was_less_than x y with + | Some true -> + if keep_less then meet_condition x y Lt get_rhs get_value t' else t' + | Some false -> + if keep_greater then meet_condition x y Gt get_rhs get_value t' else t' + | _ -> t' + in BatEnum.fold (transfer_single_var) t vars_to_check + + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + let res = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in + if M.tracing then M.tracel "transfer" "transfering for var_%d with cond: %s from %s into %s -> %s" x (show_cond cond) (show t_old) (show t) (show res); + res + end \ No newline at end of file From 34331f1afe151e5f96b3322ced69d72819ab4ded Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 6 Mar 2025 18:43:44 +0100 Subject: [PATCH 22/86] Integrate Interval / Congruence with bounds into the original files --- .../value/cdomains/int/congruenceDomain.ml | 72 ++- .../int/congruenceDomainNormFunctor.ml | 532 ------------------ .../value/cdomains/int/intervalDomain.ml | 62 +- .../cdomains/int/intervalDomainWithBounds.ml | 443 --------------- .../apron/pentagonSubDomains.apron.ml | 6 +- 5 files changed, 103 insertions(+), 1012 deletions(-) delete mode 100644 src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml delete mode 100644 src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml index 003e33a624..1ab1b3e0c5 100644 --- a/src/cdomain/value/cdomains/int/congruenceDomain.ml +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -1,8 +1,12 @@ open IntDomain0 open GoblintCil +(*TODO Test and remove code duplication*) +module type Norm = sig + val normalize : ikind -> (Z.t * Z.t) option -> (Z.t * Z.t) option +end -module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = +module CongruenceFunctor (Norm : Norm): S with type int_t = Z.t and type t = (Z.t * Z.t) option = struct let name () = "congruences" type int_t = Z.t @@ -24,22 +28,7 @@ struct 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 normalize = Norm.normalize let range ik = Size.range ik @@ -494,3 +483,52 @@ struct let project ik p t = t end + +module Wrapping : Norm = struct + + let (%:) = Z.rem + let (=:) = Z.equal + let (+:) = Z.add + let (<:) x y = Z.compare x y < 0 + + 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') +end + +module NoWrapping : Norm = struct + + let (%:) = Z.rem + let (=:) = Z.equal + let (+:) = Z.add + let (<:) x y = Z.compare x y < 0 + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + 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') +end + +module Congruence = CongruenceFunctor(Wrapping) \ No newline at end of file diff --git a/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml b/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml deleted file mode 100644 index 0ea6f350e8..0000000000 --- a/src/cdomain/value/cdomains/int/congruenceDomainNormFunctor.ml +++ /dev/null @@ -1,532 +0,0 @@ -open IntDomain0 -open GoblintCil - -(*TODO Test and remove code duplication*) -module type Norm = sig - val normalize : ikind -> (Z.t * Z.t) option -> (Z.t * Z.t) option -end - -module Wrapping : Norm = struct - - let (%:) = Z.rem - let (=:) = Z.equal - let (+:) = Z.add - let (<:) x y = Z.compare x y < 0 - - 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') -end - -module NoWrapping : Norm = struct - - let (%:) = Z.rem - let (=:) = Z.equal - let (+:) = Z.add - let (<:) x y = Z.compare x y < 0 - - let normalize ik x = - match x with - | None -> None - | Some (c, m) -> - if m =: Z.zero then - 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') -end - -module Congruence (Norm : Norm): 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 = Norm.normalize - - 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 diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml index 7d7329e76a..6a6e9a166b 100644 --- a/src/cdomain/value/cdomains/int/intervalDomain.ml +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -1,30 +1,30 @@ open IntDomain0 +(**TODO Better Naming!*) +module type BoundedIntOps = sig + include IntOps.IntOps -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) + type t_interval = (t * t) option + + val range : GoblintCil.ikind -> t * t + val top_of : GoblintCil.ikind -> t_interval + val bot_of : GoblintCil.ikind -> t_interval + + val norm : ?suppress_ovwarn:bool -> ?cast:bool -> GoblintCil.ikind -> t_interval -> t_interval * overflow_info +end + +module Bounded (Ints_t : IntOps.IntOps): BoundedIntOps with type t = Ints_t.t and type t_interval = (Ints_t.t * Ints_t.t) option = struct + include Ints_t + type t_interval = (Ints_t.t * Ints_t.t) option 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 bot_of ik = None (* 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) -> + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t_interval -> t_interval * 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 ( @@ -60,6 +60,32 @@ struct (v, ov_info) ) +end + +module BoundedIntervalFunctor (Ints_t : BoundedIntOps): SOverflow with type int_t = Ints_t.t and type t = Ints_t.t_interval = +struct + let name () = "intervals bounds injected" + 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 = Ints_t.range + let top_of = Ints_t.top_of + let norm = Ints_t.norm + let bot_of = Ints_t.bot_of + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let bot () = None + + 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 leq (x:t) (y:t) = match x, y with | None, _ -> true @@ -413,5 +439,7 @@ struct let project ik p t = t end +module IntervalFunctor (Ints_t : IntOps.IntOps) = BoundedIntervalFunctor (Bounded(Ints_t)) + module Interval = IntervalFunctor (IntOps.BigIntOps) module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) diff --git a/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml b/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml deleted file mode 100644 index b809462cf5..0000000000 --- a/src/cdomain/value/cdomains/int/intervalDomainWithBounds.ml +++ /dev/null @@ -1,443 +0,0 @@ -open IntDomain0 - -(**TODO Better Naming!*) -module type BoundedIntOps = sig - include IntOps.IntOps - - type t_interval = (t * t) option - - val range : GoblintCil.ikind -> t * t - val top_of : GoblintCil.ikind -> t_interval - val bot_of : GoblintCil.ikind -> t_interval - - - val norm : ?suppress_ovwarn:bool -> ?cast:bool -> GoblintCil.ikind -> t_interval -> t_interval * overflow_info -end - -module Bounded (Ints_t : IntOps.IntOps): BoundedIntOps with type t = Ints_t.t and type t_interval = (Ints_t.t * Ints_t.t) option = struct - include Ints_t - type t_interval = (Ints_t.t * Ints_t.t) option - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top_of ik = Some (range ik) - let bot_of ik = None (* TODO: improve *) - - - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t_interval -> t_interval * 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) - ) - -end - -module IntervalFunctor (Ints_t : BoundedIntOps): SOverflow with type int_t = Ints_t.t and type t = Ints_t.t_interval = -struct - let name () = "intervals bounds injected" - 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 = Ints_t.range - let top_of = Ints_t.top_of - let norm = Ints_t.norm - let bot_of = Ints_t.bot_of - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - let bot () = None - - 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 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 Interval = IntervalFunctor (Bounded(IntOps.BigIntOps)) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (Bounded(IntOps.Int64Ops))))) (IntIkind) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index ab866778b4..5e1a1ba69b 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -170,7 +170,7 @@ module TopIntOps = struct end -module Unbounded : IntervalDomainWithBounds.BoundedIntOps with type t = TopIntOps.t = struct +module Unbounded : IntervalDomain.BoundedIntOps with type t = TopIntOps.t = struct include TopIntOps type t_interval = (t * t) option [@@deriving eq, ord, hash] @@ -191,8 +191,8 @@ end (*Combining operations into one reduced product for values*) module IntervalAndCongruence = struct - module I = IntDomain0.SOverflowUnlifter(IntervalDomainWithBounds.IntervalFunctor(Unbounded)) - module C = CongruenceDomainNormFunctor.Congruence(CongruenceDomainNormFunctor.NoWrapping) + module I = IntDomain0.SOverflowUnlifter(IntervalDomain.BoundedIntervalFunctor(Unbounded)) + module C = CongruenceDomain.CongruenceFunctor(CongruenceDomain.NoWrapping) type t = I.t * C.t [@@deriving eq, ord, hash] From c74832f7a167f9bf5c6f2c9e2bb127906544dce9 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 6 Mar 2025 19:13:52 +0100 Subject: [PATCH 23/86] Use queries when assigning expressions --- src/cdomain/value/cdomains/int/intDomTuple.ml | 3 ++ src/cdomain/value/cdomains/intDomain.mli | 1 + ...inearTwoVarEqualityDomainPentagon.apron.ml | 35 ++++++++++++++----- .../apron/pentagonSubDomains.apron.ml | 6 ++++ tests/regression/82-lin2vareq_p/31-careful.c | 3 +- 5 files changed, 38 insertions(+), 10 deletions(-) diff --git a/src/cdomain/value/cdomains/int/intDomTuple.ml b/src/cdomain/value/cdomains/int/intDomTuple.ml index 34647795d8..420e14d7e9 100644 --- a/src/cdomain/value/cdomains/int/intDomTuple.ml +++ b/src/cdomain/value/cdomains/int/intDomTuple.ml @@ -123,6 +123,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 to_congruence (_,_,_,c,_) = match c with Some c -> c | None -> I4.top () let refine_with_congruence ik ((a, b, c, d, e) : t) (cong : (int_t * int_t) option) : t= let opt f a = @@ -519,6 +520,8 @@ struct 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} + + let to_congruence (x: I.t) = IntDomTupleImpl.to_congruence x.v end let of_const (i, ik, str) = IntDomTuple.of_int ik i diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index e7667c9b14..34fb61fcb4 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -355,6 +355,7 @@ module IntDomTuple : sig val no_interval: t -> t val no_intervalSet: t -> t val ikind: t -> ikind + val to_congruence : t -> CongruenceDomain.Congruence.t end val of_const: Z.t * Cil.ikind * string option -> IntDomTuple.t diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a928c65a49..2bdd847cb2 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -615,6 +615,7 @@ struct if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; EConjI.meet_with_one_value dim value d Value.meet ) in + (*TODO Could be more precise with query ?? would need to convert back to Cil *) let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in let open Texpr1 in let rec refine_values d value expr = @@ -930,24 +931,22 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), vs, Ineq.forget_variable ineq_old var_i); env=t.env } + {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), IntMap.remove var_i vs, Ineq.forget_variable ineq_old var_i); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env - | Some d' -> - (*TODO use query for more precision instead?!*) - let (econ, vs, ineq) as d'' = EConjI.set_value d' var_i (VarManagement.eval_texpr t texp) in + | Some ((econ, vs, ineq) as d') -> if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some (econ, vs, ineq); env = t.env}); let meet_cond ineq (cond, var) = let dim = Environment.dim_of_var t.env var in if dim <> var_i then - Ineq.meet_condition var_i dim cond (EConjI.get_rhs d'') (EConjI.get_value d'') ineq + Ineq.meet_condition var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq else (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen?*) - Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d'') (EConjI.get_value d'') + Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') in let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some (econ, vs, ineq'); env = t.env}); @@ -962,9 +961,27 @@ struct -> Convert.texpr1_expr_of_cil_exp handles overflow *) let assign_exp ask (t: VarManagement.t) var exp (no_ov: bool Lazy.t) = let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in - match Convert.texpr1_expr_of_cil_exp ask t t.env exp no_ov with - | texp -> assign_texpr t var texp - | exception Convert.Unsupported_CilExp _ -> forget_var t var + (*evaluate in the same way as is used for simplification*) + let t = match Convert.texpr1_expr_of_cil_exp ask t t.env exp no_ov with + | texp -> assign_texpr t var texp + | exception Convert.Unsupported_CilExp _ -> forget_var t var + in match t.d with + | None -> t + | Some d -> + let value = + try Value.of_IntDomTuple + (GobRef.wrap AnalysisState.executing_speculative_computations true ( fun () -> + let ikind = Cilfacade.get_ikind_exp exp in + match ask.f (EvalInt exp) with + | `Bot -> failwith "EvalInt returned bot" (* This should never happen according to Michael Schwarz *) + | `Top -> IntDomain.IntDomTuple.top_of ikind + | `Lifted x -> x (* Cast should be unnecessary because it should be taken care of by EvalInt. *) + )) + with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) + in + let d' = EConjI.set_value d (Environment.dim_of_var t.env var) value in + {d=Some d'; env = t.env} + let assign_exp ask t var exp no_ov = let res = assign_exp ask t var exp no_ov in diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 5e1a1ba69b..3546f4a9d7 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -265,6 +265,12 @@ module IntervalAndCongruence = struct let maximal (i,_) = I.maximal i let minimal (i,_) = I.minimal i + let of_IntDomTuple tuple = + let interval = match IntDomain.IntDomTuple.minimal tuple, IntDomain.IntDomTuple.maximal tuple with + | Some min, Some max -> Some ( TopIntOps.Int min, TopIntOps.Int max) + | _ -> None + in (interval, IntDomain.IntDomTuple.to_congruence tuple) + end module Value = IntervalAndCongruence diff --git a/tests/regression/82-lin2vareq_p/31-careful.c b/tests/regression/82-lin2vareq_p/31-careful.c index b83c7bc147..ff5dc4cc8c 100644 --- a/tests/regression/82-lin2vareq_p/31-careful.c +++ b/tests/regression/82-lin2vareq_p/31-careful.c @@ -17,6 +17,7 @@ int main(void) { // Both hold in the concrete - __goblint_check(j == i-1); //UNKNOWN + // First is SUCCESS here and not for lin2vareq because the interval domain is queried when assigning (but not yet in the condition) + __goblint_check(j == i-1); //SUCCESS __goblint_check(j == i + UINT_MAX); //UNKNOWN } From 2deec187fb4daa3e992345dc75a1000f2b1d8d30 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 6 Mar 2025 23:26:02 +0100 Subject: [PATCH 24/86] Fixed small bugs --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 14 +++++++++----- src/cdomains/apron/pentagonSubDomains.apron.ml | 2 +- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 2bdd847cb2..d9e2ca96b7 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -125,6 +125,7 @@ struct let set_value ((econ, is, ineq) as t:t) lhs i = if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show t); + if Value.is_bot i then raise EConj.Contradiction; let set_value_for_root lhs i = if M.tracing then M.tracel "modify_pentagon" "set_value_for_root var_%d=%s, before: %s" lhs (Value.show i) (show t); let i = constrain_with_congruence_from_rhs econ lhs i in @@ -383,7 +384,7 @@ struct | _ -> Value.top (*not integers*) in let res = eval texp in - if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (EConjI.show @@ BatOption.get t.d) Texpr1.Expr.pretty texp (Value.show res); + if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (match t.d with None -> "⊥" | Some d ->EConjI.show d) Texpr1.Expr.pretty texp (Value.show res); res (*TODO Could be more precise with query*) @@ -973,14 +974,17 @@ struct (GobRef.wrap AnalysisState.executing_speculative_computations true ( fun () -> let ikind = Cilfacade.get_ikind_exp exp in match ask.f (EvalInt exp) with - | `Bot -> failwith "EvalInt returned bot" (* This should never happen according to Michael Schwarz *) + | `Bot -> IntDomain.IntDomTuple.bot_of ikind | `Top -> IntDomain.IntDomTuple.top_of ikind - | `Lifted x -> x (* Cast should be unnecessary because it should be taken care of by EvalInt. *) + | `Lifted x -> + if M.tracing then M.trace "assign_exp" "Query for %a returned %s" d_exp exp (IntDomain.IntDomTuple.show x); + x (* Cast should be unnecessary because it should be taken care of by EvalInt. *) )) with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) in - let d' = EConjI.set_value d (Environment.dim_of_var t.env var) value in - {d=Some d'; env = t.env} + let d' = if Value.is_bot value then None + else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) + in {d= d'; env = t.env} let assign_exp ask t var exp no_ov = diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 3546f4a9d7..8c1e99d2ff 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -269,7 +269,7 @@ module IntervalAndCongruence = struct let interval = match IntDomain.IntDomTuple.minimal tuple, IntDomain.IntDomTuple.maximal tuple with | Some min, Some max -> Some ( TopIntOps.Int min, TopIntOps.Int max) | _ -> None - in (interval, IntDomain.IntDomTuple.to_congruence tuple) + in refine (interval, IntDomain.IntDomTuple.to_congruence tuple) end From 3fee37711fd1d8a2870cb422fdce59064d9f4091 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 7 Mar 2025 00:46:24 +0100 Subject: [PATCH 25/86] Fixed more bugs --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 39 +++++++++++-------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index d9e2ca96b7..5928268ba4 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -969,22 +969,25 @@ struct in match t.d with | None -> t | Some d -> - let value = - try Value.of_IntDomTuple - (GobRef.wrap AnalysisState.executing_speculative_computations true ( fun () -> - let ikind = Cilfacade.get_ikind_exp exp in - match ask.f (EvalInt exp) with - | `Bot -> IntDomain.IntDomTuple.bot_of ikind - | `Top -> IntDomain.IntDomTuple.top_of ikind - | `Lifted x -> - if M.tracing then M.trace "assign_exp" "Query for %a returned %s" d_exp exp (IntDomain.IntDomTuple.show x); - x (* Cast should be unnecessary because it should be taken care of by EvalInt. *) - )) - with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) - in - let d' = if Value.is_bot value then None - else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) - in {d= d'; env = t.env} + if exp = MyCFG.unknown_exp then + t + else + let value = + try Value.of_IntDomTuple + (GobRef.wrap AnalysisState.executing_speculative_computations true ( fun () -> + let ikind = Cilfacade.get_ikind_exp exp in + match ask.f (EvalInt exp) with + | `Bot -> IntDomain.IntDomTuple.bot_of ikind + | `Top -> IntDomain.IntDomTuple.top_of ikind + | `Lifted x -> + if M.tracing then M.trace "assign_exp" "Query for %a returned %s" d_exp exp (IntDomain.IntDomTuple.show x); + x (* Cast should be unnecessary because it should be taken care of by EvalInt. *) + )) + with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) + in + let d' = if Value.is_bot value then None + else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) + in {d= d'; env = t.env} let assign_exp ask t var exp no_ov = @@ -1173,7 +1176,9 @@ struct let ri = Environment.var_of_dim t.env r in of_coeff xi [(GobApron.Coeff.s_of_z @@ Z.neg d, xi); (GobApron.Coeff.s_of_z c, ri)] o :: acc in - BatOption.get t.d |> fun ((_,map),_,_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + match t.d with + | None -> [] + | Some d -> d |> fun ((_,map),_,_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 From 280be0d92162fb3bf8f33099db64715bc752d9b3 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 7 Mar 2025 19:42:29 +0100 Subject: [PATCH 26/86] Fixed forget_variable not keeping invariant when root was deleted, added transfering of information if possible --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 94 ++++++++++++++----- .../apron/pentagonSubDomains.apron.ml | 16 ++-- 2 files changed, 80 insertions(+), 30 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 5928268ba4..a449dabe88 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -47,22 +47,6 @@ struct let dim_add (ch: Apron.Dim.change) (econj, i, ineq) = (EConj.dim_add ch econj, modify_variables_in_domain_values i ch.dim (+), Ineq.modify_variables_in_domain ineq ch.dim (+)) - - let forget_variable (econj, is, ineq) var = (EConj.forget_variable econj var, IntMap.remove var is, Ineq.forget_variable ineq var) - - let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = - if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then - (econj, v, ineq) - else ( - let cpy = Array.copy ch.dim in - Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) - let (econj', v', ineq') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, v, ineq) cpy in (* clear m' from relations concerning ch.dim *) - let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in - let v'' = modify_variables_in_domain_values v' cpy (-) in - let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in - (econj'', v'', ineq'')) - - let get_rhs (econ, _, _) = EConj.get_rhs econ let get_value ((econ, vs, _) as t) lhs = @@ -177,6 +161,70 @@ struct if M.tracing then M.tracel "modify_pentagon" "set_rhs before: %s eq: var_%d=%s -> %s " (show t) lhs (Rhs.show rhs) (show res); res + let forget_variable ((econj, _, _) as d) var = + let rhs_var = get_rhs d var in + let value_var = get_value d var in + let (econj', vs', ineq'), newRoot = + (let ref_var_opt = Tuple3.first rhs_var in + match ref_var_opt with + | Some (_,ref_var) when ref_var = var -> + if M.tracing then M.trace "forget" "headvar var_%d" var; + (* var is the reference variable of its connected component *) + (let cluster = List.sort (Int.compare) @@ IntMap.fold + (fun i (refe,_,_) l -> BatOption.map_default (fun (coeff,refe) -> if (refe=ref_var) then i::l else l) l refe) (snd econj) [] in + if M.tracing then M.trace "forget" "cluster varindices: [%s]" (String.concat ", " (List.map (string_of_int) cluster)); + (* obtain cluster with common reference variable ref_var*) + match cluster with (* new ref_var is taken from head of the cluster *) + | head :: clusterrest -> + (* head: divi*x = coeff*y + offs *) + (* divi*x = coeff*y + offs =inverse=> y =( divi*x - offs)/coeff *) + let (newref,offs,divi) = (get_rhs d head) in + let (coeff,y) = BatOption.get newref in + let (y,yrhs) = EConj.inverse head (coeff,y,offs,divi) in (* reassemble yrhs out of components *) + let shifted_cluster = (List.fold (fun map i -> + let irhs = (get_rhs d i) in (* old entry is i = irhs *) + Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) + set_rhs map i + ) d clusterrest) in + set_rhs shifted_cluster head (Rhs.var_zero head), Some head (* finally make sure that head is now trivial *) + | [] -> d, None) (* empty cluster means no work for us *) + | _ -> d, None) (* variable is either a constant or expressed by another refvar *) in + (*Forget old information*) + let econj'' = (fst econj', IntMap.remove var (snd econj')) in (* set d(var) to unknown, finally *) + let vs'' = IntMap.remove var vs' in + let ineq'' = Ineq.forget_variable ineq' var in + let d' = (econj'', vs'', ineq'') in + (*Try restoring information for new head*) + let d'' = + match newRoot with + | None -> d' + | Some newRoot -> + let cond = + match get_rhs d newRoot with + | (Some (c,_), o, d) when Z.equal c Z.one && Z.equal o Z.zero && Z.equal d Z.one -> Some Ineq.Eq + | rhs_new -> match Ineq.is_less_than (rhs_new, get_value d newRoot) (rhs_var, value_var) ineq'' with (*relation of new root to root before this call*) + | None -> None + | Some true -> Some Lt + | Some false -> Some Gt + in match cond with + | None -> d' + | Some cond -> econj'', vs'', Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq'' (get_rhs d') (get_value d') + in + if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show d) (show d''); + d'' + + let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = + if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then + (econj, v, ineq) + else ( + let cpy = Array.copy ch.dim in + Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) + let (econj', v', ineq') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, v, ineq) cpy in (* clear m' from relations concerning ch.dim *) + let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in + let v'' = modify_variables_in_domain_values v' cpy (-) in + let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in + (econj'', v'', ineq'')) + let meet_with_one_conj ((ts, is, ineq) as t:t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = @@ -815,7 +863,6 @@ struct (* normalize in case of a full blown equality *) | Some (coeffj,j) -> tuple_cmp (EConj.get_rhs ts i) @@ Rhs.subst (EConj.get_rhs ts j) j (var, offs, divi) in - (*TODO allow congruence implied by Rhs? or fix bug that some aren't always set!!*) let implies_value v i value = Value.leq (EConjI.get_value v i) value in if env_comp = -2 || env_comp > 0 then false else @@ -947,7 +994,7 @@ struct Ineq.meet_condition var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq else (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen?*) - Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') + Ineq.transfer dim dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') in let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some (econ, vs, ineq'); env = t.env}); @@ -1089,20 +1136,23 @@ struct | SUP when Z.gt constant Z.zero -> t | DISEQ when not @@ Z.equal constant Z.zero -> t | EQMOD _ -> t - | _ -> bot_env (* all other results are violating the guard *) + | _ -> if M.tracing then M.tracel "meet_tcons" "meet_one_conj case 0"; + bot_env (* all other results are violating the guard *) end | [(coeff, index, divi)] -> (* guard has a single reference variable only *) - if Tcons1.get_typ tcons = EQ then + if Tcons1.get_typ tcons = EQ then begin + if M.tracing then M.tracel "meet_tcons" "meet_one_conj case 1"; meet_with_one_conj t index (Rhs.canonicalize (None, Z.neg @@ Z.(divi*constant),Z.(coeff*divisor))) - else + end else t (* only EQ is supported in equality based domains *) | [(c1,var1,d1); (c2,var2,d2)] -> (* two variables in relation needs a little sorting out *) begin match Tcons1.get_typ tcons with | EQ -> (* c1*var1/d1 + c2*var2/d2 +constant/divisor = 0*) (* ======> c1*divisor*d2 * var1 = -c2*divisor*d1 * var2 +constant*-d1*d2*) (* \/ c2*divisor*d1 * var2 = -c1*divisor*d2 * var1 +constant*-d1*d2*) + if M.tracing then M.tracel "meet_tcons" "meet_one_conj case 2"; let open Z in - if var1 < var2 then + if var1 < var2 then meet_with_one_conj t var2 (Rhs.canonicalize (Some (neg @@ c1*divisor,var1),neg @@ constant*d2*d1,c2*divisor*d1)) else meet_with_one_conj t var1 (Rhs.canonicalize (Some (neg @@ c2*divisor,var2),neg @@ constant*d2*d1,c1*divisor*d2)) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 8c1e99d2ff..f4eb118d1c 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -293,7 +293,7 @@ module type TwoVarInequalities = sig val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t (*copy all constraints for some variable to a different t if they still hold for a new x' with x' (cond) x *) - val transfer : int -> cond -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t + val transfer : int -> int -> cond -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t val show_formatted : (int -> string) -> t -> string val hash : t -> int @@ -334,7 +334,7 @@ module NoInequalties : TwoVarInequalities = struct let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () - let transfer _ _ _ _ _ _ _ _ = () + let transfer _ _ _ _ _ _ _ _ _ = () end module type Coeffs = sig @@ -555,7 +555,7 @@ module SimpleInequalities : TwoVarInequalities = struct res (*TODO I think this will be the same (or at least almost) for all the domain, but depends on is_less_than / meet_condition -> make it general?*) - let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = let was_less_than x y = let get_information lhs = let rhs = get_rhs_old lhs in @@ -580,15 +580,15 @@ module SimpleInequalities : TwoVarInequalities = struct in let transfer_single_var t' y = match was_less_than x y with | Some true -> - if keep_less then meet_condition x y Lt get_rhs get_value t' else t' + if keep_less then meet_condition x_new y Lt get_rhs get_value t' else t' | Some false -> - if keep_greater then meet_condition x y Gt get_rhs get_value t' else t' + if keep_greater then meet_condition x_new y Gt get_rhs get_value t' else t' | _ -> t' in BatEnum.fold (transfer_single_var) t vars_to_check - let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = - let res = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in - if M.tracing then M.tracel "transfer" "transfering for var_%d with cond: %s from %s into %s -> %s" x (show_cond cond) (show t_old) (show t) (show res); + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in + if M.tracing then M.tracel "transfer" "transfering var_%d -> var_%d with cond: %s from %s into %s -> %s" x x_new (show_cond cond) (show t_old) (show t) (show res); res end \ No newline at end of file From b6028148d8f9f955a517ca0e68596b35f86027f7 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 7 Mar 2025 23:35:31 +0100 Subject: [PATCH 27/86] Make InEq stay sparse --- src/cdomains/apron/pentagonSubDomains.apron.ml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index f4eb118d1c..2cad1e60ba 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -366,13 +366,14 @@ module CommonActions (Coeffs : Coeffs) = struct let show_formatted formatter t = if IntMap.is_empty t then "{}" else + if IntMap.exists (fun _ -> IntMap.is_empty) t then failwith "Map not sparse" else let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (Coeffs.show_formatted (formatter x) (formatter y) coeff) acc) ys acc) t "" - in "{" ^ (*String.sub str 0 (String.length str - 3) *) str ^ "}" (*TODO why does this not work when removing the things?*) + in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" let show = show_formatted (Printf.sprintf "var_%d") let forget_variable t v = - IntMap.map (fun ys -> IntMap.remove v ys) (IntMap.remove v t) + IntMap.filter_map (fun _ ys -> let ys' = IntMap.remove v ys in if IntMap.is_empty ys' then None else Some ys') (IntMap.remove v t) let modify_variables_in_domain map indexes op = let map_fun bump_var ys = IntMap.fold (fun y -> IntMap.add (bump_var y) ) ys IntMap.empty in @@ -383,8 +384,10 @@ module CommonActions (Coeffs : Coeffs) = struct let set_coeff x y coeff t = IntMap.add x (IntMap.add y coeff @@ IntMap.find_default IntMap.empty x t ) t - let remove_coeff x y t = - IntMap.add x (IntMap.remove y @@ IntMap.find_default IntMap.empty x t ) t + let remove_coeff x y t = + let new_map = IntMap.remove y @@ IntMap.find_default IntMap.empty x t in + if IntMap.is_empty new_map then t + else IntMap.add x new_map t let leq t1 get_value_t1 t2 = let implies x y t2_coeff = @@ -496,6 +499,7 @@ module SimpleInequalities : TwoVarInequalities = struct let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in let union' = if strict then IntMap.add y () union else union in if IntMap.mem x union' then raise EConj.Contradiction + else if IntMap.is_empty union' then t else IntMap.add x union' t in let meet_less x' y' strict t = @@ -542,6 +546,7 @@ module SimpleInequalities : TwoVarInequalities = struct in let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in if IntMap.mem x union || IntMap.mem y union then raise EConj.Contradiction + else if IntMap.is_empty union then t else IntMap.add x union @@ IntMap.add y union t end else meet_less x' y' false @@ meet_less y' x' false t (*TODO skip repeat calculations?*) From 99ed24b1255f37626fe0e0010579441e9c768f7a Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 7 Mar 2025 23:42:37 +0100 Subject: [PATCH 28/86] Fixed get_value not returning correct congruence information. Make all functions use our set_rhs instead of EConj. Small precision fix in forget_variable --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 48 +++++++++++++------ 1 file changed, 33 insertions(+), 15 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a449dabe88..036f8c1721 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -57,9 +57,11 @@ struct if (v,o,d) = Rhs.var_zero lhs then Value.top (*no relation -> Top*) else match v with None -> Value.div (Value.of_bigint o) (Value.of_bigint d)(*constant*) (*TODO is divisor always 1?*) - | Some (coeff,v) -> match IntMap.find_opt v vs with - None -> Value.top (*uninitialised*) - | Some i -> Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) + | Some (coeff,v) -> + let i = match IntMap.find_opt v vs with + None -> Value.top (*uninitialised. Still translate it with the Rhs for congruence information*) + | Some i -> i + in Value.div (Value.add (Value.of_bigint o) @@ Value.mul (Value.of_bigint coeff) i) (Value.of_bigint d) (*Does not check the values directly, only the inequality domain, so we can use this to detect contradictions *) @@ -206,9 +208,10 @@ struct | None -> None | Some true -> Some Lt | Some false -> Some Gt - in match cond with - | None -> d' - | Some cond -> econj'', vs'', Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq'' (get_rhs d') (get_value d') + in let after_ineq = match cond with + | None -> d' + | Some cond -> econj'', vs'', Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq'' (get_rhs d') (get_value d') + in set_value after_ineq newRoot @@ get_value d newRoot in if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show d) (show d''); d'' @@ -287,18 +290,31 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show t) i (Rhs.show (var,offs,divi)) (show res) ; res + + let affine_transform ((econ, vs, ineq) as t) i (coeff, j, offs, divi) = + if EConj.nontrivial econ i then (* i cannot occur on any other rhs apart from itself *) + set_rhs t i (Rhs.subst (get_rhs t i) i (Some (coeff,j), offs, divi)) + else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) + (* so now, we transform with the inverse of the transformer: *) + let inv = snd (EConj.inverse i (coeff,j,offs,divi)) in + IntMap.fold (fun k v acc -> + match v with + | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) + | _ -> acc + ) (snd econ) t + + let affine_transform econ i rhs = + let res = affine_transform econ i rhs in + if M.tracing then M.tracel "modify_pentagon" "affine_transform %s -> %s " (show econ) (show res); + res + let meet_with_one_value var value t meet_function = - let refined_value = Value.refine value in - let new_value = meet_function refined_value (get_value t var) + let new_value = meet_function value (get_value t var) in if Value.is_bot new_value then raise EConj.Contradiction else - let res = set_value t var new_value + let res = set_value t var new_value in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res - let join_with_one_value var value ((ts, _, _) as t:t) = - let (_,cong) = constrain_with_congruence_from_rhs ts var (Value.top) in (*TODO probably should be a flag in set_value to do a join instead of meet so we do not do this twice*) - let value' = Value.join value (Value.I.bot (), cong) in - set_value t var value' end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -891,7 +907,7 @@ struct if vars < 0 then t else if EConj.nontrivial econj_joined vars then collect_values x y econj_joined (vars-1) t (*we only need values for roots of the connected components*) else let joined_value = join_function (EConjI.get_value x vars) (EConjI.get_value y vars) in - collect_values x y econj_joined (vars-1) (EConjI.join_with_one_value vars joined_value t) + collect_values x y econj_joined (vars-1) (EConjI.meet_with_one_value vars joined_value t Value.meet) in let join_d ((econ_x, _, ineq_x) as x) ((econ_y, _, ineq_y) as y) env = let econj' = join_econj (econ_x) (econ_y) env in @@ -979,7 +995,8 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - {d=Some (EConj.affine_transform econj var_i (coeff_var, var_i, off, divi), IntMap.remove var_i vs, Ineq.forget_variable ineq_old var_i); env=t.env } + let econji' = econj, IntMap.remove var_i vs, Ineq.forget_variable ineq_old var_i in + {d=Some (EConjI.affine_transform econji' var_i (coeff_var, var_i, off, divi)); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) @@ -1032,6 +1049,7 @@ struct )) with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) in + (*TODO If the newly assigned value must be greater / lower than the old, we can transfer conditions!*) let d' = if Value.is_bot value then None else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) in {d= d'; env = t.env} From cfad8f679ac195f5e21a0bc78acb5a21c43360c5 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 8 Mar 2025 01:20:30 +0100 Subject: [PATCH 29/86] Revert changes to affine_transform, add comment why this is correct --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 036f8c1721..088dfdc964 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -290,18 +290,11 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show t) i (Rhs.show (var,offs,divi)) (show res) ; res - - let affine_transform ((econ, vs, ineq) as t) i (coeff, j, offs, divi) = - if EConj.nontrivial econ i then (* i cannot occur on any other rhs apart from itself *) - set_rhs t i (Rhs.subst (get_rhs t i) i (Some (coeff,j), offs, divi)) - else (* var_i = var_i, i.e. it may occur on the rhs of other equalities *) - (* so now, we transform with the inverse of the transformer: *) - let inv = snd (EConj.inverse i (coeff,j,offs,divi)) in - IntMap.fold (fun k v acc -> - match v with - | (Some (c,x),o,d) when x=i-> set_rhs acc k (Rhs.subst inv i v) - | _ -> acc - ) (snd econ) t + let affine_transform (econ, vs, ineq) i rhs = + (*This is a place we want to use the original set_rhs, as the implied congruence might contradict each other during the transformation*) + (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) + (*This is only called in assign_texpr, after which the value will be set correctly.*) + (EConj.affine_transform econ i rhs, vs, ineq) let affine_transform econ i rhs = let res = affine_transform econ i rhs in From 87bba0c8bdc654915764b57bdd96411eae95ad7b Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 11 Mar 2025 01:39:04 +0100 Subject: [PATCH 30/86] Make Termination Analysis use new domain instead of apron polyhedra (TESTING ONLYeval !!) --- src/autoTune.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/autoTune.ml b/src/autoTune.ml index 7313d95881..b504efc906 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -246,7 +246,7 @@ let focusOnMemSafetySpecification () = let focusOnTermination (spec: Svcomp.Specification.t) = match spec with | Termination -> - let terminationAnas = ["threadflag"; "apron"] in + let terminationAnas = ["threadflag"; "lin2vareq_p"] in Logs.info "Specification: Termination -> enabling termination analyses \"%s\"" (String.concat ", " terminationAnas); enableAnalyses terminationAnas; set_string "sem.int.signed_overflow" "assume_none"; From 8489b54fb38a4d1829a21a664650bb3dfb59e722 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 11 Mar 2025 02:50:12 +0100 Subject: [PATCH 31/86] Fix TopIntOps returning usefull values for widening when bound is top --- src/cdomains/apron/pentagonSubDomains.apron.ml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 2cad1e60ba..b4040d7823 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -25,9 +25,13 @@ struct | _ , Top Neg | Top Pos, _ -> 1 + let max_val = Int_t.add Int_t.one @@ Int_t.of_bigint @@ snd @@ IntDomain0.Size.range IULongLong + let min_val = Int_t.add (Int_t.of_int @@ -1) @@ Int_t.of_bigint @@ fst @@ IntDomain0.Size.range ILongLong + let get_int_t = function | Int i -> i - | _ -> failwith "get_int_t on top value" + | Top Pos -> max_val (*needed so that we can call to_bigint on Top (e.g. for widening constants)*) + | Top Neg -> min_val let neg_s = function | Pos -> Neg @@ -133,7 +137,14 @@ struct | Top Pos -> "+∞" | Top Neg -> "-∞" - let of_bigint i = Int (Int_t.of_bigint i) + (*Normalizes values outside the maximum range. Normalization is not done anywhere else + because we may temporarily have values outside that range e.g. when applying an equations*) + let of_bigint i = let i = Int_t.of_bigint i in + if Int_t.compare i max_val >= 0 + then Top Pos + else if Int_t.compare i min_val <= 0 + then Top Neg + else Int i let to_bigint t = Int_t.to_bigint @@ get_int_t t (*TODO*) From 2ccdc553851103b7eb222e327ad31b2b58c39fd3 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 20 Mar 2025 14:32:58 +0100 Subject: [PATCH 32/86] start of Complex linear inequalities, make join part of common actions, add widening and narrow to interface of inequalities --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 43 +++-- .../apron/pentagonSubDomains.apron.ml | 171 +++++++++++++++--- 2 files changed, 164 insertions(+), 50 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 088dfdc964..0ef3ccff13 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -301,7 +301,8 @@ struct if M.tracing then M.tracel "modify_pentagon" "affine_transform %s -> %s " (show econ) (show res); res - let meet_with_one_value var value t meet_function = + let meet_with_one_value var value t narrow = + let meet_function = if narrow then Value.narrow else Value.meet in let new_value = meet_function value (get_value t var) in if Value.is_bot new_value then raise EConj.Contradiction else let res = set_value t var new_value @@ -671,7 +672,7 @@ struct | _ -> d (*TODO if value is a constant, we sometimes could do some refinement*) end else ( if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; - EConjI.meet_with_one_value dim value d Value.meet ) + EConjI.meet_with_one_value dim value d false ) in (*TODO Could be more precise with query ?? would need to convert back to Cil *) let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in @@ -812,12 +813,12 @@ struct if M.tracing then M.tracel "meet" "%s with single eq %s=%s -> %s" (show t) (Z.(to_string @@ Tuple3.third e)^ show_var t.env i) (Rhs.show_rhs_formatted (show_var t.env) e) (show res); res - let meet_with_one_value meet_function i value t = + let meet_with_one_value narrow i value t = let res = match t.d with | None -> t | Some d -> try - { d = Some (EConjI.meet_with_one_value i value d meet_function); env = t.env} + { d = Some (EConjI.meet_with_one_value i value d narrow); env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction with value\n"; { d = None; env = t.env} @@ -825,35 +826,34 @@ struct if M.tracing then M.tracel "meet" "%s with single value %s=%s -> %s" (show t) (show_var t.env i) (Value.show value) (show res); res - (*TODO do I need a narrow function??*) - let meet_with_inequalities ineq t = + let meet_with_inequalities narrow ineq t = match t.d with | None -> t | Some ((econ, vs, ineq2) as d) -> try - { d = Some (econ, vs, Ineq.meet (EConjI.get_rhs d) (EConjI.get_value d) ineq ineq2); env = t.env} + { d = Some (econ, vs, (if narrow then Ineq.narrow else Ineq.meet) (EConjI.get_value d) ineq ineq2); env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction with inequalities\n"; { d = None; env = t.env} - let meet_with_inequalities ineq t = - let res = meet_with_inequalities ineq t in + let meet_with_inequalities narrow ineq t = + let res = meet_with_inequalities narrow ineq t in if M.tracing then M.tracel "meet" "%s with inequalities %s -> %s" (show t) (Ineq.show_formatted (show_var t.env) ineq) (show res); res - let meet' t1 t2 meet_function = + let meet' t1 t2 narrow = let sup_env = Environment.lce t1.env t2.env in let t1 = change_d t1 sup_env ~add:true ~del:false in let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with | Some d1', Some (econ, vs, ineq) -> let conj_met = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd econ) t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) - in let vals_met = IntMap.fold (meet_with_one_value meet_function) vs conj_met - in meet_with_inequalities ineq vals_met + in let vals_met = IntMap.fold (meet_with_one_value narrow) vs conj_met + in meet_with_inequalities narrow ineq vals_met | _ -> {d = None; env = sup_env} let meet t1 t2 = - meet' t1 t2 Value.meet + meet' t1 t2 false let meet t1 t2 = let res = meet t1 t2 in @@ -890,17 +890,15 @@ struct if M.tracing then M.tracel "leq" "leq a: %s b: %s -> %b" (show t1) (show t2) res ; res - (*The first parameter is the function used to join two values. Different uses for join / widen*) - (*TODO do we need the same for the inequalities? not for simple inequalities, but for more complex ones*) - let join' join_function a b = + let join' widen a b = let join_econj ad bd env = (LinearTwoVarEqualityDomain.D.join {d = Some ad; env} {d = Some bd; env}).d in (*Check all variables (up to index vars) if we need to save an value for them*) let rec collect_values x y econj_joined vars t = if vars < 0 then t else if EConj.nontrivial econj_joined vars then collect_values x y econj_joined (vars-1) t (*we only need values for roots of the connected components*) - else let joined_value = join_function (EConjI.get_value x vars) (EConjI.get_value y vars) in - collect_values x y econj_joined (vars-1) (EConjI.meet_with_one_value vars joined_value t Value.meet) + else let joined_value = (if widen then Value.widen else Value.join) (EConjI.get_value x vars) (EConjI.get_value y vars) in + collect_values x y econj_joined (vars-1) (EConjI.meet_with_one_value vars joined_value t false) in let join_d ((econ_x, _, ineq_x) as x) ((econ_y, _, ineq_y) as y) env = let econj' = join_econj (econ_x) (econ_y) env in @@ -908,7 +906,8 @@ struct None -> None | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); - let ineq' = Ineq.join ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in + (*TODO: I'm not sure if this is precise enough in all cases or if we would need to do something similar to collecting the values!*) + let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in Some (collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq')) in (*Normalize the two domains a and b such that both talk about the same variables*) @@ -927,7 +926,7 @@ struct | Some x, Some y -> {d = join_d x y a.env; env = a.env} - let join = join' (Value.join) + let join = join' false let join a b = timing_wrap "join" (join a) b let join a b = @@ -937,14 +936,14 @@ struct assert(leq b res); res - let widen = join' (Value.widen) + let widen = join' true let widen a b = let res = widen a b in if M.tracing then M.tracel "widen" "widen a: %s b: %s -> %s" (show a) (show b) (show res) ; res - let narrow a b = meet' a b Value.narrow + let narrow a b = meet' a b true let narrow a b = let res = narrow a b in diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index b4040d7823..6873e66cc7 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -297,11 +297,14 @@ module type TwoVarInequalities = sig (*meet x' < y' (or with = / <= *) val meet_condition : int -> int -> cond -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t - val meet : (int -> Rhs.t) -> (int -> Value.t) -> t -> t -> t + val meet : (int -> Value.t) -> t -> t -> t + val narrow : (int -> Value.t) -> t -> t -> t + val leq : t -> (int -> Value.t) -> t -> bool val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t + val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t (*copy all constraints for some variable to a different t if they still hold for a new x' with x' (cond) x *) val transfer : int -> int -> cond -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t @@ -331,10 +334,13 @@ module NoInequalties : TwoVarInequalities = struct let is_less_than _ _ _ = None let meet_condition _ _ _ _ _ _ = () - let meet _ _ _ _ = () + let meet _ _ _ = () + let narrow _ _ _ = () let leq _ _ _ = true let join _ _ _ _ = () + let widen _ _ _ _ = () + let show_formatted _ _ = "{}" let hash _ = 3 @@ -352,11 +358,15 @@ module type Coeffs = sig type t val implies : Value.t -> Value.t -> t option -> t -> bool val meet : Value.t -> Value.t -> t -> t -> t + val narrow : Value.t -> Value.t -> t -> t -> t + + val join : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option + val widen : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option + val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int val show_formatted : string -> string -> t -> string - end module CommonActions (Coeffs : Coeffs) = struct @@ -407,16 +417,34 @@ module CommonActions (Coeffs : Coeffs) = struct in IntMap.for_all (fun x ys -> IntMap.for_all (implies x) ys) t2 - let meet_one_coeff get_value x y coeff t = + let meet_one_coeff narrow get_value x y coeff t = let coeff_t = get_coeff x y t in let coeff_met = match coeff_t with | None -> coeff - | Some coeff_t -> Coeffs.meet (get_value x) (get_value y) coeff coeff_t + | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (get_value x) (get_value y) coeff coeff_t in set_coeff x y coeff_met t - (*TODO I do not see an obvious way that an inequalitiy between roots could contradict a rhs. Is there one?*) - let meet get_rhs get_value t1 t2 = - IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff get_value x) ys t) t2 t1 + let meet get_value t1 t2 = + IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff false get_value x) ys t) t2 t1 + + let narrow get_value t1 t2 = + IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff true get_value x) ys t) t2 t1 + + let join' widen t1 get_val_t1 t2 get_val_t2 = + let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 + in let merge_x x ys1 ys2 = + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + in match ys1, ys2 with + | Some ys1, None -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t2 x) (get_val_t2 y) None coeff ) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t1 x) (get_val_t1 y) None coeff ) ys2) + | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) + | _, _ -> None in + IntMap.merge (merge_x) t1 t2 + + let join = join' false + let widen = join' true end @@ -435,6 +463,18 @@ module NoCoeffs = struct | Some x, Some y when TopIntOps.compare x y > 0 -> raise EConj.Contradiction | _, _ -> () + let narrow = meet + + let join x y get_val_t1 get_val_t2 t1 t2 = + let of_bool b = if b then Some () else None in + match t1 with + | Some t1 -> of_bool (implies (get_val_t2 x) (get_val_t2 y) t2 t1) + | None -> match t2 with + | Some t2 -> of_bool (implies (get_val_t1 x) (get_val_t1 y) t1 t2) + | None -> None + + let widen = join + let show_formatted x y t = x ^ " < " ^ y end @@ -444,25 +484,6 @@ module SimpleInequalities : TwoVarInequalities = struct module Coeffs = NoCoeffs include CommonActions(Coeffs) - let join t1 get_val_t1 t2 get_val_t2 = - let merge_y x y c1 c2 = - let of_bool b = if b then Some () else None in - match c1 with - | Some c1 -> of_bool (Coeffs.implies (get_val_t2 x) (get_val_t2 y) c2 c1) - | None -> match c2 with - | Some c2 -> of_bool (Coeffs.implies (get_val_t1 x) (get_val_t1 y) c1 c2) - | None -> None - in let merge_x x ys1 ys2 = - let ignore_empty ls = - if IntMap.is_empty ls then None - else Some ls - in match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t2 x) (get_val_t2 y) None coeff ) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t1 x) (get_val_t1 y) None coeff ) ys2) - | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) - | _, _ -> None in - IntMap.merge (merge_x) t1 t2 - let is_less_than x y t = let check_inequality ((var_x,o_x,d_x), val_x) ((var_y,o_y,d_y), val_y) = if M.tracing then M.trace "is_less_than" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); @@ -607,4 +628,98 @@ module SimpleInequalities : TwoVarInequalities = struct if M.tracing then M.tracel "transfer" "transfering var_%d -> var_%d with cond: %s from %s into %s -> %s" x x_new (show_cond cond) (show t_old) (show t) (show res); res -end \ No newline at end of file +end + +(*List of inequalities ax < by + c, mapping a and b to c*) +(*We need to make sure that x has lower index than y to keep this representation unique! *) +module ArbitraryCoeffsSet = struct + module Key = struct + type t = Q.t * Q.t [@@deriving ord] + end + module CoeffMap = Map.Make(Key) + + type t = Q.t CoeffMap.t [@@deriving eq, ord] + + let hash t = CoeffMap.fold (fun (a,b) c acc -> let open Q in Q.to_int @@ a + b + b + c+c+ c) t 0 + + let show_single_inequality x y a b c = Printf.sprintf "%s %s < %s %s + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c) + + let show_formatted x y t = + CoeffMap.fold (fun (a,b) c acc -> Printf.sprintf "%s , %s" (show_single_inequality x y a b c ) acc) t "" + + (*TODO this function should limit how many inequalities we are saving. What information does this need? + likely: values, coefficients of Rhs relating to x and y*) + (* Throw away inequalities that are least useful: + implied by the current values? -> need to adapt implies to check all inequalities !!, otherwise join is not valid + least rhs with fitting coefficients *) + let limit = identity + + let meet_single_inequality narrow x_val y_val (a,b) c t = + (*Look for contradicting inequality*) + match CoeffMap.find_opt (Q.neg a, Q.neg b) t with + | Some c' when Q.geq (Q.neg c') c -> raise EConj.Contradiction + | _ -> match CoeffMap.find_opt (a,b) t with + | Some c_old -> if narrow then (*TODO*)undefined "narrow not implemented" else CoeffMap.add (a,b) (Q.min c c_old) t + | None -> CoeffMap.add (a,b) c t + + let meet' narrow x_val y_val t1 t2 = limit @@ CoeffMap.fold (meet_single_inequality narrow x_val y_val) t1 t2 + + (*TODO: We could check all inequalities if they imply this for the specific values, but it might be too inefficient! leq O(|t|^2) instead of O(|t|) ?*) + let implies_single_inequality x_val y_val t_opt (a,b) c = + let implied_by_value () = + let ax = Value.div (Value.mul x_val @@ Value.of_bigint @@ Q.num a) @@ Value.of_bigint @@ Q.den a in + let by = Value.div (Value.mul y_val @@ Value.of_bigint @@ Q.num b) @@ Value.of_bigint @@ Q.den b in + let c' = Value.maximal @@ Value.sub ax by in + match c' with + | Some (TopIntOps.Int c') -> Q.leq (Q.of_bigint c') c + | _ -> false + in match t_opt with + | Some t -> begin match CoeffMap.find_opt (a,b) t with + | Some c' -> Q.leq c' c + | None -> implied_by_value () + end + | None -> implied_by_value () + let implies x_val y_val t_opt t = CoeffMap.for_all (implies_single_inequality x_val y_val t_opt) t + + let join' widen x y get_val_t1 get_val_t2 t1 t2 = + let join_single_inequality (a,b) c1 c2 = + match c1, c2 with + | None, None -> None + | Some c1, Some c2 -> if widen && c2 > c1 then None else Some (Q.max c1 c2) (*TODO widening thresholds?*) + | Some c1, None -> if implies_single_inequality (get_val_t2 x) (get_val_t2 y) None (a,b) c1 then Some c1 else None + | None, Some c2 -> if implies_single_inequality (get_val_t1 x) (get_val_t1 y) None (a,b) c2 then Some c2 else None + in + let ignore_empty ls = + if CoeffMap.is_empty ls then None + else Some ls + in + match t1, t2 with + | None, None -> None + | Some t1, None -> ignore_empty @@ limit @@ CoeffMap.filter (implies_single_inequality (get_val_t2 x) (get_val_t2 y) None) t1 + | None, Some t2 -> ignore_empty @@ limit @@ CoeffMap.filter (implies_single_inequality (get_val_t1 x) (get_val_t1 y) None) t2 + | Some t1, Some t2 -> ignore_empty @@ limit @@ CoeffMap.merge join_single_inequality t1 t2 + + let join = join' false + let widen = join' true + let meet = meet' false + let narrow = meet' true +end + + +module LinearInequalities (*: TwoVarInequalities *)= struct + module Coeffs = ArbitraryCoeffsSet + include CommonActions(Coeffs) +(* + `is_less_than' + `meet_condition' + `transfer' + *) +end + +(*TODOs:*) +(*allow inequalities with offset for meet_condition, is_less_than, transfer*) +(*generate inequalities with offset*) +(*limit in ArbitraryCoeaffsList*) +(*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) +(*widening thresholds: from offsets of rhs?*) +(*domain inbetween these two: with offset between roots? -> should be trivial to implement*) \ No newline at end of file From 937c0fc6501c46e5285e7639c3ae26dd6bb1db3f Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 20 Mar 2025 14:33:35 +0100 Subject: [PATCH 33/86] fix accidentialy duplicated regression test --- .../82-lin2vareq_p/39-congruence_from_equation.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c index b2fbc2112d..7fb1be4816 100644 --- a/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c +++ b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c @@ -2,15 +2,9 @@ int main() { int x, y, z; - x = 3 * y + 1; // a - z = 5 * x + 7; // b - if (y < 14) - { - __goblint_check( x <= 42); - __goblint_check(y < 14); // A - __goblint_check(z != 500); // B - __goblint_check(z != 14); // Because of eqution for z - __goblint_check(z != 17); // Because of combination of equation for z and x + if (4 * x == 3 * y + 1) { + __goblint_check( y % 4 == 1); + __goblint_check( x % 3 == 1); } } \ No newline at end of file From 6e8ee16d5c6ac036b75d39c3973f1b2cdf9f8d43 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 25 Mar 2025 14:56:58 +0100 Subject: [PATCH 34/86] finish linear inequalities, generate inequalities with offset, allow meet_relation to refine values --- ...earTwoVarEqualityAnalysisPentagon.apron.ml | 2 +- ...inearTwoVarEqualityDomainPentagon.apron.ml | 240 +++++------ .../apron/pentagonSubDomains.apron.ml | 397 +++++++++++++----- 3 files changed, 416 insertions(+), 223 deletions(-) diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml index 399c7a5515..617d5cb4f9 100644 --- a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -6,7 +6,7 @@ open Analyses include RelationAnalysis module NoIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.NoInequalties) -module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.SimpleInequalities) +module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.LinearInequalities) let spec_module: (module MCPSpec) Lazy.t = lazy ( diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 0ef3ccff13..52d641a71d 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -65,7 +65,7 @@ struct (*Does not check the values directly, only the inequality domain, so we can use this to detect contradictions *) - let is_less_than ((_,vs,ineq) as t) x y = + let get_relations ((_,vs,ineq) as t) x y = let get_information lhs = let rhs = get_rhs t lhs in match rhs with @@ -73,7 +73,7 @@ struct (*We need to know which root a constant is referring to, so we use this the trivial equation to carry that information*) | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) in - Ineq.is_less_than (get_information x) (get_information y) ineq + Ineq.get_relations (get_information x) (get_information y) ineq let get_value t lhs = @@ -166,6 +166,7 @@ struct let forget_variable ((econj, _, _) as d) var = let rhs_var = get_rhs d var in let value_var = get_value d var in + (*Forgetting EConj, but also return new representative if it changed*) let (econj', vs', ineq'), newRoot = (let ref_var_opt = Tuple3.first rhs_var in match ref_var_opt with @@ -192,29 +193,31 @@ struct | [] -> d, None) (* empty cluster means no work for us *) | _ -> d, None) (* variable is either a constant or expressed by another refvar *) in (*Forget old information*) - let econj'' = (fst econj', IntMap.remove var (snd econj')) in (* set d(var) to unknown, finally *) + let econj'' = (fst econj', IntMap.remove var (snd econj')) in let vs'' = IntMap.remove var vs' in let ineq'' = Ineq.forget_variable ineq' var in let d' = (econj'', vs'', ineq'') in - (*Try restoring information for new head*) - let d'' = - match newRoot with - | None -> d' - | Some newRoot -> - let cond = - match get_rhs d newRoot with - | (Some (c,_), o, d) when Z.equal c Z.one && Z.equal o Z.zero && Z.equal d Z.one -> Some Ineq.Eq - | rhs_new -> match Ineq.is_less_than (rhs_new, get_value d newRoot) (rhs_var, value_var) ineq'' with (*relation of new root to root before this call*) - | None -> None - | Some true -> Some Lt - | Some false -> Some Gt - in let after_ineq = match cond with - | None -> d' - | Some cond -> econj'', vs'', Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq'' (get_rhs d') (get_value d') - in set_value after_ineq newRoot @@ get_value d newRoot - in - if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show d) (show d''); - d'' + (*Try restoring information for new head if root changed*) + match newRoot with + | None -> d' + | Some newRoot -> + (*restoring inequalities*) + let relations = + match get_rhs d newRoot with + | (Some (c,_), o, d) when Z.equal c Z.one && Z.equal d Z.one -> [Relation.Eq, o] + | rhs_new -> Ineq.get_relations (rhs_new, get_value d newRoot) (rhs_var, value_var) ineq'' (*relation of new root to root before this call*) + in let after_ineq = + let transfer_single_relation ineq_acc cond = + Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq_acc (get_rhs d') (get_value d') + in econj'', vs'', List.fold transfer_single_relation ineq'' relations + (*restoring values*) + in set_value after_ineq newRoot @@ get_value d newRoot + + let forget_variable d var = + let res = forget_variable d var in + if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show d) (show res); + res + let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then @@ -432,10 +435,12 @@ struct | None -> Value.top | Some d -> let v = Value.sub (EConjI.get_value d dim_a) (EConjI.get_value d dim_b) in - match EConjI.is_less_than d dim_a dim_b with - | None -> v - | Some true -> Value.meet v (Value.ending Z.minus_one) - | Some false -> Value.meet v (Value.starting Z.one) + let relations = EConjI.get_relations d dim_a dim_b in + let meet_relation v = function + | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.sub o Z.one + | Relation.Eq, o -> Value.of_bigint o + | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.add o Z.one + in List.fold meet_relation v relations end | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) | Unop (op, a, Int, _) -> (unop_function op) (eval a) @@ -451,30 +456,24 @@ struct let open Apron.Texpr1 in let inequality_from_add var expr = let v = eval_texpr t expr in (*TODO we evaluate some subexpressions twice when calling this in assign_texpr -> bad for performance??*) - if Value.must_be_pos v then - [(Ineq.Gt, var)] - else if Value.must_be_neg v then - [(Ineq.Lt, var)] - else if Value.leq v (Value.of_bigint Z.zero) then - [(Ineq.Eq, var)] - else if Value.leq v (Value.starting Z.zero) then - [(Ineq.Ge, var)] - else if Value.leq v (Value.ending Z.zero) then - [(Ineq.Le, var)] - else - [] + match Value.minimal v, Value.maximal v with + | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, min), var] + | Some (Int min), Some (Int maxi) -> [(Relation.Gt, min), var; (Relation.Lt, maxi), var] + | Some (Int min), _ -> [(Relation.Gt, min), var] + | _,Some (Int maxi) -> [(Relation.Lt, maxi), var] + | _,_ -> [] in let inequality_from_mul var expr = let v_expr = eval_texpr t expr in let v_var = eval_texpr t (Var var) in if Value.leq v_expr (Value.of_bigint Z.one) || Value.leq v_var (Value.of_bigint Z.zero) - then [(Ineq.Eq, var)] + then [((Relation.Eq, Z.zero), var)] else match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with - | true, _ , true, _ -> if Value.contains v_expr Z.one then [Ineq.Ge, var] else [Ineq.Gt, var] - | _, true, _ , true -> [Ineq.Gt, var] - | true, _ , _ , true -> if Value.contains v_expr Z.one then [Ineq.Le, var] else [Ineq.Lt, var] - | _ , true, true, _ -> [Ineq.Lt, var] + | true, _ , true, _ -> if Value.contains v_expr Z.one then [(Relation.Gt, Z.minus_one), var] else [(Relation.Gt, Z.zero), var] + | _, true, _ , true -> [(Relation.Gt, Z.zero), var] + | true, _ , _ , true -> if Value.contains v_expr Z.one then [(Relation.Lt, Z.one), var] else [(Relation.Lt, Z.zero), var] + | _ , true, true, _ -> [(Relation.Lt, Z.zero), var] | _ , _ , _ , _ -> [] in match texpr with | Binop (Add, Var x, Var y, _, _) -> inequality_from_add x (Var y) @ inequality_from_add y (Var x) @@ -484,73 +483,53 @@ struct | Binop (Mul, e, Var y, _, _) | Binop (Mul, Var y, e, _, _) -> inequality_from_mul y e | Binop (Sub, Var y, e, _, _) -> - let v = eval_texpr t e in - if Value.must_be_pos v then - [(Ineq.Lt, y)] - else if Value.must_be_neg v then - [(Ineq.Gt, y)] - else if Value.leq v (Value.of_bigint Z.zero) then - [(Ineq.Eq, y)] - else if Value.leq v (Value.starting Z.zero) then - [(Ineq.Le, y)] - else if Value.leq v (Value.ending Z.zero) then - [(Ineq.Ge, y)] - else - [] + let v = eval_texpr t e in begin + match Value.minimal v, Value.maximal v with + | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, Z.neg min), y] + | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.neg min), y; (Relation.Gt, Z.neg maxi), y] + | Some (Int min), _ -> [(Relation.Lt, Z.neg min), y] + | _,Some (Int maxi) -> [(Relation.Gt, Z.neg maxi), y] + | _,_ -> [] + end | Binop (Div, Var y, e, _, _) -> begin let v_expr = eval_texpr t e in let v_var = eval_texpr t (Var y) in if Value.leq v_expr (Value.of_bigint Z.one) || Value.leq v_var (Value.of_bigint Z.zero) - then [(Ineq.Eq, y)] + then [((Relation.Eq, Z.zero), y)] else match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with - | true, _ , true, _ -> if Value.contains v_expr Z.one then [Ineq.Le, y] else [Ineq.Lt, y] - | _, true, _ , true -> [Ineq.Gt, y] - | true, _ , _ , true -> if Value.contains v_expr Z.one then [Ineq.Ge, y] else [Ineq.Gt, y] - | _ , true, true, _ -> [Ineq.Lt, y] + | true, _ , true, _ -> if Value.contains v_expr Z.one then [(Relation.Lt, Z.one), y] else [(Relation.Lt, Z.zero), y] + | _, true, _ , true -> [(Relation.Gt, Z.zero), y] + | true, _ , _ , true -> if Value.contains v_expr Z.one then [(Relation.Gt, Z.minus_one), y] else [(Relation.Gt, Z.zero), y] + | _ , true, true, _ -> [(Relation.Lt, Z.zero), y] | _ , _ , _ , _ -> [] end | Binop (Mod, e, Var y, _, _) -> let v_var = eval_texpr t (Var y) in if Value.must_be_pos v_var then - [Ineq.Lt, y] + [(Relation.Lt, Z.zero), y] else if Value.must_be_neg v_var then - [Ineq.Gt, y] + [(Relation.Gt, Z.zero), y] else [] | Unop (Neg, e, _, _) -> - let v = eval_texpr t e in - let negate (cond, var) = - if Value.must_be_pos v then - match cond with - | Ineq.Lt | Ineq.Le | Ineq.Eq -> Some (Ineq.Lt, var) - | _ -> None - else if Value.must_be_neg v then - match cond with - | Ineq.Gt | Ineq.Ge | Ineq.Eq -> Some (Ineq.Gt, var) - | _ -> None - else if Value.leq v (Value.of_bigint Z.zero) then - Some (cond, var) - else if Value.leq v (Value.starting Z.zero) then - match cond with - | Ineq.Lt -> Some (Ineq.Lt, var) - | Ineq.Le | Ineq.Eq -> Some (Ineq.Le, var) - | _ -> None - else if Value.leq v (Value.ending Z.zero) then - match cond with - | Ineq.Gt -> Some (Ineq.Gt, var) - | Ineq.Ge | Ineq.Eq -> Some (Ineq.Ge, var) - | _ -> None - else - None - in List.filter_map negate (to_inequalities t e) + let v = eval_texpr t e in begin + match Value.minimal v, Value.maximal v with + | Some (Int min), _ when Z.geq min Z.zero -> + let neg_cond = (Relation.Lt, Z.sub Z.one @@ Z.add min min ) in (*relation of -x to x*) + List.filter_map (fun (old_cond,var) -> BatOption.map (fun x -> x,var) @@ Relation.combine neg_cond old_cond) (to_inequalities t e) + | _, Some (Int maxi) when Z.leq maxi Z.zero -> + let neg_cond = (Relation.Gt, Z.sub Z.minus_one @@ Z.add maxi maxi ) in (*relation of -x to x*) + List.filter_map (fun (old_cond,var) -> BatOption.map (fun x -> x,var) @@ Relation.combine neg_cond old_cond) (to_inequalities t e) + | _,_ -> [] + end | Unop (Cast, e, _, _) -> to_inequalities t e - | Var x -> [(Ineq.Eq, x)] + | Var x -> [((Relation.Eq, Z.zero), x)] | _ -> [] let to_inequalities (t:t) texpr = let res = to_inequalities t texpr in - let show_ineq (cond, var) = Ineq.show_cond cond ^ " " ^ Var.show var ^ ", " + let show_ineq (cond, var) = Relation.show "expr" cond (Var.show var) ^ ", " in if M.tracing then M.tracel "inequalities" "expr: %a ineq: %s" Texpr1.Expr.pretty texpr (List.fold (^) "" @@ List.map show_ineq res); res @@ -665,11 +644,15 @@ struct let refine_var d var value = let dim = Environment.dim_of_var t.env var in if is_inequality then begin - match Value.to_int value, Value.to_int (EConjI.get_value d dim) with - | Some v, Some i when TopIntOps.equal v i -> - if M.tracing then M.trace "refine_tcons" "inequality %s <> %s must be wrong" (Var.to_string var) (Value.show value); - raise EConj.Contradiction - | _ -> d (*TODO if value is a constant, we sometimes could do some refinement*) + (*If the value is at the bounds of the interval of var, we can make it smaller*) + match Value.to_int value with + | Some (Int v) -> let old_value = (EConjI.get_value d dim) in + if Value.minimal old_value = Some (Int v) then + EConjI.meet_with_one_value dim (Value.starting @@ Z.add v Z.one) d false + else if Value.maximal old_value = Some (Int v) then + EConjI.meet_with_one_value dim (Value.ending @@ Z.sub v Z.one) d false + else d + | _-> d end else ( if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; EConjI.meet_with_one_value dim value d false ) @@ -692,7 +675,7 @@ struct | Sub -> refine_both (Value.add) (Fun.flip Value.sub) (*Because the overflow handeling in SharedFunctions guarantees us no wrapping behaviour, this is always invertible *) | Mul -> refine_both (Value.div) (Value.div) - (*DIV and MOD are largely inspired by BaseInvariant*) + (*DIV and MOD are largely adapted from BaseInvariant*) | Div -> (* Integer division means we need to add the remainder, so instead of just `a = c*b` we have `a = c*b + a%b`. * However, a%b will give [-b+1, b-1] for a=top, but we only want the positive/negative side depending on the sign of c*b. @@ -771,20 +754,37 @@ struct in let refine_inequalities ((econ, vs, ineq) as d) expr = let rhss = EConjI.get_rhs d in let vss = EConjI.get_value d in - match expr with - (*TODO we could use to_inequalities for more flexible handeling?*) - | Binop (Sub, Var a, Var b, Int, _) -> - begin - let dim_a = Environment.dim_of_var t.env a in - let dim_b = Environment.dim_of_var t.env b in - if M.tracing then M.tracel "meet_condition" "calling from refine inside %s" (EConjI.show d) ; - let ineq' = match Tcons1.get_typ tcons with - | EQ -> Ineq.meet_condition dim_a dim_b Ineq.Eq rhss vss ineq - | SUP -> Ineq.meet_condition dim_b dim_a Ineq.Lt rhss vss ineq - | SUPEQ -> Ineq.meet_condition dim_b dim_a Ineq.Le rhss vss ineq - | _ -> ineq - in (econ, vs, ineq') - end + (*a - b + interval (in arbitrary order)*) + let meet_relation a b value = + let dim_a = Environment.dim_of_var t.env a in + let dim_b = Environment.dim_of_var t.env b in + if M.tracing then M.tracel "meet_relation" "calling from refine with %s inside %s" (Tcons1.show tcons) (EConjI.show d); + let ineq', value_refinements = match Value.minimal value, Value.maximal value, Tcons1.get_typ tcons with + | Some (Int min), _, SUP -> Ineq.meet_relation dim_b dim_a (Relation.Lt, min) rhss vss ineq + | Some (Int min), _, SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one min) rhss vss ineq + | Some min, Some max, EQ -> begin + let ineq, refine = match min with + | Int min -> Ineq.meet_relation dim_b dim_a (Relation.Gt, Z.sub min Z.one) rhss vss ineq + | _ -> ineq, [] + in match max with + | Int max -> BatTuple.Tuple2.map2 ((@) refine) @@ Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq + | _ -> ineq, refine + end + | _, _,_ -> ineq, [] + in let d' = (econ, vs, ineq') + in List.fold (fun d (var,value) -> EConjI.meet_with_one_value var value d false) d' value_refinements + in match expr with (*TODO we could do this in a more general way -> normalisation??*) + (*currently only hits if two variables are at the first two levels. Also, we only choose one pattern even if multiple are possible + e.g. x + y - z arbitrarily selects x or y to convert into an interval, instead we could meet for both*) + | Binop (Add, Var a, (Binop (Sub, exp, Var b,_,_)),_,_) + | Binop (Add, exp, (Binop (Sub, Var a, Var b,_,_)),_,_) + | Binop (Add, (Binop (Sub, exp, Var b,_,_)), Var a, _,_) + | Binop (Add, (Binop (Sub, Var a, Var b,_,_)), exp, _,_) + | Binop (Sub, exp, (Binop (Sub, Var b, Var a,_,_)),_,_) -> meet_relation a b (eval_texpr {d=Some d;env=t.env} exp) + | Binop (Sub, Var a, Var b, _, _) -> meet_relation a b (Value.of_bigint Z.zero) + | Binop (Sub, (Binop (Sub, Var a, Var b,_,_)), exp, _,_) + | Binop (Sub, Var a, (Binop (Add, Var b, exp,_,_)),_,_) + | Binop (Sub, Var a, (Binop (Add, exp, Var b,_,_)),_,_) -> meet_relation a b (Value.neg @@ eval_texpr {d=Some d;env=t.env} exp) | _ -> d in try let expr = to_expr @@ Tcons1.get_texpr1 tcons in @@ -987,6 +987,7 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) + (*TODO in this case, the transfer of information could be more precise for the exact inequalities! But currently COndition.t can not transfer that information*) let econji' = econj, IntMap.remove var_i vs, Ineq.forget_variable ineq_old var_i in {d=Some (EConjI.affine_transform econji' var_i (coeff_var, var_i, off, divi)); env=t.env } | Some (Some monomial, off, divi) -> @@ -995,19 +996,20 @@ struct in begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env - | Some ((econ, vs, ineq) as d') -> - if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some (econ, vs, ineq); env = t.env}); - let meet_cond ineq (cond, var) = + | Some d' -> + if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some d'; env = t.env}); + let meet_cond (e,v,ineq) (cond, var) = let dim = Environment.dim_of_var t.env var in if dim <> var_i then - Ineq.meet_condition var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq + let ineq', refinements = Ineq.meet_relation var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq + in List.fold (fun d (var,value) -> EConjI.meet_with_one_value var value d false) (e,v,ineq') refinements else - (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen?*) - Ineq.transfer dim dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') + (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen without being handled above?*) + e,v,Ineq.transfer dim dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') in - let ineq' = List.fold meet_cond ineq (VarManagement.to_inequalities t texp) in - if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some (econ, vs, ineq'); env = t.env}); - {d = Some (econ, vs, ineq'); env = t'.env} + let d'' = List.fold meet_cond d' (VarManagement.to_inequalities t texp) in + if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some d''; env = t.env}); + {d = Some d''; env = t'.env} end | None -> bot_env diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 6873e66cc7..fc5026c003 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -286,28 +286,56 @@ end module Value = IntervalAndCongruence +module Relation = struct + type cond = Lt | Eq | Gt + type t = cond * Z.t + + let show_cond c = match c with + | Lt -> "<" + | Eq -> "=" + | Gt -> ">" + + let show x (c,o) y = x ^ show_cond c ^ y ^ " + " ^ Z.to_string o + + let invert (cond, o) = + let o' = Z.neg o in + match cond with + | Lt -> Gt, o' + | Gt -> Lt, o' + | Eq -> Eq, o' + + (*Tries to combine two relations, with the variable on the rhs of the first condition being equal to the one at the lhs of the second*) + let combine (c1, o1) (c2, o2) = match c1, c2 with + | Lt, Lt -> Some ( Lt, Z.add o1 @@ Z.add o2 Z.one ) + | Lt, Eq + | Eq, Lt -> Some ( Lt, Z.add o1 o2 ) + | Eq, Eq -> Some ( Eq, Z.add o1 o2 ) + | Gt, Gt -> Some ( Gt, Z.add o1 @@ Z.add o2 Z.one ) + | Gt, Eq + | Eq, Gt -> Some ( Gt, Z.add o1 o2 ) + | Lt, Gt + | Gt, Lt -> None +end + + module type TwoVarInequalities = sig type t - type cond = Lt | Le | Eq | Gt | Ge - val show_cond : cond -> string + val get_relations : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> Relation.t list - val is_less_than : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> bool option - - (*meet x' < y' (or with = / <= *) - val meet_condition : int -> int -> cond -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t + (*meet x' < y' + c (or with = / > *) + val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * (int * Value.t) list val meet : (int -> Value.t) -> t -> t -> t val narrow : (int -> Value.t) -> t -> t -> t - val leq : t -> (int -> Value.t) -> t -> bool val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t (*copy all constraints for some variable to a different t if they still hold for a new x' with x' (cond) x *) - val transfer : int -> int -> cond -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t + val transfer : int -> int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t val show_formatted : (int -> string) -> t -> string val hash : t -> int @@ -322,17 +350,9 @@ end module NoInequalties : TwoVarInequalities = struct type t = unit - type cond = Lt | Le | Eq | Gt | Ge - - let show_cond c = match c with - | Le -> "<=" - | Lt -> "<" - | Eq -> "=" - | Gt -> ">" - | Ge -> ">=" - let is_less_than _ _ _ = None - let meet_condition _ _ _ _ _ _ = () + let get_relations _ _ _ = [] + let meet_relation _ _ _ _ _ _ = (), [] let meet _ _ _ = () let narrow _ _ _ = () @@ -357,7 +377,7 @@ end module type Coeffs = sig type t val implies : Value.t -> Value.t -> t option -> t -> bool - val meet : Value.t -> Value.t -> t -> t -> t + val meet : Value.t -> Value.t -> t -> t -> t val narrow : Value.t -> Value.t -> t -> t -> t val join : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option @@ -370,17 +390,9 @@ module type Coeffs = sig end module CommonActions (Coeffs : Coeffs) = struct - type cond = Lt | Le | Eq | Gt | Ge type t = Coeffs.t IntMap.t IntMap.t [@@deriving eq, ord ] - let show_cond c = match c with - | Le -> "<=" - | Lt -> "<" - | Eq -> "=" - | Gt -> ">" - | Ge -> ">=" - let empty = IntMap.empty let is_empty = IntMap.is_empty let hash t = IntMap.fold (fun _ ys acc -> IntMap.fold (fun _ coeff acc -> Coeffs.hash coeff + 3*acc) ys (5*acc)) t 0 @@ -458,10 +470,7 @@ module NoCoeffs = struct | Some x, Some y -> TopIntOps.compare x y < 0 | _, _ -> false - let meet x y _ _ = - match Value.minimal x, Value.maximal y with - | Some x, Some y when TopIntOps.compare x y > 0 -> raise EConj.Contradiction - | _, _ -> () + let meet x y _ _ = () let narrow = meet @@ -477,6 +486,14 @@ module NoCoeffs = struct let show_formatted x y t = x ^ " < " ^ y + let add_constraints x y x_val y_val acc = + let acc = match Value.maximal y_val with + | Some (Int v) -> (x, Value.ending @@ Z.sub v Z.one) :: acc + | _ -> acc + in match Value.minimal x_val with + | Some (Int v) -> (y, Value.starting @@ Z.add v Z.one) :: acc + | _ -> acc + end (*Semantics: x -> y -> () => x < y*) @@ -484,65 +501,65 @@ module SimpleInequalities : TwoVarInequalities = struct module Coeffs = NoCoeffs include CommonActions(Coeffs) - let is_less_than x y t = + let get_relations x y t = + let open Relation in let check_inequality ((var_x,o_x,d_x), val_x) ((var_y,o_y,d_y), val_y) = - if M.tracing then M.trace "is_less_than" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); + if M.tracing then M.trace "get_relations" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); match var_x, var_y with | Some (c_x, x), Some (c_y, y) -> begin match get_coeff x y t with | None -> - if M.tracing then M.trace "is_less_than" "no inequality for roots"; - None (*No information*) + if M.tracing then M.trace "get_relations" "no inequality for roots"; + [] (*No information*) | Some _ -> (*we know x < y -> check if this translates to x' < y' or x' > y'*) let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in let d_o = Z.sub (Z.mul o_x d_y) (Z.mul o_y d_x) in let x_d_c = Value.mul val_x (Value.of_bigint d_c) in if Z.lt c_y Z.zero && Value.leq x_d_c (Value.ending d_o) (* c_y < 0, x * d_c <= d_o*) - then Some false (*x' > y '*) + then[ (Gt, Z.zero)] (*x' > y '*) else if Z.gt c_y Z.zero && Value.leq x_d_c (Value.starting d_o) (* c_y > 0, x * d_c >= d_o*) - then Some true (*x' < y '*) + then [(Lt, Z.zero)] (*x' < y '*) else let d_c' = Z.neg d_c in let d_o' = Z.neg d_o in let y_d_c = Value.mul val_y (Value.of_bigint d_c') in if Z.lt c_x Z.zero && Value.leq y_d_c (Value.starting d_o') (* c_x < 0, y * d_c >= d_o*) - then Some false (*x' > y '*) + then [(Gt, Z.zero) ](*x' > y '*) else if Z.gt c_x Z.zero && Value.leq y_d_c (Value.ending d_o') (* c_x > 0, y * d_c <= d_o*) - then Some true (*x' < y '*) - else None + then [Lt, Z.zero] (*x' < y '*) + else [] end - | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) + | _, _ -> failwith "Inequalities.get_relations does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) in let res = check_inequality x y in - if res = None then BatOption.map not @@ check_inequality y x + if res = [] then List.map invert @@ check_inequality y x else res - let is_less_than x y t = - let res = is_less_than x y t in - if M.tracing then M.trace "is_less_than" "result: %s" (BatOption.map_default (Bool.to_string) "unknown" res); + let get_relations x y t = + let res = get_relations x y t in + if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); res - (**) - let meet_condition x' y' cond get_rhs get_value t = - (*TODO should we check values for contradictions?*) + let meet_relation x' y' cond get_rhs get_value t = + let open Relation in (*strict: if the inequality is strict *) let meet_less_root x y strict t = - if M.tracing then M.tracel "meet_condition" "meet_less_root x: %d y: %d strict: %b " x y strict; + if M.tracing then M.tracel "meet_relation" "meet_less_root x: %d y: %d strict: %b " x y strict; let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in let union' = if strict then IntMap.add y () union else union in if IntMap.mem x union' then raise EConj.Contradiction - else if IntMap.is_empty union' then t - else IntMap.add x union' t + else if IntMap.is_empty union' then t, [] + else IntMap.add x union' t, IntMap.fold (fun z _ acc -> Coeffs.add_constraints x z (get_value x) (get_value z) acc) union' [] in let meet_less x' y' strict t = - if M.tracing then M.tracel "meet_condition" "meet_less x': %d y': %d strict: %b" x' y' strict; + if M.tracing then M.tracel "meet_relation" "meet_less x': %d y': %d strict: %b" x' y' strict; let get_rhs' lhs = match get_rhs lhs with | (Some (c,v),o,d) -> c,v,o,d | (None, o, d) -> Z.one, lhs, Z.zero, Z.one in let (c_x, x, o_x, d_x) = get_rhs' x' in let (c_y, y, o_y, d_y) = get_rhs' y' - in if M.tracing then M.tracel "meet_condition" "x' = %s, y' = %s " (Rhs.show (Some (c_x, x),o_x,d_x)) (Rhs.show (Some (c_y,y),o_y,d_y)); + in if M.tracing then M.tracel "meet_relation" "x' = %s, y' = %s " (Rhs.show (Some (c_x, x),o_x,d_x)) (Rhs.show (Some (c_y,y),o_y,d_y)); let val_x = get_value x in let val_y = get_value y in let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in @@ -560,17 +577,17 @@ module SimpleInequalities : TwoVarInequalities = struct (*We are strict iff we have been strict before or this bound is strict*) if Z.gt c_y Z.zero then meet_less_root x y (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t else meet_less_root y x (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t - else t + else t, [] in match cond with - | Gt -> meet_less y' x' true t - | Ge -> meet_less y' x' false t - | Eq -> + | Gt, z when Z.geq z Z.zero -> meet_less y' x' true t + | Gt, z when Z.equal z Z.minus_one -> meet_less y' x' false t + | Eq, z when Z.equal z Z.zero -> let rhs_x = get_rhs x' in let rhs_y = get_rhs y' in - if M.tracing then M.tracel "meet_condition" "in equality: x' (var_%d) = %s, y' (var_%d)= %s " x' (Rhs.show rhs_x) y' (Rhs.show rhs_y); + if M.tracing then M.tracel "meet_relation" "in equality: x' (var_%d) = %s, y' (var_%d)= %s " x' (Rhs.show rhs_x) y' (Rhs.show rhs_y); if Rhs.equal rhs_x rhs_y then begin - if M.tracing then M.tracel "meet_condition" "equality with same rhs"; + if M.tracing then M.tracel "meet_relation" "equality with same rhs"; let x,y = match rhs_x, rhs_y with | (Some (_,x), _,_), (Some (_,y), _,_) -> (x,y) | (None,_,_), (None, _,_) -> x',y' @@ -578,30 +595,34 @@ module SimpleInequalities : TwoVarInequalities = struct in let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in if IntMap.mem x union || IntMap.mem y union then raise EConj.Contradiction - else if IntMap.is_empty union then t - else IntMap.add x union @@ IntMap.add y union t - end else - meet_less x' y' false @@ meet_less y' x' false t (*TODO skip repeat calculations?*) - | Le -> meet_less x' y' false t - | Lt -> meet_less x' y' true t - - let meet_condition x y c r v t = - if M.tracing then M.tracel "meet_condition" "meeting %s with x': %d y': %d cond %s" (show t) x y (show_cond c); - let res = meet_condition x y c r v t in - if M.tracing then M.tracel "meet_condition" "result: %s " (show res); - res + else if IntMap.is_empty union then t, [] + else IntMap.add x union @@ IntMap.add y union t, [] (*TODO more is possible for refinement, but is it worth it?*) + end else + let (t', acc) = meet_less y' x' false t in + let (t'', acc2) = meet_less x' y' false t' in + t'', acc @ acc2 + | Eq, z when Z.gt z Z.zero -> meet_less y' x' true t + | Eq, z when Z.lt z Z.zero -> meet_less x' y' true t + | Lt, z when Z.equal z Z.one -> meet_less x' y' false t + | Lt, z when Z.leq z Z.zero-> meet_less x' y' true t + | _ -> t, [] (*TODO adapt the equations to take care of offsets!*) + + let meet_relation x y c r v t = + if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); + let res, refinements = meet_relation x y c r v t in + if M.tracing then M.tracel "meet_relation" "result: %s " (show res); + res, refinements - (*TODO I think this will be the same (or at least almost) for all the domain, but depends on is_less_than / meet_condition -> make it general?*) let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - let was_less_than x y = + let get_old_condition x y = let get_information lhs = let rhs = get_rhs_old lhs in match rhs with | (Some (_,var), _ ,_) -> (rhs, get_value_old var) - (*We need to know which root a constant is referring to, so we use this the trivial equation to carry that information*) + (*We need to know which root a constant is referring to, so we use the trivial equation to carry that information*) | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) in - is_less_than (get_information x) (get_information y) t_old + get_relations (get_information x) (get_information y) t_old in let vars_to_check = let root = match get_rhs_old x with | (Some (_,var), _ ,_) -> var @@ -609,23 +630,31 @@ module SimpleInequalities : TwoVarInequalities = struct (*we need to check all y with root -> y -> coeff or y -> root -> coeff*) in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) in let keep_less = match cond with - | Eq | Lt | Le -> true + | Relation.Eq | Lt -> true | _ -> false in let keep_greater = match cond with - | Eq | Gt | Ge -> true + | Eq | Gt -> true | _ -> false in let transfer_single_var t' y = - match was_less_than x y with - | Some true -> - if keep_less then meet_condition x_new y Lt get_rhs get_value t' else t' - | Some false -> - if keep_greater then meet_condition x_new y Gt get_rhs get_value t' else t' + match get_old_condition x y with + |[ (Lt, o)] -> (*transfering the variables does not lead to new information -> drop the refinements*) + if keep_less then fst @@ meet_relation x_new y (Lt, o) get_rhs get_value t' else t' + | [(Gt, o)] -> + if keep_greater then fst @@ meet_relation x_new y (Gt, o) get_rhs get_value t' else t' | _ -> t' in BatEnum.fold (transfer_single_var) t vars_to_check + (*TODO we currently just strip the offset, but could take advantage of the offset*) + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + match cond with + | Relation.Eq, o when Z.equal o Z.zero -> transfer x x_new Eq t_old get_rhs_old get_value_old t get_rhs get_value + | Relation.Lt, o when Z.leq o Z.zero -> transfer x x_new Lt t_old get_rhs_old get_value_old t get_rhs get_value + | Relation.Gt, o when Z.geq o Z.zero -> transfer x x_new Gt t_old get_rhs_old get_value_old t get_rhs get_value + | _ -> t + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in - if M.tracing then M.tracel "transfer" "transfering var_%d -> var_%d with cond: %s from %s into %s -> %s" x x_new (show_cond cond) (show t_old) (show t) (show res); + if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s -> %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t) (show res); res end @@ -647,6 +676,8 @@ module ArbitraryCoeffsSet = struct let show_formatted x y t = CoeffMap.fold (fun (a,b) c acc -> Printf.sprintf "%s , %s" (show_single_inequality x y a b c ) acc) t "" + let empty = CoeffMap.empty + (*TODO this function should limit how many inequalities we are saving. What information does this need? likely: values, coefficients of Rhs relating to x and y*) (* Throw away inequalities that are least useful: @@ -654,17 +685,64 @@ module ArbitraryCoeffsSet = struct least rhs with fitting coefficients *) let limit = identity - let meet_single_inequality narrow x_val y_val (a,b) c t = - (*Look for contradicting inequality*) - match CoeffMap.find_opt (Q.neg a, Q.neg b) t with - | Some c' when Q.geq (Q.neg c') c -> raise EConj.Contradiction - | _ -> match CoeffMap.find_opt (a,b) t with - | Some c_old -> if narrow then (*TODO*)undefined "narrow not implemented" else CoeffMap.add (a,b) (Q.min c c_old) t - | None -> CoeffMap.add (a,b) c t - - let meet' narrow x_val y_val t1 t2 = limit @@ CoeffMap.fold (meet_single_inequality narrow x_val y_val) t1 t2 - - (*TODO: We could check all inequalities if they imply this for the specific values, but it might be too inefficient! leq O(|t|^2) instead of O(|t|) ?*) + let meet_single_inequality refine_data narrow x_val y_val (a,b) c t = + (*calculate value refine. If one of the coefficients is zero, we should not add it to the map*) + let refinements, skip_adding = match refine_data with + | None -> [], (Q.equal a Q.zero) || Q.equal b Q.zero + | Some (x,y) -> + let round_up q = Z.cdiv (Q.num q) (Q.den q) in + let round_down q = Z.fdiv (Q.num q) (Q.den q) in + let x_refine a_sign = + let ba = Q.div b a in + if a_sign = 1 then (*x < b/a y + c/a*) + let max_y = match Value.maximal (Value.mul y_val(Value.of_bigint (round_down ba))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up ba)) with + | Some a, Some b -> TopIntOps.max a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match max_y with + | Int max -> [x, Value.ending @@ Z.add Z.minus_one @@ Z.add max @@ round_up @@ Q.div c a] + | _ -> [] + else (*x > b/a y + c/a*) + let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down ba))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up ba)) with + | Some a, Some b -> TopIntOps.min a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match min_y with + | Int min -> [x, Value.starting @@ Z.add Z.one @@ Z.add min @@ round_down @@ Q.div c a] + | _ -> [] + in let y_refine b_sign = + let ba = Q.div a b in + if b_sign = 1 then (*a/b x - c/b < y*) + let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down ba))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up ba)) with + | Some a, Some b -> TopIntOps.min a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match min_x with + | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up @@ Q.div c a] + | _ -> [] + else (*a/b x - c/b > y*) + let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down ba))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up ba)) with + | Some a, Some b -> TopIntOps.max a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match max_x with + | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down @@ Q.div c a] + | _ -> [] + in match Q.compare a Q.zero, Q.compare b Q.zero with + | 0, 0 -> (*0 < c*) if Q.gt c Q.zero then [], true else raise EConj.Contradiction + | 0, -1 -> (* -c / b > y*) [y, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.neg @@ Q.div c b] , true + | 0, 1 -> (* -c / b < y*) [y, Value.starting @@ Z.add Z.one @@ round_down @@ Q.neg @@ Q.div c b] , true + | 1, 0 -> (*x < c / a*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.div c a ], true + | -1,0 -> (*x > c / a*) [x, Value.starting @@ Z.add Z.one @@ round_down @@ Q.div c a ], true + | a_sign, b_sign -> x_refine a_sign @ y_refine b_sign, false + in if skip_adding then t, refinements + else match CoeffMap.find_opt (Q.neg a, Q.neg b) t with (*Look for contradicting inequality*) + | Some c' when Q.geq (Q.add Q.one @@ Q.neg c') c -> raise EConj.Contradiction + (*TODO if c = - c' + 2 , then we have an equality -> maybe we can update the econj domain *) + | _ -> match CoeffMap.find_opt (a,b) t with + | Some c_old -> (*TODO if narrow then undefined "narrow not implemented" else *)CoeffMap.add (a,b) (Q.min c c_old) t, refinements + | None -> CoeffMap.add (a,b) c t , refinements + + (*when meeting, the values should already ben refined before -> ignore the refinement data*) + let meet' narrow x_val y_val t1 t2 = CoeffMap.fold (fun k c t -> fst @@ meet_single_inequality None narrow x_val y_val k c t) t1 t2 + + (*TODO: We could check all inequalities if they imply this for the specific intervals, but it might be too inefficient! leq O(|t|^2) instead of O(|t|) ?*) let implies_single_inequality x_val y_val t_opt (a,b) c = let implied_by_value () = let ax = Value.div (Value.mul x_val @@ Value.of_bigint @@ Q.num a) @@ Value.of_bigint @@ Q.den a in @@ -703,23 +781,136 @@ module ArbitraryCoeffsSet = struct let widen = join' true let meet = meet' false let narrow = meet' true + + (*Convert two righthandsides into coefficients to an inequality*) + let coeffs_from_rhss (cx, ox, dx) (cy, oy, dy)= (Q.make cx dx, Q.make cy dy, Q.sub (Q.make oy dy) (Q.make ox dx)) + end -module LinearInequalities (*: TwoVarInequalities *)= struct +module LinearInequalities: TwoVarInequalities = struct module Coeffs = ArbitraryCoeffsSet include CommonActions(Coeffs) -(* - `is_less_than' - `meet_condition' - `transfer' - *) + + (*Is it woth it in here to check all inequalities inside the intervals?*) + let rec get_relations (((var_x,o_x,d_x), val_x) as x') (((var_y,o_y,d_y), val_y) as y') t = + match var_x, var_y with + | Some (c_x, x), Some (c_y, y) -> + if x > y then + (*We save information only in one of the directions -> check the other one*) + List.map Relation.invert @@ get_relations y' x' t + else begin + if M.tracing then M.trace "is_less_than" "checking x': %s, y': %s" (Rhs.show @@ fst x') (Rhs.show @@ fst y'); + match get_coeff x y t with + | None -> begin if M.tracing then M.trace "is_less_than" "no inequality for roots"; [] end (*No information*) + | Some coeff -> (*TODO should we check all inequalities here? how could we do that*) + let (a,b,c_rhs) = Coeffs.coeffs_from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) in + let upper_bound = match Coeffs.CoeffMap.find_opt (a,b) coeff with + | None -> [] + | Some c_ineq -> + let c' = Q.sub c_ineq c_rhs in + [Relation.Lt, Z.fdiv (Q.num c') (Q.den c')] + in match Coeffs.CoeffMap.find_opt (Q.neg a, Q.neg b) coeff with (*lower bound*) + | None -> upper_bound + | Some c_ineq -> + let c' = Q.neg ( Q.add c_ineq c_rhs) in + (Gt, Z.cdiv (Q.num c') (Q.den c')) :: upper_bound + end + | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) + + let get_relations x y t = + let res = get_relations x y t in + if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); + res + + let rec meet_relation x' y' cond get_rhs get_value t = + if x' > y' then + (*We save information only in one of the directions*) + meet_relation y' x' (Relation.invert cond) get_rhs get_value t + else + let get_rhs' lhs = + let rhs = get_rhs lhs in + match rhs with + | (Some (c,var), o ,d) -> (c,o,d), var + | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO I think we should not save relations to constants here, as that information will be saved in the intervals, but am not sure if this is always done*) + in let (rhs_x, x) = get_rhs' x' + in let (rhs_y, y) = get_rhs' y' + in let coeffs = match get_coeff x y t with + | None -> Coeffs.empty + | Some c -> c + in let (a,b,c_rhs) = Coeffs.coeffs_from_rhss rhs_x rhs_y + in let meet_relation_roots (a,b) c t = + if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s var_%d < %s var_%d + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c); + (*do not save inequalities refering to the same variable*) + if x = y then + if a = b then + if Q.leq c Q.zero then raise EConj.Contradiction + else t, [] (*trivially true*) + else (*refine the value in this case*) + let ab = Q.sub a b in + if Q.gt ab Q.zero then + let max = Q.sub (Q.div c ab) Q.one in + t, [x, Value.ending @@ Z.cdiv (Q.num max) (Q.den max)] + else + let min = Q.add (Q.div c ab) Q.one in + t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] + else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) (a,b) c t + in let (new_coeffs, refine_acc) = match cond with + | Lt, o -> meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint o) coeffs + | Gt, o -> meet_relation_roots (Q.neg a ,Q.neg b) (Q.neg @@ (Q.add c_rhs @@ Q.of_bigint o)) coeffs + | Eq, o -> coeffs, [] + (*TODO: I think this should always be stored by the lin2vareq domain (at least the way we are generating this information) + (*meet with < +1 und > -1*) + if M.tracing then M.tracel "meet_relation" "meeting equality!"; + meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint @@ Z.add Z.one o) @@ + meet_relation_roots (Q.neg a ,Q.neg b) (Q.neg @@ (Q.add c_rhs @@ Q.of_bigint @@ Z.add Z.minus_one o)) coeffs*) + in if Coeffs.CoeffMap.is_empty new_coeffs + then remove_coeff x y t , refine_acc + else set_coeff x y new_coeffs t, refine_acc + + let meet_relation x y c r v t = + if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); + let res, refine_acc = meet_relation x y c r v t in + if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (List.fold (fun acc (var,value) -> Printf.sprintf "var_%d: %s, %s" var (Value.show value) acc) "" refine_acc); + res, refine_acc + + (*TODO very similar to simple equalities -> generalise?*) + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + let get_old_condition x y = + let get_information lhs = + let rhs = get_rhs_old lhs in + match rhs with + | (Some (_,var), _ ,_) -> (rhs, get_value_old var) + (*We need to know which root a constant is referring to, so we use the trivial equation to carry that information*) + | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) + in + get_relations (get_information x) (get_information y) t_old + in let vars_to_check = + let root = match get_rhs_old x with + | (Some (_,var), _ ,_) -> var + | (_,o,_) -> x + (*we need to check all y with root -> y -> coeff or y -> root -> coeff*) + (*TODO we know all vars greater than y can not contain y *) + in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) + in let transfer_single_condition y t' old_cond = + match Relation.combine cond old_cond with + | Some new_cond -> fst @@ meet_relation x_new y new_cond get_rhs get_value t' + | None -> t' + in let transfer_single_var t' y = List.fold (transfer_single_condition y ) t' (get_old_condition x y) + in BatEnum.fold (transfer_single_var) t vars_to_check + + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in + if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s -> %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t) (show res); + res + end (*TODOs:*) -(*allow inequalities with offset for meet_condition, is_less_than, transfer*) -(*generate inequalities with offset*) +(*adapt simple equalities to take advantage of the offset!*) +(*domain inbetween these two: with offset between roots? -> should be trivial to implement*) +(*what is required of narrow?*) (*limit in ArbitraryCoeaffsList*) (*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*widening thresholds: from offsets of rhs?*) -(*domain inbetween these two: with offset between roots? -> should be trivial to implement*) \ No newline at end of file +(*rebase to main branch*) \ No newline at end of file From 03b9f0a0b393e707b52375f6f226f8e7b0158471 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 25 Mar 2025 16:39:19 +0100 Subject: [PATCH 35/86] small fixes, debugging output --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 20 ++++++++++------ .../apron/pentagonSubDomains.apron.ml | 24 +++++++++---------- 2 files changed, 25 insertions(+), 19 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 52d641a71d..5635560306 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -756,6 +756,7 @@ struct let vss = EConjI.get_value d in (*a - b + interval (in arbitrary order)*) let meet_relation a b value = + if M.tracing then M.tracel "refine_tcons" "meet_relation: %s - %s + %s" (Var.show a) (Var.show b) (Value.show value); let dim_a = Environment.dim_of_var t.env a in let dim_b = Environment.dim_of_var t.env b in if M.tracing then M.tracel "meet_relation" "calling from refine with %s inside %s" (Tcons1.show tcons) (EConjI.show d); @@ -763,16 +764,21 @@ struct | Some (Int min), _, SUP -> Ineq.meet_relation dim_b dim_a (Relation.Lt, min) rhss vss ineq | Some (Int min), _, SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one min) rhss vss ineq | Some min, Some max, EQ -> begin - let ineq, refine = match min with - | Int min -> Ineq.meet_relation dim_b dim_a (Relation.Gt, Z.sub min Z.one) rhss vss ineq - | _ -> ineq, [] - in match max with - | Int max -> BatTuple.Tuple2.map2 ((@) refine) @@ Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq - | _ -> ineq, refine + if TopIntOps.equal min max then ineq, [] else (*If this is a constant, we have a equality that the lin2vareq domain should handle*) + let ineq, refine = match min with + | Int min -> Ineq.meet_relation dim_b dim_a (Relation.Gt, Z.sub min Z.one) rhss vss ineq + | _ -> ineq, [] + in match max with + | Int max -> BatTuple.Tuple2.map2 ((@) refine) @@ Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq + | _ -> ineq, refine end | _, _,_ -> ineq, [] in let d' = (econ, vs, ineq') - in List.fold (fun d (var,value) -> EConjI.meet_with_one_value var value d false) d' value_refinements + in let refine_value d (var,value) = + let res = EConjI.meet_with_one_value var value d false in + if M.tracing then M.tracel "refine_tcons" "refinement from ineq: var_%d: %s => %s -> %s" var (Value.show value) (EConjI.show d) (EConjI.show res); + res + in List.fold (refine_value) d' value_refinements in match expr with (*TODO we could do this in a more general way -> normalisation??*) (*currently only hits if two variables are at the first two levels. Also, we only choose one pattern even if multiple are possible e.g. x + y - z arbitrarily selects x or y to convert into an interval, instead we could meet for both*) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index fc5026c003..699cb79a28 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -824,20 +824,20 @@ module LinearInequalities: TwoVarInequalities = struct res let rec meet_relation x' y' cond get_rhs get_value t = - if x' > y' then + let get_rhs' lhs = + let rhs = get_rhs lhs in + match rhs with + | (Some (c,var), o ,d) -> (c,o,d), var + | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO I think we should not save relations to constants here, as that information will be saved in the intervals, but am not sure if this is always done*) + in let (rhs_x, x) = get_rhs' x' + in let (rhs_y, y) = get_rhs' y' + in if x > y then (*We save information only in one of the directions*) meet_relation y' x' (Relation.invert cond) get_rhs get_value t else - let get_rhs' lhs = - let rhs = get_rhs lhs in - match rhs with - | (Some (c,var), o ,d) -> (c,o,d), var - | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO I think we should not save relations to constants here, as that information will be saved in the intervals, but am not sure if this is always done*) - in let (rhs_x, x) = get_rhs' x' - in let (rhs_y, y) = get_rhs' y' - in let coeffs = match get_coeff x y t with - | None -> Coeffs.empty - | Some c -> c + let coeffs = match get_coeff x y t with + | None -> Coeffs.empty + | Some c -> c in let (a,b,c_rhs) = Coeffs.coeffs_from_rhss rhs_x rhs_y in let meet_relation_roots (a,b) c t = if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s var_%d < %s var_%d + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c); @@ -856,7 +856,7 @@ module LinearInequalities: TwoVarInequalities = struct t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) (a,b) c t in let (new_coeffs, refine_acc) = match cond with - | Lt, o -> meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint o) coeffs + | Relation.Lt, o -> meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint o) coeffs | Gt, o -> meet_relation_roots (Q.neg a ,Q.neg b) (Q.neg @@ (Q.add c_rhs @@ Q.of_bigint o)) coeffs | Eq, o -> coeffs, [] (*TODO: I think this should always be stored by the lin2vareq domain (at least the way we are generating this information) From 8788cddb768a7fd34e54d417f52aac1b1c1f8260 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 25 Mar 2025 19:59:53 +0100 Subject: [PATCH 36/86] more fixing --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 12 ++++++------ src/cdomains/apron/pentagonSubDomains.apron.ml | 13 +++++++++---- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 5635560306..a5912b86ea 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -458,9 +458,9 @@ struct let v = eval_texpr t expr in (*TODO we evaluate some subexpressions twice when calling this in assign_texpr -> bad for performance??*) match Value.minimal v, Value.maximal v with | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, min), var] - | Some (Int min), Some (Int maxi) -> [(Relation.Gt, min), var; (Relation.Lt, maxi), var] - | Some (Int min), _ -> [(Relation.Gt, min), var] - | _,Some (Int maxi) -> [(Relation.Lt, maxi), var] + | Some (Int min), Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one min), var; (Relation.Lt, Z.add Z.one maxi), var] + | Some (Int min), _ -> [(Relation.Gt, Z.add Z.minus_one min), var] + | _,Some (Int maxi) -> [(Relation.Lt, Z.add Z.one maxi), var] | _,_ -> [] in let inequality_from_mul var expr = let v_expr = eval_texpr t expr in @@ -486,9 +486,9 @@ struct let v = eval_texpr t e in begin match Value.minimal v, Value.maximal v with | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, Z.neg min), y] - | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.neg min), y; (Relation.Gt, Z.neg maxi), y] - | Some (Int min), _ -> [(Relation.Lt, Z.neg min), y] - | _,Some (Int maxi) -> [(Relation.Gt, Z.neg maxi), y] + | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y; (Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] + | Some (Int min), _ -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y] + | _,Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] | _,_ -> [] end | Binop (Div, Var y, e, _, _) -> begin diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 699cb79a28..71af06f9a9 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -669,7 +669,7 @@ module ArbitraryCoeffsSet = struct type t = Q.t CoeffMap.t [@@deriving eq, ord] - let hash t = CoeffMap.fold (fun (a,b) c acc -> let open Q in Q.to_int @@ a + b + b + c+c+ c) t 0 + let hash t = CoeffMap.fold (fun (a,b) c acc -> let open Q in Z.hash @@ Q.to_bigint @@ a + b + b + c+c+ c) t 0 let show_single_inequality x y a b c = Printf.sprintf "%s %s < %s %s + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c) @@ -744,13 +744,17 @@ module ArbitraryCoeffsSet = struct (*TODO: We could check all inequalities if they imply this for the specific intervals, but it might be too inefficient! leq O(|t|^2) instead of O(|t|) ?*) let implies_single_inequality x_val y_val t_opt (a,b) c = - let implied_by_value () = + let implied_by_value () = (*TODO will rounding lead to problems?*) let ax = Value.div (Value.mul x_val @@ Value.of_bigint @@ Q.num a) @@ Value.of_bigint @@ Q.den a in let by = Value.div (Value.mul y_val @@ Value.of_bigint @@ Q.num b) @@ Value.of_bigint @@ Q.den b in let c' = Value.maximal @@ Value.sub ax by in match c' with - | Some (TopIntOps.Int c') -> Q.leq (Q.of_bigint c') c + | Some (TopIntOps.Int c') -> Q.lt (Q.of_bigint c') c | _ -> false + in let implied_by_value () = + let res = implied_by_value () in + if M.tracing then M.trace "implied" "checking %s returned %b" (show_single_inequality (Value.show x_val) (Value.show y_val) a b c) res ; + res in match t_opt with | Some t -> begin match CoeffMap.find_opt (a,b) t with | Some c' -> Q.leq c' c @@ -900,8 +904,9 @@ module LinearInequalities: TwoVarInequalities = struct in BatEnum.fold (transfer_single_var) t vars_to_check let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t); let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in - if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s -> %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t) (show res); + if M.tracing then M.tracel "transfer" "result: %s" (show res); res end From 5b8fa24f36d0699b8459e2fa71de7dd6a04c4e51 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 26 Mar 2025 17:09:29 +0100 Subject: [PATCH 37/86] make sure we only save relations for the roots, simple transfering --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 40 ++++++++++++++----- .../apron/pentagonSubDomains.apron.ml | 4 +- 2 files changed, 34 insertions(+), 10 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a5912b86ea..fee1d9135a 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -214,8 +214,9 @@ struct in set_value after_ineq newRoot @@ get_value d newRoot let forget_variable d var = + if M.tracing then M.tracel "forget" "forget var_%d in { %s } " var (show d); let res = forget_variable d var in - if M.tracing then M.tracel "forget" "forget var_%d in { %s } -> { %s }" var (show d) (show res); + if M.tracing then M.trace "forget" "-> { %s }" (show res); res @@ -234,7 +235,7 @@ struct let meet_with_one_conj ((ts, is, ineq) as t:t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = - let subst_var ((dim,econj), is, ineq) x (vary, o, d) = + let subst_var (((dim,econj), is, ineq) as t) x (vary, o, d) = let (vary, o, d) = Rhs.canonicalize (vary, o, d) in (* [[x substby (cy+o)/d ]] ((c'x+o')/d') *) (* =====> (c'cy + c'o+o'd)/(dd') *) @@ -243,7 +244,7 @@ struct let open Z in Rhs.canonicalize (BatOption.map (fun (c, y)-> (c * c', y)) vary, c'*o + o'*d, d'*d) | e -> e in - let value = get_value (ts, is, ineq) x in + let value = get_value t x in if vary = None then begin if d <> Z.one then (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); @@ -251,10 +252,21 @@ struct if not @@ Value.contains value (Z.div offs divi) then (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show value); raise EConj.Contradiction) - end; - let is' = IntMap.remove x is in (*if x was the representative, it might not be anymore -> remove value and add it back afterwards*) - let t' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj), is', ineq in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) - set_value t' x value + end; + let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) + match vary with + | Some (c,y) -> (*x was a representant but is not anymore*) + let relations = + if Z.equal c Z.one && Z.equal d Z.one then [Relation.Eq, o] + else Ineq.get_relations (get_rhs t x, value) (get_rhs t y, get_value t y) ineq (*relation of new root to root before this call*) + in let ineq' = + let transfer_single_relation ineq_acc cond = + Ineq.transfer x y cond ineq (get_rhs t) (get_value t) ineq_acc (get_rhs (econj', is, ineq)) (get_value (econj', is, ineq)) + in List.fold transfer_single_relation ineq relations + in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) + let t' = econj', is', ineq' in + set_value t' x value + | None -> econj', is, ineq in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -912,9 +924,19 @@ struct None -> None | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); - (*TODO: I'm not sure if this is precise enough in all cases or if we would need to do something similar to collecting the values!*) let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in - Some (collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq')) + let (e,v,i) as d' = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in + (*We do not want to save inequalities for non-representants. in some cases, we can transfer these*) + (*TODO this feels inefficient, but I'm not sure how else to do it*) + (*TODO here and at forgetvar, we could be more precise by transforming with the whole rhs!!*) + let not_constant (c,_,_) = BatOption.is_some c in + let transfer_if_possible var rhs ineq_acc = + match rhs with + | (Some (c,v), o, d) when Z.equal c d -> Ineq.transfer var v (Relation.Eq, Z.neg @@ Z.divexact o d) ineq' (EConjI.get_rhs d') (EConjI.get_value d') ineq_acc (EConjI.get_rhs d') (EConjI.get_value d') + | _ -> ineq_acc + in + let i' = EConj.IntMap.fold (fun var rhs ineq_acc -> if not_constant rhs then transfer_if_possible var rhs @@ Ineq.forget_variable ineq_acc var else ineq_acc) (snd econj'') i in + Some (e,v,i') in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 71af06f9a9..f02e38fa3f 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -898,7 +898,9 @@ module LinearInequalities: TwoVarInequalities = struct in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) in let transfer_single_condition y t' old_cond = match Relation.combine cond old_cond with - | Some new_cond -> fst @@ meet_relation x_new y new_cond get_rhs get_value t' + | Some new_cond -> + if M.tracing then M.tracel "transfer" "combined %s , %s -> %s" (Relation.show (Int.to_string x_new) cond (Int.to_string x) ) (Relation.show (Int.to_string x) old_cond (Int.to_string y) ) (Relation.show (Int.to_string x_new) new_cond (Int.to_string y) ); + fst @@ meet_relation x_new y new_cond get_rhs get_value t' | None -> t' in let transfer_single_var t' y = List.fold (transfer_single_condition y ) t' (get_old_condition x y) in BatEnum.fold (transfer_single_var) t vars_to_check From 582919bc2deb805c9d0f34e5eb377a448f8d9ae8 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 27 Mar 2025 00:51:47 +0100 Subject: [PATCH 38/86] remove value when the variable is replaced by a constant --- src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index fee1d9135a..4e32b24df7 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -266,7 +266,7 @@ struct in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) let t' = econj', is', ineq' in set_value t' x value - | None -> econj', is, ineq + | None -> econj', IntMap.remove x is, ineq (*we replaced x by a constant -> do not save a value anymore*) in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) From 2222c20179beeda6eaf0e68ddf484d7177c21be5 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 27 Mar 2025 02:45:42 +0100 Subject: [PATCH 39/86] fixed using wrong variable to calculate value refinements --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 3 ++- src/cdomains/apron/pentagonSubDomains.apron.ml | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 4e32b24df7..e8de0d5842 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -812,8 +812,9 @@ struct with EConj.Contradiction -> bot_env let refine_with_tcons t tcons = + if M.tracing then M.tracel "refine_tcons" "refining %s with %s" (show t) (Tcons1.show tcons); let res = refine_with_tcons t tcons in - if M.tracing then M.tracel "refine_tcons" "before: %s \n refined with %s\n result: %s " (show t) (Tcons1.show tcons) (show res) ; + if M.tracing then M.tracel "refine_tcons" "result: %s" (show res) ; res let meet_with_one_conj t i (var, o, divi) = diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index f02e38fa3f..58fafc74dc 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -715,14 +715,14 @@ module ArbitraryCoeffsSet = struct | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_x with - | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up @@ Q.div c a] + | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up @@ Q.div c b] | _ -> [] else (*a/b x - c/b > y*) let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down ba))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up ba)) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_x with - | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down @@ Q.div c a] + | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down @@ Q.div c b] | _ -> [] in match Q.compare a Q.zero, Q.compare b Q.zero with | 0, 0 -> (*0 < c*) if Q.gt c Q.zero then [], true else raise EConj.Contradiction From 2ac66363074d9dd6177e0b6273df657fe435a77f Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 27 Mar 2025 14:14:59 +0100 Subject: [PATCH 40/86] fixed looking at wrong bound in interval --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index e8de0d5842..2ae213c4d5 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -773,8 +773,8 @@ struct let dim_b = Environment.dim_of_var t.env b in if M.tracing then M.tracel "meet_relation" "calling from refine with %s inside %s" (Tcons1.show tcons) (EConjI.show d); let ineq', value_refinements = match Value.minimal value, Value.maximal value, Tcons1.get_typ tcons with - | Some (Int min), _, SUP -> Ineq.meet_relation dim_b dim_a (Relation.Lt, min) rhss vss ineq - | Some (Int min), _, SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one min) rhss vss ineq + | _, Some (Int max), SUP -> Ineq.meet_relation dim_b dim_a (Relation.Lt, max) rhss vss ineq + | _, Some (Int max), SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq | Some min, Some max, EQ -> begin if TopIntOps.equal min max then ineq, [] else (*If this is a constant, we have a equality that the lin2vareq domain should handle*) let ineq, refine = match min with From 06bde16301e5c9b91a001486552f9aba3527603c Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 10 Apr 2025 03:46:41 +0200 Subject: [PATCH 41/86] larger rework of linear inequalities --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 97 +-- .../apron/pentagonSubDomains.apron.ml | 678 +++++++++++++----- 2 files changed, 552 insertions(+), 223 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 2ae213c4d5..f6d9186a06 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -56,7 +56,7 @@ struct let (v,o,d) = get_rhs t lhs in if (v,o,d) = Rhs.var_zero lhs then Value.top (*no relation -> Top*) else match v with - None -> Value.div (Value.of_bigint o) (Value.of_bigint d)(*constant*) (*TODO is divisor always 1?*) + None -> Value.of_bigint @@ Z.divexact o d (*constant*) | Some (coeff,v) -> let i = match IntMap.find_opt v vs with None -> Value.top (*uninitialised. Still translate it with the Rhs for congruence information*) @@ -132,7 +132,9 @@ struct set_value_for_root lhs i else match v with - | None -> (econ, is, ineq) (*For a constant, we do not need to save an value*) (*TODO should we check for equality?*) + | None -> + if not @@ Value.contains i @@ Z.div o d then raise EConj.Contradiction; + (econ, is, ineq) (*For a constant, we do not need to save an value*) | Some (coeff, v) -> let i1 = Value.mul (Value.of_bigint d) i in let i2 = Value.sub i1 (Value.of_bigint o) in @@ -165,8 +167,7 @@ struct let forget_variable ((econj, _, _) as d) var = let rhs_var = get_rhs d var in - let value_var = get_value d var in - (*Forgetting EConj, but also return new representative if it changed*) + (*Forgetting EConj, but also return relation of new representative to the old if this changes*) let (econj', vs', ineq'), newRoot = (let ref_var_opt = Tuple3.first rhs_var in match ref_var_opt with @@ -189,29 +190,20 @@ struct Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) set_rhs map i ) d clusterrest) in - set_rhs shifted_cluster head (Rhs.var_zero head), Some head (* finally make sure that head is now trivial *) + set_rhs shifted_cluster head (Rhs.var_zero head), Some yrhs (* finally make sure that head is now trivial *) | [] -> d, None) (* empty cluster means no work for us *) | _ -> d, None) (* variable is either a constant or expressed by another refvar *) in (*Forget old information*) let econj'' = (fst econj', IntMap.remove var (snd econj')) in let vs'' = IntMap.remove var vs' in - let ineq'' = Ineq.forget_variable ineq' var in - let d' = (econj'', vs'', ineq'') in - (*Try restoring information for new head if root changed*) match newRoot with - | None -> d' - | Some newRoot -> - (*restoring inequalities*) - let relations = - match get_rhs d newRoot with - | (Some (c,_), o, d) when Z.equal c Z.one && Z.equal d Z.one -> [Relation.Eq, o] - | rhs_new -> Ineq.get_relations (rhs_new, get_value d newRoot) (rhs_var, value_var) ineq'' (*relation of new root to root before this call*) - in let after_ineq = - let transfer_single_relation ineq_acc cond = - Ineq.transfer var newRoot cond ineq' (get_rhs d) (get_value d) ineq_acc (get_rhs d') (get_value d') - in econj'', vs'', List.fold transfer_single_relation ineq'' relations - (*restoring values*) - in set_value after_ineq newRoot @@ get_value d newRoot + | None -> (econj'', vs'', Ineq.forget_variable ineq' var) + | Some (Some (coeff,y),offs,divi) -> + (*modify inequalities*) + let ineq'' = Ineq.affine_transform ineq' var (coeff,y,offs,divi) + (*restoring value information*) + in set_value (econj'', vs'', ineq'') y @@ get_value d y + | _ -> failwith "Should not happen" (*transformation can not be a constant*) let forget_variable d var = if M.tracing then M.tracel "forget" "forget var_%d in { %s } " var (show d); @@ -256,17 +248,11 @@ struct let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) match vary with | Some (c,y) -> (*x was a representant but is not anymore*) - let relations = - if Z.equal c Z.one && Z.equal d Z.one then [Relation.Eq, o] - else Ineq.get_relations (get_rhs t x, value) (get_rhs t y, get_value t y) ineq (*relation of new root to root before this call*) - in let ineq' = - let transfer_single_relation ineq_acc cond = - Ineq.transfer x y cond ineq (get_rhs t) (get_value t) ineq_acc (get_rhs (econj', is, ineq)) (get_value (econj', is, ineq)) - in List.fold transfer_single_relation ineq relations + let ineq' = Ineq.affine_transform ineq x (c, y, o, d) in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) let t' = econj', is', ineq' in set_value t' x value - | None -> econj', IntMap.remove x is, ineq (*we replaced x by a constant -> do not save a value anymore*) + | None -> econj', IntMap.remove x is, Ineq.forget_variable ineq x (*we replaced x (and all connected vars) by a constant -> do not save a value and inequality anymore*) in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -306,21 +292,23 @@ struct ; res let affine_transform (econ, vs, ineq) i rhs = - (*This is a place we want to use the original set_rhs, as the implied congruence might contradict each other during the transformation*) + (*This is a place we want to use the original set_rhs (therefore use EConj directly), as the implied congruence might contradict each other during the transformation*) (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) (*This is only called in assign_texpr, after which the value will be set correctly.*) - (EConj.affine_transform econ i rhs, vs, ineq) + let (_, (m,o,d)) = EConj.inverse i rhs in + let c,v = BatOption.get m in + (EConj.affine_transform econ i rhs, vs, Ineq.affine_transform ineq i (c,v,o,d)) let affine_transform econ i rhs = let res = affine_transform econ i rhs in - if M.tracing then M.tracel "modify_pentagon" "affine_transform %s -> %s " (show econ) (show res); + if M.tracing then M.tracel "affine_transform" "affine_transform %s -> %s " (show econ) (show res); res let meet_with_one_value var value t narrow = let meet_function = if narrow then Value.narrow else Value.meet in let new_value = meet_function value (get_value t var) in if Value.is_bot new_value then raise EConj.Contradiction else - let res = set_value t var new_value + let res = set_value t var new_value (*TODO because we meet with an already saved values, we already confirm to the congruence constraints -> skip calculating them again!*) in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res @@ -412,7 +400,6 @@ struct let simplify_to_ref_and_offset t texp = timing_wrap "coeff_vec" (simplify_to_ref_and_offset t) texp - (*TODO texpr has rather few constructors. Would we be more precise if we evaluated the CIL expression instead??*) let eval_texpr (t:t) texp = let open Apron.Texpr1 in let binop_function = function @@ -421,18 +408,18 @@ struct | Mul -> Value.mul | Div -> Value.div | Mod -> Value.rem - | Pow -> failwith "power is not supported" (*TODO should this be supported*) + | Pow -> failwith "power is not supported" in let unop_function = function | Neg -> Value.neg | Cast -> identity - | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) + | Sqrt -> failwith "sqrt is not supported" in let rec eval = function | Cst (Scalar x) -> begin match SharedFunctions.int_of_scalar ?round:None x with | Some x -> Value.of_bigint x | None -> Value.top end - | Cst (Interval _) -> failwith "constant was an interval; this is not supported" (*TODO monomials_from_texp does not support this as well, but maybe we should*) + | Cst (Interval _) -> failwith "constant was an interval; this is not supported" | Var x -> let var_dim = Environment.dim_of_var t.env x in begin match t.d with @@ -440,7 +427,6 @@ struct | Some d -> EConjI.get_value d var_dim end | Binop (Sub, Var a , Var b, Int, _) -> - (*TODO are there more locations where we can use the inequality information? What if we allow Ineq to return more precise information? (e.g. 5a < 4b + 11)*) let dim_a = Environment.dim_of_var t.env a in let dim_b = Environment.dim_of_var t.env b in begin match t.d with @@ -469,7 +455,7 @@ struct let inequality_from_add var expr = let v = eval_texpr t expr in (*TODO we evaluate some subexpressions twice when calling this in assign_texpr -> bad for performance??*) match Value.minimal v, Value.maximal v with - | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, min), var] + | Some (Int min), Some (Int maxi) when min = maxi -> [] (*Should be caught by the lin2var domain -> do not repeat that information*) | Some (Int min), Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one min), var; (Relation.Lt, Z.add Z.one maxi), var] | Some (Int min), _ -> [(Relation.Gt, Z.add Z.minus_one min), var] | _,Some (Int maxi) -> [(Relation.Lt, Z.add Z.one maxi), var] @@ -479,7 +465,7 @@ struct let v_var = eval_texpr t (Var var) in if Value.leq v_expr (Value.of_bigint Z.one) || Value.leq v_var (Value.of_bigint Z.zero) - then [((Relation.Eq, Z.zero), var)] + then [] (*Should be caught by the lin2var domain -> do not repeat that information*) else match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with | true, _ , true, _ -> if Value.contains v_expr Z.one then [(Relation.Gt, Z.minus_one), var] else [(Relation.Gt, Z.zero), var] @@ -497,7 +483,7 @@ struct | Binop (Sub, Var y, e, _, _) -> let v = eval_texpr t e in begin match Value.minimal v, Value.maximal v with - | Some (Int min), Some (Int maxi) when min = maxi -> [(Relation.Eq, Z.neg min), y] + | Some (Int min), Some (Int maxi) when min = maxi -> [] (*Should be caught by the lin2var domain -> do not repeat that information*) | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y; (Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] | Some (Int min), _ -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y] | _,Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] @@ -508,7 +494,7 @@ struct let v_var = eval_texpr t (Var y) in if Value.leq v_expr (Value.of_bigint Z.one) || Value.leq v_var (Value.of_bigint Z.zero) - then [((Relation.Eq, Z.zero), y)] + then [] (*Should be caught by the lin2var domain -> do not repeat that information*) else match Value.must_be_pos v_expr, Value.must_be_neg v_expr, Value.must_be_pos v_var, Value.must_be_neg v_var with | true, _ , true, _ -> if Value.contains v_expr Z.one then [(Relation.Lt, Z.one), y] else [(Relation.Lt, Z.zero), y] @@ -536,7 +522,7 @@ struct | _,_ -> [] end | Unop (Cast, e, _, _) -> to_inequalities t e - | Var x -> [((Relation.Eq, Z.zero), x)] + | Var x -> [] (*Should be caught by the lin2var domain -> do not repeat that information*) | _ -> [] let to_inequalities (t:t) texpr = @@ -742,7 +728,6 @@ struct (* a%b == c -> a: c+bℤ *) let t = Value.of_congruence (c, b) in (*If the calculated congruence implies this one, we have a contradiction*) - (*TODO we could check for definite values and contradictions at every step, not just in MOD / Variable assignment*) if is_inequality && Value.leq a_val (Value.of_congruence (c,b)) then raise EConj.Contradiction; Value.meet a'' t | _, _ -> a'' @@ -754,7 +739,7 @@ struct | Unop (op, e,_,_) -> begin match op with | Neg -> refine_values d (Value.neg value) e | Cast -> refine_values d value e - | Sqrt -> failwith "sqrt is not supported" (*TODO should this be supported*) + | Sqrt -> failwith "sqrt is not supported" end | Cst (Scalar x) -> begin match SharedFunctions.int_of_scalar ?round:None x with @@ -926,17 +911,15 @@ struct | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in - let (e,v,i) as d' = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in - (*We do not want to save inequalities for non-representants. in some cases, we can transfer these*) - (*TODO this feels inefficient, but I'm not sure how else to do it*) - (*TODO here and at forgetvar, we could be more precise by transforming with the whole rhs!!*) - let not_constant (c,_,_) = BatOption.is_some c in - let transfer_if_possible var rhs ineq_acc = + let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in + (*The above joins might result in inequalities for variables that are no longer representants after joining the equations -> transform them*) + (*TODO what if we split a connected component?? *) + let transform_non_representant var rhs ineq_acc = match rhs with - | (Some (c,v), o, d) when Z.equal c d -> Ineq.transfer var v (Relation.Eq, Z.neg @@ Z.divexact o d) ineq' (EConjI.get_rhs d') (EConjI.get_value d') ineq_acc (EConjI.get_rhs d') (EConjI.get_value d') + | (Some (c,v), o, d) when v <> var -> Ineq.affine_transform ineq_acc var (c,v,o,d) | _ -> ineq_acc in - let i' = EConj.IntMap.fold (fun var rhs ineq_acc -> if not_constant rhs then transfer_if_possible var rhs @@ Ineq.forget_variable ineq_acc var else ineq_acc) (snd econj'') i in + let i' = EConj.IntMap.fold (transform_non_representant) (snd econj'') i in Some (e,v,i') in (*Normalize the two domains a and b such that both talk about the same variables*) @@ -1016,8 +999,7 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - (*TODO in this case, the transfer of information could be more precise for the exact inequalities! But currently COndition.t can not transfer that information*) - let econji' = econj, IntMap.remove var_i vs, Ineq.forget_variable ineq_old var_i in + let econji' = econj, IntMap.remove var_i vs, ineq_old in (*value will be updated afterwards with query*) {d=Some (EConjI.affine_transform econji' var_i (coeff_var, var_i, off, divi)); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) @@ -1033,8 +1015,7 @@ struct let ineq', refinements = Ineq.meet_relation var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq in List.fold (fun d (var,value) -> EConjI.meet_with_one_value var value d false) (e,v,ineq') refinements else - (*TODO If cond = Eq, we could restore the previous rhs. Does this ever happen without being handled above?*) - e,v,Ineq.transfer dim dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') + e,v,Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') in let d'' = List.fold meet_cond d' (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some d''; env = t.env}); @@ -1072,7 +1053,7 @@ struct )) with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) in - (*TODO If the newly assigned value must be greater / lower than the old, we can transfer conditions!*) + (*TODO If the newly assigned value must be greater / lower than the old, we can restore some conditions?*) let d' = if Value.is_bot value then None else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) in {d= d'; env = t.env} diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 58fafc74dc..4a381ba29a 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -334,8 +334,10 @@ module type TwoVarInequalities = sig val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t - (*copy all constraints for some variable to a different t if they still hold for a new x' with x' (cond) x *) - val transfer : int -> int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t + val affine_transform : t -> int -> Z.t * int * Z.t * Z.t -> t + + (*copy all constraints for some root to a different t if they still hold for a new x' with x' (cond) x *) + val transfer : int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t val show_formatted : (int -> string) -> t -> string val hash : t -> int @@ -361,7 +363,6 @@ module NoInequalties : TwoVarInequalities = struct let join _ _ _ _ = () let widen _ _ _ _ = () - let show_formatted _ _ = "{}" let hash _ = 3 let empty = () @@ -371,7 +372,9 @@ module NoInequalties : TwoVarInequalities = struct let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () - let transfer _ _ _ _ _ _ _ _ _ = () + let affine_transform _ _ _ = () + + let transfer _ _ _ _ _ _ _ _ = () end module type Coeffs = sig @@ -460,21 +463,24 @@ module CommonActions (Coeffs : Coeffs) = struct end -(*Equations of the type x < y*) -module NoCoeffs = struct - type t = unit [@@deriving eq, ord, hash ] +(* TODO Redo this + + + (*Equations of the type x < y*) + module NoCoeffs = struct + type t = unit [@@deriving eq, ord, hash ] - let implies x y t1_opt _ = match t1_opt with + let implies x y t1_opt _ = match t1_opt with | Some _ -> true | None -> match Value.maximal x, Value.minimal y with | Some x, Some y -> TopIntOps.compare x y < 0 | _, _ -> false - let meet x y _ _ = () + let meet x y _ _ = () - let narrow = meet + let narrow = meet - let join x y get_val_t1 get_val_t2 t1 t2 = + let join x y get_val_t1 get_val_t2 t1 t2 = let of_bool b = if b then Some () else None in match t1 with | Some t1 -> of_bool (implies (get_val_t2 x) (get_val_t2 y) t2 t1) @@ -482,11 +488,11 @@ module NoCoeffs = struct | Some t2 -> of_bool (implies (get_val_t1 x) (get_val_t1 y) t1 t2) | None -> None - let widen = join + let widen = join - let show_formatted x y t = x ^ " < " ^ y + let show_formatted x y t = x ^ " < " ^ y - let add_constraints x y x_val y_val acc = + let add_constraints x y x_val y_val acc = let acc = match Value.maximal y_val with | Some (Int v) -> (x, Value.ending @@ Z.sub v Z.one) :: acc | _ -> acc @@ -494,14 +500,14 @@ module NoCoeffs = struct | Some (Int v) -> (y, Value.starting @@ Z.add v Z.one) :: acc | _ -> acc -end + end -(*Semantics: x -> y -> () => x < y*) -module SimpleInequalities : TwoVarInequalities = struct - module Coeffs = NoCoeffs - include CommonActions(Coeffs) + (*Semantics: x -> y -> () => x < y*) + module SimpleInequalities : TwoVarInequalities = struct + module Coeffs = NoCoeffs + include CommonActions(Coeffs) - let get_relations x y t = + let get_relations x y t = let open Relation in let check_inequality ((var_x,o_x,d_x), val_x) ((var_y,o_y,d_y), val_y) = if M.tracing then M.trace "get_relations" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); @@ -535,12 +541,12 @@ module SimpleInequalities : TwoVarInequalities = struct if res = [] then List.map invert @@ check_inequality y x else res - let get_relations x y t = + let get_relations x y t = let res = get_relations x y t in if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); res - let meet_relation x' y' cond get_rhs get_value t = + let meet_relation x' y' cond get_rhs get_value t = let open Relation in (*strict: if the inequality is strict *) let meet_less_root x y strict t = @@ -607,13 +613,13 @@ module SimpleInequalities : TwoVarInequalities = struct | Lt, z when Z.leq z Z.zero-> meet_less x' y' true t | _ -> t, [] (*TODO adapt the equations to take care of offsets!*) - let meet_relation x y c r v t = + let meet_relation x y c r v t = if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); let res, refinements = meet_relation x y c r v t in if M.tracing then M.tracel "meet_relation" "result: %s " (show res); res, refinements - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = let get_old_condition x y = let get_information lhs = let rhs = get_rhs_old lhs in @@ -644,150 +650,440 @@ module SimpleInequalities : TwoVarInequalities = struct | _ -> t' in BatEnum.fold (transfer_single_var) t vars_to_check - (*TODO we currently just strip the offset, but could take advantage of the offset*) - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + (*TODO we currently just strip the offset, but could take advantage of the offset*) + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = match cond with | Relation.Eq, o when Z.equal o Z.zero -> transfer x x_new Eq t_old get_rhs_old get_value_old t get_rhs get_value | Relation.Lt, o when Z.leq o Z.zero -> transfer x x_new Lt t_old get_rhs_old get_value_old t get_rhs get_value | Relation.Gt, o when Z.geq o Z.zero -> transfer x x_new Gt t_old get_rhs_old get_value_old t get_rhs get_value | _ -> t - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = + let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s -> %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t) (show res); res -end + end + +*) + +let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) + + +module LinearInequality = struct + (*Normalised representation of an inequality through the origin + a/b x < y (or >) bzw. slope and direction. infinite slope represents 0 < x / 0 > x*) + module OriginInequality = struct (*Separate module so we can use it as key in a map*) + type t = LT of Q.t | GT of Q.t + + (*make the representation of inequalities without y unique*) + let norm = function + | GT s when Q.equal s Q.minus_inf -> LT Q.inf + | LT s when Q.equal s Q.minus_inf -> GT Q.inf + | t -> t + + (*We want the inequalities to be ordered by angle (with arbitrary start point and direction), which is tan(slope) (+ pi for other direction) *) + (*because tan is monotone, we can simply sort by slope: LT < GT, LT ordered by a, GT ordered by -a*) + let compare t1 t2 = match t1, t2 with + | LT _, GT _ -> -1 + | GT _, LT _ -> 1 + | LT a1, LT a2 -> Q.compare a1 a2 + | GT a1, GT a2 -> -(Q.compare a1 a2) + + let equal t1 t2 = 0 = compare t1 t2 + + let hash = function LT q -> qhash q | GT q -> 7 * qhash q + let get_slope = function LT a -> a | GT a -> a + + let negate = function + | LT s -> GT s + | GT s -> LT s + + end + + (*add an offset to the inequalities*) + type t = OriginInequality.t * Q.t [@@deriving eq] + + let show x y (k,c) = Printf.sprintf "%s %s %s %s %s + %s" (Z.to_string @@ Q.num @@ OriginInequality.get_slope k ) x (match k with LT _ -> "<" | GT _ -> ">") (Z.to_string @@ Q.den @@ OriginInequality.get_slope k ) y (Q.to_string c) + + (*Convert into coefficients of inequality ax + by < c + Useful because the TVLI paper (DOI: 10.1007/3-540-45013-0_7) uses this representation *) + let to_coeffs = function + | OriginInequality.LT s, c when Q.equal s Q.inf -> (Q.one,Q.zero,c) + | GT s, c when Q.equal s Q.inf -> (Q.minus_one, Q.zero, Q.neg c) + | LT s, c -> (s,Q.minus_one,c) + | GT s, c -> (Q.neg s, Q.one, Q.neg c) + + (*From TVLI: check if one or two inequalities imply an inequality*) + let entails1 (s1,c1) (s2,c2) = OriginInequality.equal s1 s2 && match s1 with LT _ -> Q.leq c1 c2 | GT _ -> Q.geq c1 c2 + + let entails1 t1 t2 = + let res = entails1 t1 t2 in + if M.tracing then M.trace "entails" "%s |= %s ? %b" (show "x" "y" t1) (show "x" "y" t2) res; + res + + let entails2 t1 t2 t = + let (a1,b1,c1) = to_coeffs t1 in + let (a2,b2,c2) = to_coeffs t2 in + let (a ,b ,c ) = to_coeffs t in + let open Q in + let d = a1 * b2 - a2 * b1 in + if equal d zero then + entails1 t1 t || entails1 t2 t + else + let l1 = (a * b2 - a2 * b) / d in + let l2 = (a1 * b - a * b1) / d in + geq l1 zero && geq l2 zero && geq c @@ l1 * c1 + l2 * c2 + + let entails2 t1 t2 t = + let res = entails2 t1 t2 t in + if M.tracing then M.trace "entails" "%s , %s |= %s ? %b" (show "x" "y" t1) (show "x" "y" t2) (show "x" "y" t) res; + res + + (*Calculate the best inequality with a fixed slope implied by two inequalities. Assumes the searched slope to be different to the known ones*) + let best_entailed t1 t2 k = + let (a1,b1,c1) = to_coeffs t1 in + let (a2,b2,c2) = to_coeffs t2 in + let (a ,b ,_ ) = to_coeffs (k,Q.zero) in + let open Q in + let d = a1 * b2 - a2 * b1 in + if equal d zero then + None + else + let l1 = (a * b2 - a2 * b) / d in + let l2 = (a1 * b - a * b1) / d in + if not (geq l1 zero && geq l2 zero) + then None + else + let c = l1 * c1 + l2 * c2 in + let c' = match k with LT _ -> c | GT _ -> neg c in + Some c' + + (*convert interval information into inequalities*) + let from_values x_val y_val = + let open OriginInequality in + let ineqs = match Value.maximal x_val with + | Some (Int z) -> (*x <= z *) [LT Q.inf, Q.of_bigint @@ Z.add Z.one z] + | _ -> [] + in let ineqs = match Value.minimal x_val with + | Some (Int z) -> (*x >= z *) (GT Q.inf, Q.of_bigint @@ Z.add Z.minus_one z) :: ineqs + | _ -> ineqs + in let ineqs = match Value.maximal x_val with + | Some (Int z) -> (*y <= z *) (GT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.one z ) :: ineqs + | _ -> ineqs + in let ineqs = match Value.minimal x_val with + | Some (Int z) -> (*y >= z *) (LT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.minus_one z ) :: ineqs + | _ -> ineqs + in ineqs + + (*Convert two righthandsides into an inequality*) + let from_rhss (cx, ox, dx) (cy, oy, dy) = + let a,b,c = (Q.make cx dx, Q.make cy dy, Q.sub (Q.make oy dy) (Q.make ox dx)) in + let s = Q.div a b in + if Q.equal b Q.zero + then OriginInequality.norm (LT s), Q.div c a + else if Q.gt b Q.zero + then LT s, Q.div c b + else GT s, Q.div c b + + + (*apply the transformation to the variable on the left side*) + let affine_transform_left (coeff, offs, divi) (k,o) = + let open OriginInequality in + let s = get_slope k in + let s' = Q.mul s (Q.make coeff divi) in + let o' = Q.sub o @@ Q.mul s @@ Q.make offs divi in + match k with + | LT _ -> LT s', o' + | GT _ -> GT s', o' + + (*apply the transformation to the variable on the right side*) + let affine_transform_right (coeff, offs, divi) (k,o) = + let open OriginInequality in + let s = get_slope k in + let f = Q.make coeff divi in + let s' = Q.div s f in + let o' = Q.add o @@ Q.make offs coeff in + let k' = match k with + | LT _ -> LT s' + | GT _ -> GT s' + in if Q.lt f Q.zero + then (negate k', Q.neg o') + else k', o' + + (*combine an inequaliy x_old -> x_new with x_old -> y to x_new -> y*) + let combine_left (k_rel, o_rel) (k, o) = + let open OriginInequality in + (*factor we need to multiply rel with so that x_old has the same coefficient in both inequalities *) + let f = Q.div (get_slope k) (get_slope k_rel) in + let k_rel' = if Q.geq f Q.zero then k_rel else negate k_rel in + match k_rel', k with + | LT _, LT _ + | GT _, GT _ -> None (*no useable inequality x_new -> y*) + | GT _, LT _ -> Some (LT f, Q.sub o (Q.mul f o_rel)) + | LT _, GT _ -> Some (GT f, Q.sub o (Q.mul f o_rel)) + + (*combine an inequaliy y_old -> y_new with x -> y_old to x-> y_new*) + let combine_right (k_rel, o_rel) (k, o) = + let open OriginInequality in + (*factor we need to multiply the inequality x -> y_old with so that y_old has the same coefficient in both inequalities *) + let f = (get_slope k) in + let k' = if Q.geq f Q.zero then k else negate k in + match k_rel, k' with + | LT _, GT _ + | GT _, LT _ -> None + | LT s_rel, LT s -> Some (LT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + | GT s_rel, GT s -> Some (GT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + + +end (*List of inequalities ax < by + c, mapping a and b to c*) (*We need to make sure that x has lower index than y to keep this representation unique! *) module ArbitraryCoeffsSet = struct - module Key = struct - type t = Q.t * Q.t [@@deriving ord] - end + module Key = LinearInequality.OriginInequality module CoeffMap = Map.Make(Key) type t = Q.t CoeffMap.t [@@deriving eq, ord] - let hash t = CoeffMap.fold (fun (a,b) c acc -> let open Q in Z.hash @@ Q.to_bigint @@ a + b + b + c+c+ c) t 0 - - let show_single_inequality x y a b c = Printf.sprintf "%s %s < %s %s + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c) + let hash t = CoeffMap.fold (fun k c acc -> qhash c + 17 * Key.hash k ) t 0 let show_formatted x y t = - CoeffMap.fold (fun (a,b) c acc -> Printf.sprintf "%s , %s" (show_single_inequality x y a b c ) acc) t "" + CoeffMap.fold (fun k c acc -> Printf.sprintf "%s , %s" (LinearInequality.show x y (k,c)) acc) t "" let empty = CoeffMap.empty (*TODO this function should limit how many inequalities we are saving. What information does this need? likely: values, coefficients of Rhs relating to x and y*) (* Throw away inequalities that are least useful: - implied by the current values? -> need to adapt implies to check all inequalities !!, otherwise join is not valid - least rhs with fitting coefficients *) + least rhss with fitting coefficients *) let limit = identity - let meet_single_inequality refine_data narrow x_val y_val (a,b) c t = + (*get the next key in anti-clockwise order*) + let get_previous k t = + match CoeffMap.find_first_opt (fun key -> Key.compare key k >= 0) t with + | None -> CoeffMap.min_binding_opt t (*there is no larger key -> take the first one*) + | s -> s + + (*get the next key in clockwise order*) + let get_next k t = + match CoeffMap.find_last_opt (fun key -> Key.compare key k <= 0) t with + | None -> CoeffMap.max_binding_opt t (*there is no smaller key -> take the last one*) + | s -> s + + (*adds the inequality while removing redundant ones. assumes that there is no inequality with this key already in the map*) + let add_inequality k c t = + match get_previous k t, get_next k t with + | None, None -> CoeffMap.add k c t (* the map is empty *) + | Some prev, Some next -> + if LinearInequality.entails2 prev next (k,c) then t (*new inequality is already implied*) + else (*check in both direction if the next inequality is now implied, and remove those that are. recursive because multiple may now be implied*) + let rec remove_prev prev t = + match get_previous (fst prev) t with + | None -> t + | Some prev_prev -> + if not (LinearInequality.equal prev prev_prev) && LinearInequality.entails2 prev_prev (k,c) prev then + remove_prev prev_prev @@ CoeffMap.remove (fst prev) t + else t + in let rec remove_next next t = + match get_next (fst next) t with + | None -> t + | Some next_next -> + if not (LinearInequality.equal next next_next) && LinearInequality.entails2 next_next (k,c) next then + remove_next next_next @@ CoeffMap.remove (fst next) t + else t + in CoeffMap.add k c @@ remove_prev prev @@ remove_next next t + | _,_ -> failwith "impossible state" + + + (*get the thightest offset for an inequality with a given slope that is implied by the current set of inequalities*) + let get_best_offset k t = + match CoeffMap.find_opt k t with + | Some c -> Some c + | None -> + if CoeffMap.cardinal t < 2 then None + else LinearInequality.best_entailed (BatOption.get @@ get_next k t) (BatOption.get @@ get_previous k t) k + + let get_best_offset k t = + let res = get_best_offset k t in + if M.tracing then M.trace "get_offset" "%s implies %s" (show_formatted "x" "y" t) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing for this slope" res); + res + + let meet_single_inequality refine_data narrow x_val y_val k c t = (*calculate value refine. If one of the coefficients is zero, we should not add it to the map*) let refinements, skip_adding = match refine_data with - | None -> [], (Q.equal a Q.zero) || Q.equal b Q.zero + | None -> [], (Q.equal Q.zero @@ Key.get_slope k) || not @@ Q.is_real @@ Key.get_slope k | Some (x,y) -> let round_up q = Z.cdiv (Q.num q) (Q.den q) in let round_down q = Z.fdiv (Q.num q) (Q.den q) in - let x_refine a_sign = - let ba = Q.div b a in - if a_sign = 1 then (*x < b/a y + c/a*) - let max_y = match Value.maximal (Value.mul y_val(Value.of_bigint (round_down ba))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up ba)) with + let x_refine = + let upper_bound s = (*x < y / s + c / s*) + let max_y = match Value.maximal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_y with - | Int max -> [x, Value.ending @@ Z.add Z.minus_one @@ Z.add max @@ round_up @@ Q.div c a] + | Int max -> [x, Value.ending @@ Z.add Z.minus_one @@ Z.add max @@ round_up @@ Q.div c s] | _ -> [] - else (*x > b/a y + c/a*) - let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down ba))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up ba)) with - | Some a, Some b -> TopIntOps.min a b - | _,_ -> failwith "trying to refine bot in inequalities" - in match min_y with - | Int min -> [x, Value.starting @@ Z.add Z.one @@ Z.add min @@ round_down @@ Q.div c a] - | _ -> [] - in let y_refine b_sign = - let ba = Q.div a b in - if b_sign = 1 then (*a/b x - c/b < y*) - let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down ba))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up ba)) with + in let lower_bound s = (*x > y / s + c / s*) + let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" - in match min_x with - | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up @@ Q.div c b] - | _ -> [] - else (*a/b x - c/b > y*) - let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down ba))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up ba)) with + in match min_y with + | Int min -> [x, Value.starting @@ Z.add Z.one @@ Z.add min @@ round_down @@ Q.div c s] + | _ -> [] + in + match k with + | LT s when Q.sign s > 0 -> upper_bound s + | GT s when Q.sign s < 0 -> upper_bound s + | LT s when Q.sign s < 0 -> lower_bound s + | GT s when Q.sign s > 0 -> lower_bound s + | _ -> [] (*Should never be used in this case*) + in let y_refine = + match k with + | LT s -> begin (*sx -c < y*) + let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up s)) with + | Some a, Some b -> TopIntOps.min a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match min_x with + | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up c] + | _ -> [] + end + | GT s -> (*s x - c > y*) + let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_x with - | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down @@ Q.div c b] + | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down c] | _ -> [] - in match Q.compare a Q.zero, Q.compare b Q.zero with - | 0, 0 -> (*0 < c*) if Q.gt c Q.zero then [], true else raise EConj.Contradiction - | 0, -1 -> (* -c / b > y*) [y, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.neg @@ Q.div c b] , true - | 0, 1 -> (* -c / b < y*) [y, Value.starting @@ Z.add Z.one @@ round_down @@ Q.neg @@ Q.div c b] , true - | 1, 0 -> (*x < c / a*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.div c a ], true - | -1,0 -> (*x > c / a*) [x, Value.starting @@ Z.add Z.one @@ round_down @@ Q.div c a ], true - | a_sign, b_sign -> x_refine a_sign @ y_refine b_sign, false + in match k with + | LT s when Q.equal Q.zero s -> (* -c > y *) [y, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.neg c] , true + | GT s when Q.equal Q.zero s -> (* -c < y *) [y, Value.starting @@ Z.add Z.one @@ round_down @@ Q.neg c] , true + | LT s when Q.equal Q.inf s -> (*x > c*) [x, Value.starting @@ Z.add Z.one @@ round_down c ], true + | GT s when Q.equal Q.minus_inf s -> (*x > c*) [x, Value.starting @@ Z.add Z.one @@ round_down c ], true + | LT s when Q.equal Q.minus_inf s -> (*x < c*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up c], true + | GT s when Q.equal Q.inf s -> (*x < c*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up c], true + | k -> (*an actual inequality *) x_refine @ y_refine, false in if skip_adding then t, refinements - else match CoeffMap.find_opt (Q.neg a, Q.neg b) t with (*Look for contradicting inequality*) - | Some c' when Q.geq (Q.add Q.one @@ Q.neg c') c -> raise EConj.Contradiction - (*TODO if c = - c' + 2 , then we have an equality -> maybe we can update the econj domain *) - | _ -> match CoeffMap.find_opt (a,b) t with - | Some c_old -> (*TODO if narrow then undefined "narrow not implemented" else *)CoeffMap.add (a,b) (Q.min c c_old) t, refinements - | None -> CoeffMap.add (a,b) c t , refinements - - (*when meeting, the values should already ben refined before -> ignore the refinement data*) + else (*Look for contradicting inequality*) + let contradicts c' = match k with + | LT _ -> Q.geq c' @@ Q.sub c Q.one + | GT _ -> Q.leq c' @@ Q.add c Q.one + in + match get_best_offset (Key.negate k) t with + | Some c' when contradicts c' -> raise EConj.Contradiction + (*TODO if c = c' + 2 , then we have an equality -> maybe we can update the econj domain *) + | _ -> + (*add the inequality, while making sure that we do not save redundant inequalities*) + (*TODO make this consider the intervals! -> adapt get_next and get_previous?*) + let t' = match CoeffMap.find_opt k t with + | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) (*TODO narrow?*) + | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) + in t', refinements (*TODO: lookup the best interval information from the inequalities!*) + + (*when meeting, the values should already been refined before -> ignore the refinement data*) let meet' narrow x_val y_val t1 t2 = CoeffMap.fold (fun k c t -> fst @@ meet_single_inequality None narrow x_val y_val k c t) t1 t2 - (*TODO: We could check all inequalities if they imply this for the specific intervals, but it might be too inefficient! leq O(|t|^2) instead of O(|t|) ?*) - let implies_single_inequality x_val y_val t_opt (a,b) c = - let implied_by_value () = (*TODO will rounding lead to problems?*) - let ax = Value.div (Value.mul x_val @@ Value.of_bigint @@ Q.num a) @@ Value.of_bigint @@ Q.den a in - let by = Value.div (Value.mul y_val @@ Value.of_bigint @@ Q.num b) @@ Value.of_bigint @@ Q.den b in - let c' = Value.maximal @@ Value.sub ax by in - match c' with - | Some (TopIntOps.Int c') -> Q.lt (Q.of_bigint c') c - | _ -> false - in let implied_by_value () = - let res = implied_by_value () in - if M.tracing then M.trace "implied" "checking %s returned %b" (show_single_inequality (Value.show x_val) (Value.show y_val) a b c) res ; - res - in match t_opt with - | Some t -> begin match CoeffMap.find_opt (a,b) t with - | Some c' -> Q.leq c' c - | None -> implied_by_value () - end - | None -> implied_by_value () - let implies x_val y_val t_opt t = CoeffMap.for_all (implies_single_inequality x_val y_val t_opt) t + let implies x_val y_val t1_opt t2 = + let t1 = match t1_opt with + | None -> CoeffMap.empty + | Some t -> t + in let interval_ineqs = LinearInequality.from_values x_val y_val in + let t1 = List.fold (fun t (k,c) -> add_inequality k c t) t1 interval_ineqs (*makes this O(n log n) instead of O(n)*) + in if CoeffMap.is_empty t2 then true + else if CoeffMap.is_empty t1 then false + else(*functional version of the entailment check from TVLI*) + let ts1 = CoeffMap.bindings t1 in + let ts2 = CoeffMap.bindings t2 in + let min_t1 = List.hd ts1 in + let max_t1 = CoeffMap.max_binding t1 in + let rec entails t1 t2 = match t1, t2 with + | _, [] -> true + | [], _ -> false (*should never happen, but makes this matching complete*) + | (tl::tu::t1s), ti::t2s when Key.compare (fst tu) (fst ti) < 0 -> entails (tu::t1s) (ti::t2s) + | ((tl::tu::_) as t1s), ti::t2s -> LinearInequality.entails2 tl tu ti && entails t1s t2s + | [tl], ti::t2s -> LinearInequality.entails2 tl min_t1 ti && entails [tl] t2s + in entails (max_t1::ts1) ts2 + + let implies x_val y_val t1_opt t2 = + let res = implies x_val y_val t1_opt t2 in + if M.tracing then M.trace "implies" "x = %s, y = %s, %s implies %s ? -> %b" (Value.show x_val) (Value.show y_val) (BatOption.map_default (show_formatted "x" "y") "{}" t1_opt) (show_formatted "x" "y" t2) res; + res let join' widen x y get_val_t1 get_val_t2 t1 t2 = - let join_single_inequality (a,b) c1 c2 = - match c1, c2 with - | None, None -> None - | Some c1, Some c2 -> if widen && c2 > c1 then None else Some (Q.max c1 c2) (*TODO widening thresholds?*) - | Some c1, None -> if implies_single_inequality (get_val_t2 x) (get_val_t2 y) None (a,b) c1 then Some c1 else None - | None, Some c2 -> if implies_single_inequality (get_val_t1 x) (get_val_t1 y) None (a,b) c2 then Some c2 else None + let implies_single_equality t k c = + let res = match get_best_offset k t with None -> false | Some c' -> LinearInequality.entails1 (k, c') (k,c) + in if M.tracing then M.trace "implies" "single ineq: %s implies %s ? -> %b" (show_formatted "x" "y" t) (LinearInequality.show "x" "y" (k,c)) res; + res in - let ignore_empty ls = - if CoeffMap.is_empty ls then None - else Some ls + let t1 = match t1 with None -> CoeffMap.empty | Some t1 -> t1 in + let t2 = match t2 with None -> CoeffMap.empty | Some t2 -> t2 in + (*add interval inequalities to copies, because doing it at every filter step would be more work*) + let t1_with_interval = + let ineqs = LinearInequality.from_values (get_val_t1 x) (get_val_t1 y) in + List.fold (fun t (k,c) -> add_inequality k c t) t1 ineqs + in let t2_with_interval = + let ineqs = LinearInequality.from_values (get_val_t2 x) (get_val_t2 y) in + List.fold (fun t (k,c) -> add_inequality k c t) t2 ineqs in - match t1, t2 with - | None, None -> None - | Some t1, None -> ignore_empty @@ limit @@ CoeffMap.filter (implies_single_inequality (get_val_t2 x) (get_val_t2 y) None) t1 - | None, Some t2 -> ignore_empty @@ limit @@ CoeffMap.filter (implies_single_inequality (get_val_t1 x) (get_val_t1 y) None) t2 - | Some t1, Some t2 -> ignore_empty @@ limit @@ CoeffMap.merge join_single_inequality t1 t2 + (*we want to keep inequalities that are in one of the elements and implied by the other (maxbe by also being in there) *) + let t1_filtered = CoeffMap.filter (implies_single_equality t2_with_interval) t1_with_interval in + let t2_filtered = CoeffMap.filter (implies_single_equality t1_with_interval) t2_with_interval in + (* merge the two sets. if one inequality is in both, take the less tight bound *) + (* we make two passes over the list: first the relaxation, then adding all other inequalities*) + (* this prevents an inequality from being deemed redundant by an inequality that is later relaxed*) + (* TODO: test if this increased precision is worth the time?*) + let relax k c2 (t1, t2) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) + match CoeffMap.find_opt k t1 with + | None -> (t1, t2) + | Some c1 when Q.equal c1 c2 -> (t1, CoeffMap.remove k t2) + | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) && widen-> (CoeffMap.remove k t1, CoeffMap.remove k t2) (*t2 has more relaxed bound -> do widening*) + | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1, CoeffMap.remove k t2) (*t2 has more relaxed bound*) + | Some c1 -> (t1, CoeffMap.remove k t2) (*last remaining case: t1 has more relaxed bound*) + in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) + in let merged = CoeffMap.fold add_inequality t2_filtered' t1_filtered' + (*remove the explicetly stored interval inequalities*) + in let ignore_empty ls = + if CoeffMap.is_empty ls then None + else Some ls + in ignore_empty @@ CoeffMap.remove (LT Q.zero) @@ CoeffMap.remove (GT Q.zero) @@ CoeffMap.remove (LT Q.inf) @@ CoeffMap.remove (GT Q.inf) merged let join = join' false let widen = join' true let meet = meet' false let narrow = meet' true - (*Convert two righthandsides into coefficients to an inequality*) - let coeffs_from_rhss (cx, ox, dx) (cy, oy, dy)= (Q.make cx dx, Q.make cy dy, Q.sub (Q.make oy dy) (Q.make ox dx)) + let affine_transform_left (coeff, offs, divi) t = + let f k c t_acc = + let (k',c') = LinearInequality.affine_transform_left (coeff, offs, divi) (k,c) in + CoeffMap.add k' c' t_acc (*affine transformation does not make a non redundant inequality redundant -> add directly*) + in + CoeffMap.fold f t CoeffMap.empty + + let affine_transform_right (coeff, offs, divi) t = + let f k c t_acc = + let (k',c') = LinearInequality.affine_transform_right (coeff, offs, divi) (k,c) in + CoeffMap.add k' c' t_acc + in + CoeffMap.fold f t CoeffMap.empty + + (**) + let combine_left rel t = + let fold_fun k c acc = + match LinearInequality.combine_left rel (k,c) with + | Some (k', c') -> CoeffMap.add k' c' acc + | None -> acc + in + let t' = CoeffMap.fold fold_fun t CoeffMap.empty in + if CoeffMap.is_empty t' then None else Some t' + + let combine_right rel t = + let fold_fun k c acc = + match LinearInequality.combine_right rel (k,c) with + | Some (k', c') -> CoeffMap.add k' c' acc + | None -> acc + in + let t' = CoeffMap.fold fold_fun t CoeffMap.empty in + if CoeffMap.is_empty t' then None else Some t' end @@ -796,28 +1092,34 @@ module LinearInequalities: TwoVarInequalities = struct module Coeffs = ArbitraryCoeffsSet include CommonActions(Coeffs) - (*Is it woth it in here to check all inequalities inside the intervals?*) - let rec get_relations (((var_x,o_x,d_x), val_x) as x') (((var_y,o_y,d_y), val_y) as y') t = + let rec get_relations (((var_x,o_x,d_x), x_val) as x') (((var_y,o_y,d_y), y_val) as y') t = match var_x, var_y with | Some (c_x, x), Some (c_y, y) -> if x > y then (*We save information only in one of the directions -> check the other one*) List.map Relation.invert @@ get_relations y' x' t else begin - if M.tracing then M.trace "is_less_than" "checking x': %s, y': %s" (Rhs.show @@ fst x') (Rhs.show @@ fst y'); + if M.tracing then M.trace "get_relations" "checking x': %s, y': %s" (Rhs.show @@ fst x') (Rhs.show @@ fst y'); match get_coeff x y t with - | None -> begin if M.tracing then M.trace "is_less_than" "no inequality for roots"; [] end (*No information*) - | Some coeff -> (*TODO should we check all inequalities here? how could we do that*) - let (a,b,c_rhs) = Coeffs.coeffs_from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) in - let upper_bound = match Coeffs.CoeffMap.find_opt (a,b) coeff with + | None -> begin if M.tracing then M.trace "get_relations" "no inequality for roots"; [] end (*No information*) + | Some coeff -> + let interval_ineqs = LinearInequality.from_values x_val y_val in + let coeff = List.fold (fun t (k,c) -> Coeffs.add_inequality k c t) coeff interval_ineqs in + let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) in + let factor = (*we need to muliply c' with this factor because LinearInequalities scales them down*) + let a = Q.make c_x d_x in + let b = Q.make c_y d_y in + if Q.equal b Q.zero then a else b + in + let upper_bound = match Coeffs.get_best_offset k coeff with | None -> [] | Some c_ineq -> - let c' = Q.sub c_ineq c_rhs in + let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in [Relation.Lt, Z.fdiv (Q.num c') (Q.den c')] - in match Coeffs.CoeffMap.find_opt (Q.neg a, Q.neg b) coeff with (*lower bound*) + in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> - let c' = Q.neg ( Q.add c_ineq c_rhs) in + let c' = Q.mul factor @@ Q.neg ( Q.add c_ineq c_rhs) in (Gt, Z.cdiv (Q.num c') (Q.den c')) :: upper_bound end | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) @@ -842,26 +1144,34 @@ module LinearInequalities: TwoVarInequalities = struct let coeffs = match get_coeff x y t with | None -> Coeffs.empty | Some c -> c - in let (a,b,c_rhs) = Coeffs.coeffs_from_rhss rhs_x rhs_y - in let meet_relation_roots (a,b) c t = - if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s var_%d < %s var_%d + %s" (Q.to_string a) x (Q.to_string b) y (Q.to_string c); + in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y + in let meet_relation_roots k c t = + if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); (*do not save inequalities refering to the same variable*) if x = y then - if a = b then + let s = Coeffs.Key.get_slope k in + if Q.equal Q.one s then (* x < x + c*) if Q.leq c Q.zero then raise EConj.Contradiction else t, [] (*trivially true*) - else (*refine the value in this case*) - let ab = Q.sub a b in - if Q.gt ab Q.zero then - let max = Q.sub (Q.div c ab) Q.one in + else (* sx < x + c (or >) -> refine the value in this case*) + let s' = Q.sub s Q.one in + let s', c' = match k with LT _ -> s',c | GT _ -> Q.neg s', Q.neg c in + (*s'x < c' *) + if Q.gt s' Q.zero then + let max = Q.sub (Q.div c' s') Q.one in t, [x, Value.ending @@ Z.cdiv (Q.num max) (Q.den max)] else - let min = Q.add (Q.div c ab) Q.one in + let min = Q.add (Q.div c' s') Q.one in t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] - else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) (a,b) c t + else Coeffs.limit @@ Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t + in let factor = (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) + let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in + let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in + if Q.equal b Q.zero then a else b + (*TODO: transfer some transitivity, similar to the simple inequalities*) in let (new_coeffs, refine_acc) = match cond with - | Relation.Lt, o -> meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint o) coeffs - | Gt, o -> meet_relation_roots (Q.neg a ,Q.neg b) (Q.neg @@ (Q.add c_rhs @@ Q.of_bigint o)) coeffs + | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q. div (Q.of_bigint o) factor) coeffs + | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q. div (Q.of_bigint o) factor) ) coeffs | Eq, o -> coeffs, [] (*TODO: I think this should always be stored by the lin2vareq domain (at least the way we are generating this information) (*meet with < +1 und > -1*) @@ -878,46 +1188,84 @@ module LinearInequalities: TwoVarInequalities = struct if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (List.fold (fun acc (var,value) -> Printf.sprintf "var_%d: %s, %s" var (Value.show value) acc) "" refine_acc); res, refine_acc - (*TODO very similar to simple equalities -> generalise?*) - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - let get_old_condition x y = - let get_information lhs = - let rhs = get_rhs_old lhs in - match rhs with - | (Some (_,var), _ ,_) -> (rhs, get_value_old var) - (*We need to know which root a constant is referring to, so we use the trivial equation to carry that information*) - | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) + (*TODO we programmed this slightly different to EConj: this expects the rhs to be inverted, EConj does it itself *) + (*this is now used in other places where i think this way is correct -> name it inverse_affine_transform? *) + let affine_transform t i (coeff, j, offs, divi) = + let fold_x x ys acc = + if x < i then + let ys' = match IntMap.find_opt i ys with + | None -> ys + | Some cs -> + let cs' = Coeffs.affine_transform_right (coeff, offs, divi) cs in + let combine = function + | None -> Some cs' + | Some cs_j -> Some (Coeffs.meet Value.top Value.top cs' cs_j) + in IntMap.update_stdlib j combine ys + in IntMap.add x ys' acc + else if x = i then + let ys' = IntMap.filter_map (fun y cs -> if y = j then None else Some (Coeffs.affine_transform_left (coeff, offs, divi) cs)) ys in + if IntMap.is_empty ys' then + acc + else + let combine = function + | None -> Some ys' + | Some js -> Some (IntMap.union (fun y c1 c2 -> Some (Coeffs.meet Value.top Value.top c1 c2)) ys' js) + in IntMap.update_stdlib j combine acc + else + acc + in IntMap.fold fold_x t IntMap.empty + + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + match get_rhs_old x, get_rhs x with + | (Some (coeff_old,x_root_old), off_old, divi_old), ((Some (coeff,x_root), off, divi) as rhs) -> + (*convert the relation to a linear inequality refering to the old root *) + let (k,c) = LinearInequality.from_rhss (coeff_old, off_old, divi_old) (coeff_old, off_old, divi_old) + in let factor = Q.make coeff_old divi_old (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) + in let ineq_from_cond = match cond with + | Relation.Lt, o -> k, (Q.add c @@ Q. div (Q.of_bigint o) factor) + | Gt, o -> (Coeffs.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) + | Eq, o -> undefined "TODO" (*Should we exclude EQ from relation?*) in - get_relations (get_information x) (get_information y) t_old - in let vars_to_check = - let root = match get_rhs_old x with - | (Some (_,var), _ ,_) -> var - | (_,o,_) -> x - (*we need to check all y with root -> y -> coeff or y -> root -> coeff*) - (*TODO we know all vars greater than y can not contain y *) - in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) - in let transfer_single_condition y t' old_cond = - match Relation.combine cond old_cond with - | Some new_cond -> - if M.tracing then M.tracel "transfer" "combined %s , %s -> %s" (Relation.show (Int.to_string x_new) cond (Int.to_string x) ) (Relation.show (Int.to_string x) old_cond (Int.to_string y) ) (Relation.show (Int.to_string x_new) new_cond (Int.to_string y) ); - fst @@ meet_relation x_new y new_cond get_rhs get_value t' - | None -> t' - in let transfer_single_var t' y = List.fold (transfer_single_condition y ) t' (get_old_condition x y) - in BatEnum.fold (transfer_single_var) t vars_to_check - - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t); - let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + in + (*combine the inequality from cond with all inequalities*) + (*throw out all inequalities that do not contain the representative of x*) + let combine_1 v1 v2s = + if v1 = x_root_old then ignore_empty @@ IntMap.filter_map (fun _ c -> Coeffs.combine_left ineq_from_cond c) v2s + else + let combine_2 v2 c = if v2 = x_root_old then Coeffs.combine_right ineq_from_cond c else None in + ignore_empty @@ IntMap.filter_map combine_2 v2s + in + let filtered = IntMap.filter_map combine_1 t_old in + (*transform all inequalities to refer to new root of x*) + (*invert old rhs, then substitute the new rhs for x*) + let (m, o, d) = Rhs.subst rhs x @@ snd @@ EConj.inverse x (coeff_old,x_root_old, off_old, divi_old) in + let c, v = BatOption.get m in + let transformed = affine_transform filtered x_root (c, v, o, d) in + (*meet with this set of equations*) + meet get_value t transformed + | _,_ -> t (*ignore constants*) + + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s" (Relation.show ("var_" ^ Int.to_string x ^ "_old") cond ("var_" ^ Int.to_string x ^ "_new") ) (show t_old) (show t); + let res = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in if M.tracing then M.tracel "transfer" "result: %s" (show res); res + end (*TODOs:*) +(*relation to offset domain *) +(*transfer: allow RHS for more information transfer!*) +(*rework transfer: allow affine transfer, look at complexities*) +(*limit in ArbitraryCoeaffsList*) +(*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*adapt simple equalities to take advantage of the offset!*) (*domain inbetween these two: with offset between roots? -> should be trivial to implement*) (*what is required of narrow?*) -(*limit in ArbitraryCoeaffsList*) -(*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*widening thresholds: from offsets of rhs?*) +(*general renaming*) (*rebase to main branch*) \ No newline at end of file From 7ae6ddadd7f0eb68a2dde6990e1bdaf94443ddf9 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 10 Apr 2025 13:41:58 +0200 Subject: [PATCH 42/86] first round of fixes --- .../apron/pentagonSubDomains.apron.ml | 40 ++++++++++++++----- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 4a381ba29a..e2e5c78dd0 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1119,7 +1119,7 @@ module LinearInequalities: TwoVarInequalities = struct in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> - let c' = Q.mul factor @@ Q.neg ( Q.add c_ineq c_rhs) in + let c' = Q.mul factor ( Q.add c_ineq c_rhs) in (Gt, Z.cdiv (Q.num c') (Q.den c')) :: upper_bound end | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) @@ -1150,9 +1150,10 @@ module LinearInequalities: TwoVarInequalities = struct (*do not save inequalities refering to the same variable*) if x = y then let s = Coeffs.Key.get_slope k in - if Q.equal Q.one s then (* x < x + c*) - if Q.leq c Q.zero then raise EConj.Contradiction - else t, [] (*trivially true*) + if Q.equal Q.one s then (* x < x + c (or >) *) + match k with + | LT _ -> if Q.leq c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GT _ -> if Q.geq c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) else (* sx < x + c (or >) -> refine the value in this case*) let s' = Q.sub s Q.one in let s', c' = match k with LT _ -> s',c | GT _ -> Q.neg s', Q.neg c in @@ -1192,18 +1193,35 @@ module LinearInequalities: TwoVarInequalities = struct (*this is now used in other places where i think this way is correct -> name it inverse_affine_transform? *) let affine_transform t i (coeff, j, offs, divi) = let fold_x x ys acc = + let check_for_contradiction cs = (*TODO value refinement?*) + let check_single k c = + match k with + | Coeffs.Key.LT s -> if Q.leq c Q.zero then raise EConj.Contradiction + | GT s -> if Q.geq c Q.zero then raise EConj.Contradiction + in Coeffs.CoeffMap.iter check_single cs + in if x < i then let ys' = match IntMap.find_opt i ys with - | None -> ys + | None -> Some ys | Some cs -> let cs' = Coeffs.affine_transform_right (coeff, offs, divi) cs in - let combine = function - | None -> Some cs' - | Some cs_j -> Some (Coeffs.meet Value.top Value.top cs' cs_j) - in IntMap.update_stdlib j combine ys - in IntMap.add x ys' acc + if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictions*) + (check_for_contradiction cs'; None) + else + let combine = function + | None -> Some cs' + | Some cs_j -> Some (Coeffs.meet Value.top Value.top cs' cs_j) + in Some (IntMap.update_stdlib j combine ys) + in match ys' with + | Some ys' -> IntMap.add x ys' acc + | _ -> acc else if x = i then - let ys' = IntMap.filter_map (fun y cs -> if y = j then None else Some (Coeffs.affine_transform_left (coeff, offs, divi) cs)) ys in + let convert y cs = + let tranformed = Coeffs.affine_transform_left (coeff, offs, divi) cs in + if y = j + then (check_for_contradiction tranformed; None) + else Some tranformed + in let ys' = IntMap.filter_map convert ys in if IntMap.is_empty ys' then acc else From f42c06692486974913d2495bb9274f0b726efdce Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Thu, 10 Apr 2025 15:06:18 +0200 Subject: [PATCH 43/86] second round of fixes --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 6 +++--- src/cdomains/apron/pentagonSubDomains.apron.ml | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index f6d9186a06..e660b21832 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -299,9 +299,9 @@ struct let c,v = BatOption.get m in (EConj.affine_transform econ i rhs, vs, Ineq.affine_transform ineq i (c,v,o,d)) - let affine_transform econ i rhs = - let res = affine_transform econ i rhs in - if M.tracing then M.tracel "affine_transform" "affine_transform %s -> %s " (show econ) (show res); + let affine_transform econ i (c,v,o,d) = + let res = affine_transform econ i (c,v,o,d) in + if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); res let meet_with_one_value var value t narrow = diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index e2e5c78dd0..8fdffc54d7 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -769,10 +769,10 @@ module LinearInequality = struct in let ineqs = match Value.minimal x_val with | Some (Int z) -> (*x >= z *) (GT Q.inf, Q.of_bigint @@ Z.add Z.minus_one z) :: ineqs | _ -> ineqs - in let ineqs = match Value.maximal x_val with + in let ineqs = match Value.maximal y_val with | Some (Int z) -> (*y <= z *) (GT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.one z ) :: ineqs | _ -> ineqs - in let ineqs = match Value.minimal x_val with + in let ineqs = match Value.minimal y_val with | Some (Int z) -> (*y >= z *) (LT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.minus_one z ) :: ineqs | _ -> ineqs in ineqs @@ -1211,7 +1211,7 @@ module LinearInequalities: TwoVarInequalities = struct let combine = function | None -> Some cs' | Some cs_j -> Some (Coeffs.meet Value.top Value.top cs' cs_j) - in Some (IntMap.update_stdlib j combine ys) + in Some (IntMap.update_stdlib j combine (IntMap.remove i ys)) in match ys' with | Some ys' -> IntMap.add x ys' acc | _ -> acc From 9b521db3a8f94809019c6fe43b30b7cb29c5d77c Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 13:36:43 +0200 Subject: [PATCH 44/86] make it non-strict equalities --- .../apron/pentagonSubDomains.apron.ml | 74 +++++++++++++------ 1 file changed, 52 insertions(+), 22 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 8fdffc54d7..e934494a3f 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -672,7 +672,7 @@ let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) module LinearInequality = struct (*Normalised representation of an inequality through the origin - a/b x < y (or >) bzw. slope and direction. infinite slope represents 0 < x / 0 > x*) + a/b x <= y (or >=) bzw. slope and direction. infinite slope represents 0 <= x / 0 >= x*) module OriginInequality = struct (*Separate module so we can use it as key in a map*) type t = LT of Q.t | GT of Q.t @@ -705,9 +705,27 @@ module LinearInequality = struct (*add an offset to the inequalities*) type t = OriginInequality.t * Q.t [@@deriving eq] - let show x y (k,c) = Printf.sprintf "%s %s %s %s %s + %s" (Z.to_string @@ Q.num @@ OriginInequality.get_slope k ) x (match k with LT _ -> "<" | GT _ -> ">") (Z.to_string @@ Q.den @@ OriginInequality.get_slope k ) y (Q.to_string c) - - (*Convert into coefficients of inequality ax + by < c + let show x y (k,c) = + let show_var coeff var show_zero = + let open Z in + if coeff = zero then (if show_zero then "0 " else "") + else if coeff = one then var ^ " " + else to_string coeff ^ var ^ " " + in + let show_offset o = + let open Q in + if o = zero then "" + else if o > zero then "+ " ^ to_string o + else "- " ^ to_string (abs o) + in + let s = OriginInequality.get_slope k in + Printf.sprintf "%s%s %s%s" + (show_var (Q.num s) x true) + (match k with LT _ -> "<=" | GT _ -> ">=") + (show_var (Q.den s) y false) + (show_offset @@ if Q.equal s Q.inf then c else Q.mul c @@ Q.of_bigint @@ Q.den s ) + + (*Convert into coefficients of inequality ax + by <= c Useful because the TVLI paper (DOI: 10.1007/3-540-45013-0_7) uses this representation *) let to_coeffs = function | OriginInequality.LT s, c when Q.equal s Q.inf -> (Q.one,Q.zero,c) @@ -715,6 +733,11 @@ module LinearInequality = struct | LT s, c -> (s,Q.minus_one,c) | GT s, c -> (Q.neg s, Q.one, Q.neg c) + let to_coeffs t = + let a,b,c as res = to_coeffs t in + if M.tracing then M.trace "entails" "slope %s, whole: %s -> %s,%s,%s" (Q.to_string @@ OriginInequality.get_slope @@ fst t) (show "x" "y" t) (Q.to_string a) (Q.to_string b) (Q.to_string c); + res + (*From TVLI: check if one or two inequalities imply an inequality*) let entails1 (s1,c1) (s2,c2) = OriginInequality.equal s1 s2 && match s1 with LT _ -> Q.leq c1 c2 | GT _ -> Q.geq c1 c2 @@ -727,6 +750,7 @@ module LinearInequality = struct let (a1,b1,c1) = to_coeffs t1 in let (a2,b2,c2) = to_coeffs t2 in let (a ,b ,c ) = to_coeffs t in + if M.tracing then M.trace "entails" "coeffs: %s,%s,%s %s,%s,%s %s,%s,%s" (Q.to_string a1) (Q.to_string b1) (Q.to_string c1) (Q.to_string a2) (Q.to_string b2) (Q.to_string c2) (Q.to_string a) (Q.to_string b) (Q.to_string c); let open Q in let d = a1 * b2 - a2 * b1 in if equal d zero then @@ -764,22 +788,22 @@ module LinearInequality = struct let from_values x_val y_val = let open OriginInequality in let ineqs = match Value.maximal x_val with - | Some (Int z) -> (*x <= z *) [LT Q.inf, Q.of_bigint @@ Z.add Z.one z] + | Some (Int z) -> (*x <= z *) [LT Q.inf, Q.of_bigint z] | _ -> [] in let ineqs = match Value.minimal x_val with - | Some (Int z) -> (*x >= z *) (GT Q.inf, Q.of_bigint @@ Z.add Z.minus_one z) :: ineqs + | Some (Int z) -> (*x >= z *) (GT Q.inf, Q.of_bigint z) :: ineqs | _ -> ineqs in let ineqs = match Value.maximal y_val with - | Some (Int z) -> (*y <= z *) (GT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.one z ) :: ineqs + | Some (Int z) -> (*y <= z *) (GT Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs | _ -> ineqs in let ineqs = match Value.minimal y_val with - | Some (Int z) -> (*y >= z *) (LT Q.zero, Q.neg @@ Q.of_bigint @@ Z.add Z.minus_one z ) :: ineqs + | Some (Int z) -> (*y >= z *) (LT Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs | _ -> ineqs in ineqs (*Convert two righthandsides into an inequality*) let from_rhss (cx, ox, dx) (cy, oy, dy) = - let a,b,c = (Q.make cx dx, Q.make cy dy, Q.sub (Q.make oy dy) (Q.make ox dx)) in + let a,b,c = (Q.make cx dx, Q.make cy dy, Q.sub (Q.sub (Q.make oy dy) (Q.make ox dx)) Q.one) in (*subtracting one to convert it into a nonstrict inequality*) let s = Q.div a b in if Q.equal b Q.zero then OriginInequality.norm (LT s), Q.div c a @@ -804,7 +828,7 @@ module LinearInequality = struct let s = get_slope k in let f = Q.make coeff divi in let s' = Q.div s f in - let o' = Q.add o @@ Q.make offs coeff in + let o' = Q.add (Q.div o f) @@ Q.make offs coeff in let k' = match k with | LT _ -> LT s' | GT _ -> GT s' @@ -989,7 +1013,8 @@ module ArbitraryCoeffsSet = struct | Some t -> t in let interval_ineqs = LinearInequality.from_values x_val y_val in let t1 = List.fold (fun t (k,c) -> add_inequality k c t) t1 interval_ineqs (*makes this O(n log n) instead of O(n)*) - in if CoeffMap.is_empty t2 then true + in if M.tracing then M.trace "implies" "after adding intervals: %s" (show_formatted "x" "y" t1); + if CoeffMap.is_empty t2 then true else if CoeffMap.is_empty t1 then false else(*functional version of the entailment check from TVLI*) let ts1 = CoeffMap.bindings t1 in @@ -1115,12 +1140,12 @@ module LinearInequalities: TwoVarInequalities = struct | None -> [] | Some c_ineq -> let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in - [Relation.Lt, Z.fdiv (Q.num c') (Q.den c')] + [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to convert from a strict to an nonstrict inequality*) in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> let c' = Q.mul factor ( Q.add c_ineq c_rhs) in - (Gt, Z.cdiv (Q.num c') (Q.den c')) :: upper_bound + (Gt, Z.add Z.minus_one @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound end | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) @@ -1150,19 +1175,19 @@ module LinearInequalities: TwoVarInequalities = struct (*do not save inequalities refering to the same variable*) if x = y then let s = Coeffs.Key.get_slope k in - if Q.equal Q.one s then (* x < x + c (or >) *) + if Q.equal Q.one s then (* x <= x + c (or >=) *) match k with - | LT _ -> if Q.leq c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - | GT _ -> if Q.geq c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - else (* sx < x + c (or >) -> refine the value in this case*) + | LT _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GT _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + else (* sx <= x + c (or =>) -> refine the value in this case*) let s' = Q.sub s Q.one in let s', c' = match k with LT _ -> s',c | GT _ -> Q.neg s', Q.neg c in - (*s'x < c' *) + (*s'x <= c' *) if Q.gt s' Q.zero then - let max = Q.sub (Q.div c' s') Q.one in + let max = Q.div c' s' in t, [x, Value.ending @@ Z.cdiv (Q.num max) (Q.den max)] else - let min = Q.add (Q.div c' s') Q.one in + let min = Q.div c' s' in t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] else Coeffs.limit @@ Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t in let factor = (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) @@ -1196,8 +1221,8 @@ module LinearInequalities: TwoVarInequalities = struct let check_for_contradiction cs = (*TODO value refinement?*) let check_single k c = match k with - | Coeffs.Key.LT s -> if Q.leq c Q.zero then raise EConj.Contradiction - | GT s -> if Q.geq c Q.zero then raise EConj.Contradiction + | Coeffs.Key.LT s -> if Q.lt c Q.zero then raise EConj.Contradiction + | GT s -> if Q.gt c Q.zero then raise EConj.Contradiction in Coeffs.CoeffMap.iter check_single cs in if x < i then @@ -1233,6 +1258,11 @@ module LinearInequalities: TwoVarInequalities = struct acc in IntMap.fold fold_x t IntMap.empty + let affine_transform t i (c,j,o,d) = + let res = affine_transform t i (c,j,o,d) in + if M.tracing then M.trace "affine_transform" "transforming var_%d in %s with %s -> %s" i (show t) (Rhs.show (Some (c,j), o, d)) (show res); + res + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = match get_rhs_old x, get_rhs x with | (Some (coeff_old,x_root_old), off_old, divi_old), ((Some (coeff,x_root), off, divi) as rhs) -> From 457ec76c0118f4956b228ee14cbec9f109ca42df Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 14:06:27 +0200 Subject: [PATCH 45/86] missed value refinement --- conf/svcomp25.json | 1 - .../apron/pentagonSubDomains.apron.ml | 34 +++++++++---------- 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/conf/svcomp25.json b/conf/svcomp25.json index dedc393ba1..003e3885fa 100644 --- a/conf/svcomp25.json +++ b/conf/svcomp25.json @@ -65,7 +65,6 @@ "congruence", "octagon", "wideningThresholds", - "loopUnrollHeuristic", "memsafetySpecification", "noOverflows", "termination", diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index e934494a3f..c47d3f5746 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -941,19 +941,19 @@ module ArbitraryCoeffsSet = struct let round_up q = Z.cdiv (Q.num q) (Q.den q) in let round_down q = Z.fdiv (Q.num q) (Q.den q) in let x_refine = - let upper_bound s = (*x < y / s + c / s*) + let upper_bound s = (*x <= y / s + c / s*) let max_y = match Value.maximal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_y with - | Int max -> [x, Value.ending @@ Z.add Z.minus_one @@ Z.add max @@ round_up @@ Q.div c s] + | Int max -> [x, Value.ending @@ Z.add max @@ round_up @@ Q.div c s] | _ -> [] - in let lower_bound s = (*x > y / s + c / s*) + in let lower_bound s = (*x >= y / s + c / s*) let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_y with - | Int min -> [x, Value.starting @@ Z.add Z.one @@ Z.add min @@ round_down @@ Q.div c s] + | Int min -> [x, Value.starting @@ Z.add min @@ round_down @@ Q.div c s] | _ -> [] in match k with @@ -964,38 +964,38 @@ module ArbitraryCoeffsSet = struct | _ -> [] (*Should never be used in this case*) in let y_refine = match k with - | LT s -> begin (*sx -c < y*) + | LT s -> begin (*sx -c <= y*) let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_x with - | Int min -> [y, Value.starting @@ Z.add Z.one @@ Z.sub min @@ round_up c] + | Int min -> [y, Value.starting @@ Z.sub min @@ round_up c] | _ -> [] end - | GT s -> (*s x - c > y*) + | GT s -> (*s x - c >= y*) let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_x with - | Int max -> [y, Value.ending @@ Z.add Z.minus_one @@ Z.sub max @@ round_down c] + | Int max -> [y, Value.ending @@ Z.sub max @@ round_down c] | _ -> [] in match k with - | LT s when Q.equal Q.zero s -> (* -c > y *) [y, Value.ending @@ Z.add Z.minus_one @@ round_up @@ Q.neg c] , true - | GT s when Q.equal Q.zero s -> (* -c < y *) [y, Value.starting @@ Z.add Z.one @@ round_down @@ Q.neg c] , true - | LT s when Q.equal Q.inf s -> (*x > c*) [x, Value.starting @@ Z.add Z.one @@ round_down c ], true - | GT s when Q.equal Q.minus_inf s -> (*x > c*) [x, Value.starting @@ Z.add Z.one @@ round_down c ], true - | LT s when Q.equal Q.minus_inf s -> (*x < c*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up c], true - | GT s when Q.equal Q.inf s -> (*x < c*) [x, Value.ending @@ Z.add Z.minus_one @@ round_up c], true + | LT s when Q.equal Q.zero s -> (* -c >= y *) [y, Value.ending @@ round_up @@ Q.neg c] , true + | GT s when Q.equal Q.zero s -> (* -c <= y *) [y, Value.starting @@ round_down @@ Q.neg c] , true + | LT s when Q.equal Q.inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true + | GT s when Q.equal Q.minus_inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true + | LT s when Q.equal Q.minus_inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true + | GT s when Q.equal Q.inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true | k -> (*an actual inequality *) x_refine @ y_refine, false in if skip_adding then t, refinements else (*Look for contradicting inequality*) let contradicts c' = match k with - | LT _ -> Q.geq c' @@ Q.sub c Q.one - | GT _ -> Q.leq c' @@ Q.add c Q.one + | LT _ -> Q.geq c' c + | GT _ -> Q.leq c' c in match get_best_offset (Key.negate k) t with | Some c' when contradicts c' -> raise EConj.Contradiction - (*TODO if c = c' + 2 , then we have an equality -> maybe we can update the econj domain *) + (*TODO if c = c', then we have an equality -> maybe we can update the econj domain *) | _ -> (*add the inequality, while making sure that we do not save redundant inequalities*) (*TODO make this consider the intervals! -> adapt get_next and get_previous?*) From e309216f92bae2abca4883e72d2b638fc601b893 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 16:37:41 +0200 Subject: [PATCH 46/86] more off-by-one errors --- conf/svcomp25.json | 1 + .../apron/pentagonSubDomains.apron.ml | 34 ++++++++----------- 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/conf/svcomp25.json b/conf/svcomp25.json index 003e3885fa..dedc393ba1 100644 --- a/conf/svcomp25.json +++ b/conf/svcomp25.json @@ -65,6 +65,7 @@ "congruence", "octagon", "wideningThresholds", + "loopUnrollHeuristic", "memsafetySpecification", "noOverflows", "termination", diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index c47d3f5746..45dbf8d7e6 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -722,7 +722,7 @@ module LinearInequality = struct Printf.sprintf "%s%s %s%s" (show_var (Q.num s) x true) (match k with LT _ -> "<=" | GT _ -> ">=") - (show_var (Q.den s) y false) + (show_var (Q.den s) y (Q.equal c Q.zero)) (show_offset @@ if Q.equal s Q.inf then c else Q.mul c @@ Q.of_bigint @@ Q.den s ) (*Convert into coefficients of inequality ax + by <= c @@ -801,9 +801,10 @@ module LinearInequality = struct | _ -> ineqs in ineqs - (*Convert two righthandsides into an inequality*) - let from_rhss (cx, ox, dx) (cy, oy, dy) = - let a,b,c = (Q.make cx dx, Q.make cy dy, Q.sub (Q.sub (Q.make oy dy) (Q.make ox dx)) Q.one) in (*subtracting one to convert it into a nonstrict inequality*) + (*Convert two righthandsides into an inequality isLessThan is the direction of the inequality and needed for making the inequality non-strict while we still know that all variables are integers*) + let from_rhss (cx, ox, dx) (cy, oy, dy) isLessThan_opt = + let non_strict_offset = match isLessThan_opt with None -> Q.zero | Some isLessThan -> if isLessThan then Q.minus_one else Q.one in + let a,b,c = (Q.make cx dx, Q.make cy dy, Q.add non_strict_offset @@ Q.sub (Q.make oy dy) (Q.make ox dx)) in (*subtracting one to convert it into a nonstrict inequality*) let s = Q.div a b in if Q.equal b Q.zero then OriginInequality.norm (LT s), Q.div c a @@ -946,7 +947,7 @@ module ArbitraryCoeffsSet = struct | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_y with - | Int max -> [x, Value.ending @@ Z.add max @@ round_up @@ Q.div c s] + | Int max -> [x, Value.ending @@ Z.add max @@ round_up @@ Q.div c s] (*TODO I'm not sure anymore: why are we rounding up?*) | _ -> [] in let lower_bound s = (*x >= y / s + c / s*) let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with @@ -990,8 +991,8 @@ module ArbitraryCoeffsSet = struct in if skip_adding then t, refinements else (*Look for contradicting inequality*) let contradicts c' = match k with - | LT _ -> Q.geq c' c - | GT _ -> Q.leq c' c + | LT _ -> Q.gt c' c + | GT _ -> Q.lt c' c in match get_best_offset (Key.negate k) t with | Some c' when contradicts c' -> raise EConj.Contradiction @@ -1130,7 +1131,7 @@ module LinearInequalities: TwoVarInequalities = struct | Some coeff -> let interval_ineqs = LinearInequality.from_values x_val y_val in let coeff = List.fold (fun t (k,c) -> Coeffs.add_inequality k c t) coeff interval_ineqs in - let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) in + let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) None in let factor = (*we need to muliply c' with this factor because LinearInequalities scales them down*) let a = Q.make c_x d_x in let b = Q.make c_y d_y in @@ -1140,7 +1141,7 @@ module LinearInequalities: TwoVarInequalities = struct | None -> [] | Some c_ineq -> let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in - [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to convert from a strict to an nonstrict inequality*) + [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> @@ -1169,7 +1170,7 @@ module LinearInequalities: TwoVarInequalities = struct let coeffs = match get_coeff x y t with | None -> Coeffs.empty | Some c -> c - in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y + in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y (Some (match fst cond with Relation.Lt -> true | _ -> false)) in let meet_relation_roots k c t = if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); (*do not save inequalities refering to the same variable*) @@ -1196,14 +1197,9 @@ module LinearInequalities: TwoVarInequalities = struct if Q.equal b Q.zero then a else b (*TODO: transfer some transitivity, similar to the simple inequalities*) in let (new_coeffs, refine_acc) = match cond with - | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q. div (Q.of_bigint o) factor) coeffs - | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q. div (Q.of_bigint o) factor) ) coeffs - | Eq, o -> coeffs, [] - (*TODO: I think this should always be stored by the lin2vareq domain (at least the way we are generating this information) - (*meet with < +1 und > -1*) - if M.tracing then M.tracel "meet_relation" "meeting equality!"; - meet_relation_roots (a,b) (Q.add c_rhs @@ Q.of_bigint @@ Z.add Z.one o) @@ - meet_relation_roots (Q.neg a ,Q.neg b) (Q.neg @@ (Q.add c_rhs @@ Q.of_bigint @@ Z.add Z.minus_one o)) coeffs*) + | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q.div (Q.of_bigint o) factor) coeffs + | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q.div (Q.of_bigint o) factor) ) coeffs + | Eq, o -> coeffs, [] (*This should always be stored by the lin2vareq domain (at least the way we are generating this information)*) in if Coeffs.CoeffMap.is_empty new_coeffs then remove_coeff x y t , refine_acc else set_coeff x y new_coeffs t, refine_acc @@ -1267,7 +1263,7 @@ module LinearInequalities: TwoVarInequalities = struct match get_rhs_old x, get_rhs x with | (Some (coeff_old,x_root_old), off_old, divi_old), ((Some (coeff,x_root), off, divi) as rhs) -> (*convert the relation to a linear inequality refering to the old root *) - let (k,c) = LinearInequality.from_rhss (coeff_old, off_old, divi_old) (coeff_old, off_old, divi_old) + let (k,c) = LinearInequality.from_rhss (coeff_old, off_old, divi_old) (coeff_old, off_old, divi_old) (Some (match fst cond with Relation.Lt -> true | _ -> false)) in let factor = Q.make coeff_old divi_old (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) in let ineq_from_cond = match cond with | Relation.Lt, o -> k, (Q.add c @@ Q. div (Q.of_bigint o) factor) From 7e297204df004700d405fbef5961e819cba6d68c Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 20:59:11 +0200 Subject: [PATCH 47/86] fix widening (and leq?) --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 10 +++++++++- src/cdomains/apron/pentagonSubDomains.apron.ml | 14 +++++++------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index e660b21832..222395f4be 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -883,9 +883,17 @@ struct else if is_bot_env t2 || is_top t1 then false else let m1, (econ2, vs2, ineq2) = Option.get t1.d, Option.get t2.d in let (econ1, _, ineq1) as m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in + (*If econ1 has some representants that are not representants in econ2, we need to transform the inequalities *) + let transform_non_representant var (m,o,d) ineq_acc = + let (c,v) = BatOption.get m in + if not @@ EConj.nontrivial econ1 var then + Ineq.affine_transform ineq_acc var (c,v,o,d) + else ineq_acc + in + let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) && IntMap.for_all (implies_value m1') (vs2) - && Ineq.leq ineq1 (EConjI.get_value m1') ineq2 + && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 let leq a b = timing_wrap "leq" (leq a) b diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 45dbf8d7e6..21f18433c0 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1058,13 +1058,13 @@ module ArbitraryCoeffsSet = struct (* we make two passes over the list: first the relaxation, then adding all other inequalities*) (* this prevents an inequality from being deemed redundant by an inequality that is later relaxed*) (* TODO: test if this increased precision is worth the time?*) - let relax k c2 (t1, t2) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) - match CoeffMap.find_opt k t1 with - | None -> (t1, t2) - | Some c1 when Q.equal c1 c2 -> (t1, CoeffMap.remove k t2) - | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) && widen-> (CoeffMap.remove k t1, CoeffMap.remove k t2) (*t2 has more relaxed bound -> do widening*) - | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1, CoeffMap.remove k t2) (*t2 has more relaxed bound*) - | Some c1 -> (t1, CoeffMap.remove k t2) (*last remaining case: t1 has more relaxed bound*) + let relax k c2 (t1_f, t2_f) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) + match CoeffMap.find_opt k t1 with (*look up in original t1 so that we can take care of widening for inequalities that get filtered*) + | None -> (t1_f, t2_f) + | Some c1 when Q.equal c1 c2 -> (t1_f, CoeffMap.remove k t2_f) + | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) && widen-> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound -> do widening*) + | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound*) + | Some c1 -> (t1_f, CoeffMap.remove k t2_f) (*last remaining case: t1 has more relaxed bound*) in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) in let merged = CoeffMap.fold add_inequality t2_filtered' t1_filtered' (*remove the explicetly stored interval inequalities*) From 2d722694b662794f29997d6c8c1010110a30c588 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 21:35:45 +0200 Subject: [PATCH 48/86] leq fixed now? --- .../linearTwoVarEqualityDomainPentagon.apron.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 222395f4be..5ae70eb7aa 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -885,12 +885,16 @@ struct let (econ1, _, ineq1) as m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in (*If econ1 has some representants that are not representants in econ2, we need to transform the inequalities *) let transform_non_representant var (m,o,d) ineq_acc = - let (c,v) = BatOption.get m in - if not @@ EConj.nontrivial econ1 var then - Ineq.affine_transform ineq_acc var (c,v,o,d) - else ineq_acc + match m with + | None -> ineq_acc + | Some (c,v) -> + if M.tracing then M.trace "leq" "econ2 not representant: %s with rhs: %s" (Var.show @@ Environment.var_of_dim t2.env var) (Rhs.show (m,o,d)); + match EConj.get_rhs econ1 var with + | Some (_,v),_,_ when v <> var -> (if M.tracing then M.trace "leq" "and not representant in econ1 -> do nothing"); ineq_acc + | _ -> (if M.tracing then M.trace "leq" "and not representant in econ1 -> transform"); Ineq.affine_transform ineq_acc var (c,v,o,d) in let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in + if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) && IntMap.for_all (implies_value m1') (vs2) && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 From 2cba0cf0c26f8013caa3deb5dda53814ecf61817 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 11 Apr 2025 22:36:53 +0200 Subject: [PATCH 49/86] another fix for leq where different kinds of bot did not return the correct result --- src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 5ae70eb7aa..8beb12c71a 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -878,6 +878,7 @@ struct in let implies_value v i value = Value.leq (EConjI.get_value v i) value in + if BatOption.is_none t1.d then true else (*This kind of bot does not require the environment to be a superset*) if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true else if is_bot_env t2 || is_top t1 then false else From 0d22d783b99512fa7020ec857d01681875897f32 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 26 Apr 2025 14:36:18 +0200 Subject: [PATCH 50/86] join implement splitting --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 53 +++-- .../apron/pentagonSubDomains.apron.ml | 221 ++++++++++++++---- .../82-lin2vareq_p/37-intervals_propagation.c | 6 +- .../82-lin2vareq_p/38-simple_congruence.c | 10 +- .../39-congruence_from_equation.c | 4 +- .../82-lin2vareq_p/40-join-splitting-group.c | 41 ++++ 6 files changed, 254 insertions(+), 81 deletions(-) create mode 100644 tests/regression/82-lin2vareq_p/40-join-splitting-group.c diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 8beb12c71a..5788d8c0b1 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -200,7 +200,7 @@ struct | None -> (econj'', vs'', Ineq.forget_variable ineq' var) | Some (Some (coeff,y),offs,divi) -> (*modify inequalities*) - let ineq'' = Ineq.affine_transform ineq' var (coeff,y,offs,divi) + let ineq'' = Ineq.substitute ineq' var (coeff,y,offs,divi) (*restoring value information*) in set_value (econj'', vs'', ineq'') y @@ get_value d y | _ -> failwith "Should not happen" (*transformation can not be a constant*) @@ -248,7 +248,7 @@ struct let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) match vary with | Some (c,y) -> (*x was a representant but is not anymore*) - let ineq' = Ineq.affine_transform ineq x (c, y, o, d) + let ineq' = Ineq.substitute ineq x (c, y, o, d) in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) let t' = econj', is', ineq' in set_value t' x value @@ -296,8 +296,8 @@ struct (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) (*This is only called in assign_texpr, after which the value will be set correctly.*) let (_, (m,o,d)) = EConj.inverse i rhs in - let c,v = BatOption.get m in - (EConj.affine_transform econ i rhs, vs, Ineq.affine_transform ineq i (c,v,o,d)) + let c,_ = BatOption.get m in + (EConj.affine_transform econ i rhs, vs, Ineq.substitute ineq i (c,i,o,d)) let affine_transform econ i (c,v,o,d) = let res = affine_transform econ i (c,v,o,d) in @@ -830,19 +830,22 @@ struct if M.tracing then M.tracel "meet" "%s with single value %s=%s -> %s" (show t) (show_var t.env i) (Value.show value) (show res); res - let meet_with_inequalities narrow ineq t = - match t.d with - | None -> t - | Some ((econ, vs, ineq2) as d) -> + let meet_with_inequalities narrow t_ineq t = + match t_ineq.d, t.d with + | _, None + | None, _ -> t + | Some (_,_,ineq), Some ((econ, vs, ineq2) as d) -> try - { d = Some (econ, vs, (if narrow then Ineq.narrow else Ineq.meet) (EConjI.get_value d) ineq ineq2); env = t.env} + let new_ineqs = (if narrow then Ineq.narrow else Ineq.meet) (EConjI.get_value d) ineq ineq2 + in let new_ineqs = Ineq.limit econ new_ineqs + in { d = Some (econ, vs, new_ineqs); env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction with inequalities\n"; { d = None; env = t.env} let meet_with_inequalities narrow ineq t = let res = meet_with_inequalities narrow ineq t in - if M.tracing then M.tracel "meet" "%s with inequalities %s -> %s" (show t) (Ineq.show_formatted (show_var t.env) ineq) (show res); + if M.tracing then M.tracel "meet" "%s with inequalities from %s -> %s" (show t) (show ineq) (show res); res let meet' t1 t2 narrow = @@ -850,10 +853,12 @@ struct let t1 = change_d t1 sup_env ~add:true ~del:false in let t2 = change_d t2 sup_env ~add:true ~del:false in match t1.d, t2.d with - | Some d1', Some (econ, vs, ineq) -> - let conj_met = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd econ) t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) - in let vals_met = IntMap.fold (meet_with_one_value narrow) vs conj_met - in meet_with_inequalities narrow ineq vals_met + | Some (econ, vs, _), Some (econ2, vs2, _) -> + let t1_conj = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd econ2) t1 (* even on sparse d2, this will chose the relevant conjs to meet with*) + in let t1_val = IntMap.fold (meet_with_one_value narrow) vs2 t1_conj + (*meet conj with t2 as well so that for both the inequalities refer to the correct roots*) + in let t2_conj = IntMap.fold (fun lhs rhs map -> meet_with_one_conj map lhs rhs) (snd econ) t2 + in meet_with_inequalities narrow t2_conj t1_val | _ -> {d = None; env = sup_env} let meet t1 t2 = @@ -884,7 +889,7 @@ struct else if is_bot_env t2 || is_top t1 then false else let m1, (econ2, vs2, ineq2) = Option.get t1.d, Option.get t2.d in let (econ1, _, ineq1) as m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in - (*If econ1 has some representants that are not representants in econ2, we need to transform the inequalities *) + (*make ineq1 refer to the new representants*) let transform_non_representant var (m,o,d) ineq_acc = match m with | None -> ineq_acc @@ -892,9 +897,11 @@ struct if M.tracing then M.trace "leq" "econ2 not representant: %s with rhs: %s" (Var.show @@ Environment.var_of_dim t2.env var) (Rhs.show (m,o,d)); match EConj.get_rhs econ1 var with | Some (_,v),_,_ when v <> var -> (if M.tracing then M.trace "leq" "and not representant in econ1 -> do nothing"); ineq_acc - | _ -> (if M.tracing then M.trace "leq" "and not representant in econ1 -> transform"); Ineq.affine_transform ineq_acc var (c,v,o,d) + | _ -> (if M.tracing then M.trace "leq" "and representant in econ1 -> transform"); Ineq.substitute ineq_acc var (c,v,o,d) in let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in + (*further, econ2 might have some new representants -> transform further*) + let ineq1' = Ineq.copy_to_new_representants econ1 econ2 ineq1' in if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) && IntMap.for_all (implies_value m1') (vs2) @@ -923,17 +930,17 @@ struct None -> None | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); - let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x (EConjI.get_value x) ineq_y (EConjI.get_value y) in - let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in - (*The above joins might result in inequalities for variables that are no longer representants after joining the equations -> transform them*) - (*TODO what if we split a connected component?? *) + (*transform the inequalities to represent only representants, and make the inequalities for new representants explicit*) let transform_non_representant var rhs ineq_acc = match rhs with - | (Some (c,v), o, d) when v <> var -> Ineq.affine_transform ineq_acc var (c,v,o,d) + | (Some (c,v), o, d) when v <> var -> Ineq.substitute ineq_acc var (c,v,o,d) | _ -> ineq_acc in - let i' = EConj.IntMap.fold (transform_non_representant) (snd econj'') i in - Some (e,v,i') + let ineq_x_split = IntMap.fold (transform_non_representant) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' ineq_x in + let ineq_y_split = IntMap.fold (transform_non_representant) (snd econj'') @@ Ineq.copy_to_new_representants econ_y econj'' ineq_y in + let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split (EConjI.get_value x) ineq_y_split (EConjI.get_value y) in + let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in + Some (e,v, Ineq.limit e i) in (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 21f18433c0..8445a5d67e 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -321,11 +321,18 @@ end module type TwoVarInequalities = sig type t + (*returns the best lower and upper bound for the relation between variables with the given Rhs*) val get_relations : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> Relation.t list - (*meet x' < y' + c (or with = / > *) + (*meet relation between two variables. also returns a list of value refinements *) val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * (int * Value.t) list + (*substitutes all occurences of a variable by a rhs*) + val substitute : t -> int -> Z.t * int * Z.t * Z.t -> t + + (*called after every operation to limit the inequalities to the most relevant*) + val limit : EConj.t -> t -> t + val meet : (int -> Value.t) -> t -> t -> t val narrow : (int -> Value.t) -> t -> t -> t @@ -334,9 +341,10 @@ module type TwoVarInequalities = sig val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t - val affine_transform : t -> int -> Z.t * int * Z.t * Z.t -> t + (*a join can split groups of variables. This function copies the relevant inequalities to all new representants*) + val copy_to_new_representants : EConj.t -> EConj.t -> t -> t - (*copy all constraints for some root to a different t if they still hold for a new x' with x' (cond) x *) + (*restore inequalities after an assignment that makes the assigned to variable have a known relation to before the assignment *) val transfer : int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t val show_formatted : (int -> string) -> t -> string @@ -356,6 +364,8 @@ module NoInequalties : TwoVarInequalities = struct let get_relations _ _ _ = [] let meet_relation _ _ _ _ _ _ = (), [] + let limit _ _ = () + let meet _ _ _ = () let narrow _ _ _ = () @@ -372,7 +382,9 @@ module NoInequalties : TwoVarInequalities = struct let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () - let affine_transform _ _ _ = () + let substitute _ _ _ = () + + let copy_to_new_representants _ _ _ = () let transfer _ _ _ _ _ _ _ _ = () end @@ -400,6 +412,10 @@ module CommonActions (Coeffs : Coeffs) = struct let is_empty = IntMap.is_empty let hash t = IntMap.fold (fun _ ys acc -> IntMap.fold (fun _ coeff acc -> Coeffs.hash coeff + 3*acc) ys (5*acc)) t 0 + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + let show_formatted formatter t = if IntMap.is_empty t then "{}" else if IntMap.exists (fun _ -> IntMap.is_empty) t then failwith "Map not sparse" else @@ -448,10 +464,7 @@ module CommonActions (Coeffs : Coeffs) = struct let join' widen t1 get_val_t1 t2 get_val_t2 = let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in let merge_x x ys1 ys2 = - let ignore_empty ls = - if IntMap.is_empty ls then None - else Some ls - in match ys1, ys2 with + match ys1, ys2 with | Some ys1, None -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t2 x) (get_val_t2 y) None coeff ) ys1) | None, Some ys2 -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t1 x) (get_val_t1 y) None coeff ) ys2) | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) @@ -667,8 +680,8 @@ end *) -let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) +let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) module LinearInequality = struct (*Normalised representation of an inequality through the origin @@ -814,7 +827,7 @@ module LinearInequality = struct (*apply the transformation to the variable on the left side*) - let affine_transform_left (coeff, offs, divi) (k,o) = + let substitute_left (coeff, offs, divi) (k,o) = let open OriginInequality in let s = get_slope k in let s' = Q.mul s (Q.make coeff divi) in @@ -824,7 +837,7 @@ module LinearInequality = struct | GT _ -> GT s', o' (*apply the transformation to the variable on the right side*) - let affine_transform_right (coeff, offs, divi) (k,o) = + let substitute_right (coeff, offs, divi) (k,o) = let open OriginInequality in let s = get_slope k in let f = Q.make coeff divi in @@ -837,6 +850,15 @@ module LinearInequality = struct then (negate k', Q.neg o') else k', o' + let swap_sides (k,o) = + let open Q in + let open OriginInequality in + match k with + | LT s when s < zero -> (GT (inv s), - (o / s)) + | LT s -> (LT (inv s), - (o / s)) + | GT s when s < zero -> (LT (inv s), - (o / s)) + | GT s -> (GT (inv s), - (o / s)) + (*combine an inequaliy x_old -> x_new with x_old -> y to x_new -> y*) let combine_left (k_rel, o_rel) (k, o) = let open OriginInequality in @@ -862,7 +884,30 @@ module LinearInequality = struct | GT s_rel, GT s -> Some (GT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + let slopes_from_econj ((dim, _)as econj) = + let table = BatHashtbl.create @@ dim * (dim + 1) / 2 in (*TODO this overestimates the actual number because there are constants*) + for x' = 0 to dim do + for y' = x' to dim do + match EConj.get_rhs econj x', EConj.get_rhs econj y' with + | (Some (cx,x),ox,dx), (Some (cy,y),oy,dy) -> begin + let (k,_) = from_rhss (cx, ox, dx) (cy, oy, dy) None in + let s = Q.abs @@ OriginInequality.get_slope k in (*absolute so that x < y and y < x (and x > y, y > x) map to the same s *) + let key = min x y, max x y in + match BatHashtbl.find_option table key with + | Some xy_tbl -> BatHashtbl.modify_def 0 s ((+) 1) xy_tbl + | None -> + let xy_tbl = BatHashtbl.create 5 in + BatHashtbl.add xy_tbl s 1; + BatHashtbl.add table key xy_tbl + end + | _ -> () (*ignore constants*) + done + done; + table + end + + (*List of inequalities ax < by + c, mapping a and b to c*) (*We need to make sure that x has lower index than y to keep this representation unique! *) module ArbitraryCoeffsSet = struct @@ -878,11 +923,26 @@ module ArbitraryCoeffsSet = struct let empty = CoeffMap.empty - (*TODO this function should limit how many inequalities we are saving. What information does this need? - likely: values, coefficients of Rhs relating to x and y*) - (* Throw away inequalities that are least useful: - least rhss with fitting coefficients *) - let limit = identity + + let ignore_empty ls = + if CoeffMap.is_empty ls then None + else Some ls + + (*limit how many inequalities we are saving: only keep inequalities with slopes that correspond to variables. + optionally, limit it further to the slopes that correspond to the most inequalities *) + let limit slopes t = + let open LinearInequality.OriginInequality in + let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (Q.abs @@ get_slope k) ) t in + if true then (*TODO add option to configure this*) + filtered + else + let keep = 10 in (*TODO add option to configure this. there are possibly 4 inequalities per slope, so should be adjusted accordingly*) + let comp (k1,_) (k2,_) = + let v1 = BatHashtbl.find_default slopes (Q.abs @@ get_slope k1) 0 in + let v2 = BatHashtbl.find_default slopes (Q.abs @@ get_slope k2) 0 in + v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) + in + CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered (*get the next key in anti-clockwise order*) let get_previous k t = @@ -920,7 +980,6 @@ module ArbitraryCoeffsSet = struct in CoeffMap.add k c @@ remove_prev prev @@ remove_next next t | _,_ -> failwith "impossible state" - (*get the thightest offset for an inequality with a given slope that is implied by the current set of inequalities*) let get_best_offset k t = match CoeffMap.find_opt k t with @@ -1005,7 +1064,7 @@ module ArbitraryCoeffsSet = struct | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) in t', refinements (*TODO: lookup the best interval information from the inequalities!*) - (*when meeting, the values should already been refined before -> ignore the refinement data*) + (*when meeting, the values should already been refined before -> ignore the refinement data*) (*TODO is this actually true?*) let meet' narrow x_val y_val t1 t2 = CoeffMap.fold (fun k c t -> fst @@ meet_single_inequality None narrow x_val y_val k c t) t1 t2 let implies x_val y_val t1_opt t2 = @@ -1068,9 +1127,6 @@ module ArbitraryCoeffsSet = struct in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) in let merged = CoeffMap.fold add_inequality t2_filtered' t1_filtered' (*remove the explicetly stored interval inequalities*) - in let ignore_empty ls = - if CoeffMap.is_empty ls then None - else Some ls in ignore_empty @@ CoeffMap.remove (LT Q.zero) @@ CoeffMap.remove (GT Q.zero) @@ CoeffMap.remove (LT Q.inf) @@ CoeffMap.remove (GT Q.inf) merged let join = join' false @@ -1078,21 +1134,21 @@ module ArbitraryCoeffsSet = struct let meet = meet' false let narrow = meet' true - let affine_transform_left (coeff, offs, divi) t = + let substitute_left (coeff, offs, divi) t = let f k c t_acc = - let (k',c') = LinearInequality.affine_transform_left (coeff, offs, divi) (k,c) in + let (k',c') = LinearInequality.substitute_left (coeff, offs, divi) (k,c) in CoeffMap.add k' c' t_acc (*affine transformation does not make a non redundant inequality redundant -> add directly*) in CoeffMap.fold f t CoeffMap.empty - let affine_transform_right (coeff, offs, divi) t = + let substitute_right (coeff, offs, divi) t = let f k c t_acc = - let (k',c') = LinearInequality.affine_transform_right (coeff, offs, divi) (k,c) in + let (k',c') = LinearInequality.substitute_right (coeff, offs, divi) (k,c) in CoeffMap.add k' c' t_acc in CoeffMap.fold f t CoeffMap.empty - (**) + (*combine two inequalities into a single one if possible*) let combine_left rel t = let fold_fun k c acc = match LinearInequality.combine_left rel (k,c) with @@ -1118,6 +1174,10 @@ module LinearInequalities: TwoVarInequalities = struct module Coeffs = ArbitraryCoeffsSet include CommonActions(Coeffs) + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + let rec get_relations (((var_x,o_x,d_x), x_val) as x') (((var_y,o_y,d_y), y_val) as y') t = match var_x, var_y with | Some (c_x, x), Some (c_y, y) -> @@ -1190,7 +1250,7 @@ module LinearInequalities: TwoVarInequalities = struct else let min = Q.div c' s' in t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] - else Coeffs.limit @@ Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t + else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t in let factor = (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in @@ -1210,22 +1270,22 @@ module LinearInequalities: TwoVarInequalities = struct if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (List.fold (fun acc (var,value) -> Printf.sprintf "var_%d: %s, %s" var (Value.show value) acc) "" refine_acc); res, refine_acc - (*TODO we programmed this slightly different to EConj: this expects the rhs to be inverted, EConj does it itself *) - (*this is now used in other places where i think this way is correct -> name it inverse_affine_transform? *) - let affine_transform t i (coeff, j, offs, divi) = + (*TODO switching sides ov variables because of substitution??*) + let substitute t i (coeff, j, offs, divi) = let fold_x x ys acc = - let check_for_contradiction cs = (*TODO value refinement?*) + let check_for_contradiction cs = let check_single k c = match k with - | Coeffs.Key.LT s -> if Q.lt c Q.zero then raise EConj.Contradiction - | GT s -> if Q.gt c Q.zero then raise EConj.Contradiction + | Coeffs.Key.LT s when Q.equal s Q.one -> if Q.lt c Q.zero then raise EConj.Contradiction + | GT s when Q.equal s Q.one -> if Q.gt c Q.zero then raise EConj.Contradiction + | _ -> () (*TODO value refinement?*) in Coeffs.CoeffMap.iter check_single cs in if x < i then let ys' = match IntMap.find_opt i ys with | None -> Some ys | Some cs -> - let cs' = Coeffs.affine_transform_right (coeff, offs, divi) cs in + let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictions*) (check_for_contradiction cs'; None) else @@ -1238,7 +1298,7 @@ module LinearInequalities: TwoVarInequalities = struct | _ -> acc else if x = i then let convert y cs = - let tranformed = Coeffs.affine_transform_left (coeff, offs, divi) cs in + let tranformed = Coeffs.substitute_left (coeff, offs, divi) cs in if y = j then (check_for_contradiction tranformed; None) else Some tranformed @@ -1254,9 +1314,9 @@ module LinearInequalities: TwoVarInequalities = struct acc in IntMap.fold fold_x t IntMap.empty - let affine_transform t i (c,j,o,d) = - let res = affine_transform t i (c,j,o,d) in - if M.tracing then M.trace "affine_transform" "transforming var_%d in %s with %s -> %s" i (show t) (Rhs.show (Some (c,j), o, d)) (show res); + let substitute t i (c,j,o,d) = + let res = substitute t i (c,j,o,d) in + if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s -> %s" i (show t) (Rhs.show (Some (c,j), o, d)) (show res); res let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = @@ -1270,10 +1330,6 @@ module LinearInequalities: TwoVarInequalities = struct | Gt, o -> (Coeffs.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) | Eq, o -> undefined "TODO" (*Should we exclude EQ from relation?*) in - let ignore_empty ls = - if IntMap.is_empty ls then None - else Some ls - in (*combine the inequality from cond with all inequalities*) (*throw out all inequalities that do not contain the representative of x*) let combine_1 v1 v2s = @@ -1283,11 +1339,14 @@ module LinearInequalities: TwoVarInequalities = struct ignore_empty @@ IntMap.filter_map combine_2 v2s in let filtered = IntMap.filter_map combine_1 t_old in + if M.tracing then M.tracel "transfer" "filtered: %s" (show filtered); + (*transform all inequalities to refer to new root of x*) (*invert old rhs, then substitute the new rhs for x*) let (m, o, d) = Rhs.subst rhs x @@ snd @@ EConj.inverse x (coeff_old,x_root_old, off_old, divi_old) in let c, v = BatOption.get m in - let transformed = affine_transform filtered x_root (c, v, o, d) in + let transformed = substitute filtered x_root (c, v, o, d) in + if M.tracing then M.tracel "transfer" "transformed: %s" (show transformed); (*meet with this set of equations*) meet get_value t transformed | _,_ -> t (*ignore constants*) @@ -1298,16 +1357,82 @@ module LinearInequalities: TwoVarInequalities = struct if M.tracing then M.tracel "transfer" "result: %s" (show res); res + let limit econj t = + let slopes = LinearInequality.slopes_from_econj econj in + let limit_single x y cs = + Coeffs.limit (BatHashtbl.find_default slopes (min x y, max x y) (Hashtbl.create 0)) cs + in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> Coeffs.ignore_empty @@ limit_single x y cs) ys) t + + let copy_to_new_representants econj_old econj_new t = + let slopes = LinearInequality.slopes_from_econj econj_new in + (*a var is representant if it does not show up in the sparse map*) + let all_representants_in_new = + let rec aux acc n = + if n > (fst econj_new) then acc + else if IntMap.mem n (snd econj_new) then aux acc (n + 1) + else aux (n :: acc) (n + 1) + in aux [] 0 + in let new_representants_in_new = List.filter (fun v -> IntMap.mem v (snd econj_old)) all_representants_in_new + in let add_new v_new t_acc other_var = + (*get the old rhs*) + match IntMap.find v_new (snd econj_old) with + | None,_,_ -> t_acc (*skip constants*) + | (Some (c,old_rep), o, d) -> + let allowed_slopes = Hashtbl.keys @@ Hashtbl.find slopes (min v_new other_var, max v_new other_var) in + (*inverse rhs so that we can translate the inequalities of the old representant to slopes corresponding to the new representant*) + let (_, (mi,oi,di)) = EConj.inverse v_new (c,old_rep,o,d) in + let ci,_ = BatOption.get mi in + (*convert the slope from new representant to old*) + let convert_to_old ineq = + if v_new < other_var then + LinearInequality.substitute_left (c,o,d) ineq + else + let ineq' = LinearInequality.substitute_right (c,o,d) ineq in + if old_rep < other_var then + LinearInequality.swap_sides ineq' + else ineq' + (*convert back*) + in let convert_to_new ineq = + if v_new < other_var then + LinearInequality.substitute_left (ci,oi,di) ineq + else + let ineq' = if old_rep < other_var then LinearInequality.swap_sides ineq else ineq + in LinearInequality.substitute_right (ci,oi,di) ineq' + (*relations between the old representant and the other variable*) + in let coeffs_old = BatOption.default Coeffs.empty @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in + let add_single_slope c_acc s = + (*the given slope has been normed to be positive -> copy both it and the negative*) + let ineqs = [LinearInequality.OriginInequality.LT s, Q.zero; GT s, Q.zero; LT (Q.neg s), Q.zero; GT (Q.neg s), Q.zero;] + in let copy_single_ineq c_acc ineq = + let k_old = fst @@ convert_to_old ineq in + (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) + match Coeffs.get_best_offset k_old coeffs_old with + | None -> c_acc + | Some o -> + let k_neq, o_new = convert_to_new (k_old, o) in + Coeffs.add_inequality k_neq o_new c_acc + in List.fold copy_single_ineq c_acc ineqs + in let coeffs_new = Enum.fold add_single_slope Coeffs.empty allowed_slopes + in if Coeffs.CoeffMap.is_empty coeffs_new then t_acc else set_coeff (min v_new other_var) (max v_new other_var) coeffs_new t_acc + + in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new end (*TODOs:*) -(*relation to offset domain *) -(*transfer: allow RHS for more information transfer!*) -(*rework transfer: allow affine transfer, look at complexities*) -(*limit in ArbitraryCoeaffsList*) +(*limit: join and affine_transform*) +(*D.meet: transform to roots! + ArbitraryCoeaffsList.meet + affine_transform -> refinement + D.join, leq: splitting groups +*) +(*look at complexities. I expect: + Meet, join, leq, widen, forget: (n² log n) + assert ? + assign: same +*) +(*rework relation to offset domain -> remove Eq? *) (*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) -(*adapt simple equalities to take advantage of the offset!*) +(*redo simple equalities (take advantage of the offset!, affine transform)*) (*domain inbetween these two: with offset between roots? -> should be trivial to implement*) (*what is required of narrow?*) (*widening thresholds: from offsets of rhs?*) diff --git a/tests/regression/82-lin2vareq_p/37-intervals_propagation.c b/tests/regression/82-lin2vareq_p/37-intervals_propagation.c index dc9d76983a..607ce634a4 100644 --- a/tests/regression/82-lin2vareq_p/37-intervals_propagation.c +++ b/tests/regression/82-lin2vareq_p/37-intervals_propagation.c @@ -5,8 +5,8 @@ int main() { x = 3*y + 1; // a z = 5*x + 7; // b if (x>0) { - __goblint_check( x > 0 ); - __goblint_check( y > -1 ); // A - __goblint_check( z > 7 ); // B + __goblint_check( x > 0 ); //SUCCESS + __goblint_check( y > -1 ); //SUCCESS + __goblint_check( z > 7 ); //SUCCESS } } \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/38-simple_congruence.c b/tests/regression/82-lin2vareq_p/38-simple_congruence.c index b2fbc2112d..5936b73d09 100644 --- a/tests/regression/82-lin2vareq_p/38-simple_congruence.c +++ b/tests/regression/82-lin2vareq_p/38-simple_congruence.c @@ -6,11 +6,11 @@ int main() { z = 5 * x + 7; // b if (y < 14) { - __goblint_check( x <= 42); - __goblint_check(y < 14); // A - __goblint_check(z != 500); // B - __goblint_check(z != 14); // Because of eqution for z - __goblint_check(z != 17); // Because of combination of equation for z and x + __goblint_check( x <= 42); //SUCCESS + __goblint_check(y < 14); //SUCCESS + __goblint_check(z != 500); //SUCCESS + __goblint_check(z != 14); //SUCCESS // Because of eqution for z + __goblint_check(z != 17); //SUCCESS // Because of combination of equation for z and x } } \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c index 7fb1be4816..2a1e2e4230 100644 --- a/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c +++ b/tests/regression/82-lin2vareq_p/39-congruence_from_equation.c @@ -3,8 +3,8 @@ int main() { int x, y, z; if (4 * x == 3 * y + 1) { - __goblint_check( y % 4 == 1); - __goblint_check( x % 3 == 1); + __goblint_check( y % 4 == 1); //SUCCESS + __goblint_check( x % 3 == 1); //SUCCESS } } \ No newline at end of file diff --git a/tests/regression/82-lin2vareq_p/40-join-splitting-group.c b/tests/regression/82-lin2vareq_p/40-join-splitting-group.c new file mode 100644 index 0000000000..35bf3f40ad --- /dev/null +++ b/tests/regression/82-lin2vareq_p/40-join-splitting-group.c @@ -0,0 +1,41 @@ +//SKIP PARAM: --set ana.activated[+] lin2vareq_p --set sem.int.signed_overflow assume_none + +int main() { + //Test if inequality information is conserved correctly when a equality grouping is split + //Tested with x and y to be resitant against changes to the indexes of variables + { + int x, y, z; + + if (z) { + y = 2 * x; + if (y < z) + ; + else + return 0; + // y = 2x, 2x <= z - 1 + } else { + x = 0; + y = 1; + z = 10; + } + // 2x <= z - 1 would no longer prove what we want, as the relation y = 2x no longer holds + __goblint_check( y < z); //SUCCESS + } + { + int x, y, z; + + if (z) { + y = 2 * x; + if (x < z) + ; + else + return 0; + } else { + x = 0; + y = 1; + z = 10; + } + + __goblint_check( x < z); //SUCCESS + } +} \ No newline at end of file From 2d4da5d1bbb61cb4fbfbb91cf36c9da22ac6faa3 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 26 Apr 2025 19:22:43 +0200 Subject: [PATCH 51/86] cache slopes --- .../apron/pentagonSubDomains.apron.ml | 56 ++++++++++++++----- 1 file changed, 41 insertions(+), 15 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 8445a5d67e..027be75df7 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1,5 +1,7 @@ open Batteries open GoblintCil +open VectorMatrix + module M = Messages @@ -887,24 +889,44 @@ module LinearInequality = struct let slopes_from_econj ((dim, _)as econj) = let table = BatHashtbl.create @@ dim * (dim + 1) / 2 in (*TODO this overestimates the actual number because there are constants*) for x' = 0 to dim do - for y' = x' to dim do - match EConj.get_rhs econj x', EConj.get_rhs econj y' with - | (Some (cx,x),ox,dx), (Some (cy,y),oy,dy) -> begin - let (k,_) = from_rhss (cx, ox, dx) (cy, oy, dy) None in - let s = Q.abs @@ OriginInequality.get_slope k in (*absolute so that x < y and y < x (and x > y, y > x) map to the same s *) - let key = min x y, max x y in - match BatHashtbl.find_option table key with - | Some xy_tbl -> BatHashtbl.modify_def 0 s ((+) 1) xy_tbl - | None -> - let xy_tbl = BatHashtbl.create 5 in - BatHashtbl.add xy_tbl s 1; - BatHashtbl.add table key xy_tbl - end - | _ -> () (*ignore constants*) - done + match EConj.get_rhs econj x' with + | (Some (cx,x),ox,dx) -> + for y' = x' to dim do + match EConj.get_rhs econj y' with + | (Some (cy,y),oy,dy) -> begin + let (k,_) = from_rhss (cx, ox, dx) (cy, oy, dy) None in + let s = Q.abs @@ OriginInequality.get_slope k in (*absolute so that x < y and y < x (and x > y, y > x) map to the same s *) + let key = min x y, max x y in + match BatHashtbl.find_option table key with + | Some xy_tbl -> BatHashtbl.modify_def 0 s ((+) 1) xy_tbl + | None -> + let xy_tbl = BatHashtbl.create 5 in + BatHashtbl.add xy_tbl s 1; + BatHashtbl.add table key xy_tbl + end + | _ -> () (*ignore constants*) + done + | _ -> () (*ignore constants*) done; table + (*TODO this is a hack because the above function is slow + without it, limit (and copy_to_new_representants) will dominate the runtime + this will leak memory + !!! make this reset !!! + *) + let slopes_cache = BatHashtbl.create 100 + + let slopes_from_econj e = + match BatHashtbl.find_option slopes_cache e with + | Some result -> result + | None -> + let result = slopes_from_econj e in + Hashtbl.add slopes_cache e result; + result + + let slopes_from_econj = timing_wrap "slopes" slopes_from_econj + end @@ -1363,6 +1385,8 @@ module LinearInequalities: TwoVarInequalities = struct Coeffs.limit (BatHashtbl.find_default slopes (min x y, max x y) (Hashtbl.create 0)) cs in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> Coeffs.ignore_empty @@ limit_single x y cs) ys) t + let limit e t = timing_wrap "limit" (limit e) t + let copy_to_new_representants econj_old econj_new t = let slopes = LinearInequality.slopes_from_econj econj_new in (*a var is representant if it does not show up in the sparse map*) @@ -1417,6 +1441,8 @@ module LinearInequalities: TwoVarInequalities = struct in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new + let copy_to_new_representants econj_old econj_new t = timing_wrap "new_reps" (copy_to_new_representants econj_old econj_new) t + end (*TODOs:*) From cf60376e59dae4f608adcdee460ae5f82ba84fc0 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 29 Apr 2025 11:52:30 +0200 Subject: [PATCH 52/86] reworked limit to be lazy and need less memory --- .../apron/pentagonSubDomains.apron.ml | 110 ++++++++---------- 1 file changed, 51 insertions(+), 59 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 027be75df7..2817e89076 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -885,50 +885,48 @@ module LinearInequality = struct | LT s_rel, LT s -> Some (LT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) | GT s_rel, GT s -> Some (GT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) +end + +(*very small wrapper to make the following code clearer to me*) +module MultiSet = struct + module M = BatHashtbl + + type 'a t = ('a, int) M.t + + let create ?(initial_size = 5) () = M.create initial_size + + let change_member_count (ms : 'a t) (x : 'a) (count : int) = M.modify_def 0 x ((+) count) ms - let slopes_from_econj ((dim, _)as econj) = - let table = BatHashtbl.create @@ dim * (dim + 1) / 2 in (*TODO this overestimates the actual number because there are constants*) - for x' = 0 to dim do - match EConj.get_rhs econj x' with - | (Some (cx,x),ox,dx) -> - for y' = x' to dim do - match EConj.get_rhs econj y' with - | (Some (cy,y),oy,dy) -> begin - let (k,_) = from_rhss (cx, ox, dx) (cy, oy, dy) None in - let s = Q.abs @@ OriginInequality.get_slope k in (*absolute so that x < y and y < x (and x > y, y > x) map to the same s *) - let key = min x y, max x y in - match BatHashtbl.find_option table key with - | Some xy_tbl -> BatHashtbl.modify_def 0 s ((+) 1) xy_tbl - | None -> - let xy_tbl = BatHashtbl.create 5 in - BatHashtbl.add xy_tbl s 1; - BatHashtbl.add table key xy_tbl - end - | _ -> () (*ignore constants*) - done - | _ -> () (*ignore constants*) - done; - table - - (*TODO this is a hack because the above function is slow - without it, limit (and copy_to_new_representants) will dominate the runtime - this will leak memory - !!! make this reset !!! - *) - let slopes_cache = BatHashtbl.create 100 - - let slopes_from_econj e = - match BatHashtbl.find_option slopes_cache e with - | Some result -> result - | None -> - let result = slopes_from_econj e in - Hashtbl.add slopes_cache e result; - result - - let slopes_from_econj = timing_wrap "slopes" slopes_from_econj + let iter = M.iter end +let coeffs_from_econj (dim, map) = + let m = BatHashtbl.create @@ IntMap.cardinal map in (*This is an overestimation*) + let add_rhs _ = function + | (Some (cy,y),oy,dy) -> + let s = Q.make cy dy in + BatHashtbl.modify_def (MultiSet.create ()) y (fun set -> MultiSet.change_member_count set s 1; set) m (*TODO unneccessary readding!*) + | _ -> () (*ignore constants*) + in + IntMap.iter add_rhs map; + m + +let coeffs_from_econj = timing_wrap "coeffs" coeffs_from_econj + +(*assumes x < y*) +let slopes_from_coeffs mapping (x,y) = + let x_coeffs = BatHashtbl.find_default mapping x (MultiSet.create ~initial_size:1 ()) in + let y_coeffs = BatHashtbl.find_default mapping y (MultiSet.create ~initial_size:1 ()) in + (*We do not explicetly store the representants coefficient -> add it here*) + MultiSet.change_member_count x_coeffs Q.one 1; + MultiSet.change_member_count y_coeffs Q.one 1; + let slopes = MultiSet.create ~initial_size:(BatHashtbl.length x_coeffs * BatHashtbl.length y_coeffs) () in + MultiSet.iter (fun cx cx_count -> MultiSet.iter (fun cy cy_count -> let s = Q.div cx cy in MultiSet.change_member_count slopes s (cx_count * cy_count)) y_coeffs) x_coeffs; + slopes + +let slopes_from_coeffs = timing_wrap "slopes" slopes_from_coeffs + (*List of inequalities ax < by + c, mapping a and b to c*) (*We need to make sure that x has lower index than y to keep this representation unique! *) @@ -954,14 +952,14 @@ module ArbitraryCoeffsSet = struct optionally, limit it further to the slopes that correspond to the most inequalities *) let limit slopes t = let open LinearInequality.OriginInequality in - let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (Q.abs @@ get_slope k) ) t in + let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (get_slope k) ) t in if true then (*TODO add option to configure this*) filtered else - let keep = 10 in (*TODO add option to configure this. there are possibly 4 inequalities per slope, so should be adjusted accordingly*) + let keep = 10 in (*TODO add option to configure this. there are possibly 2 inequalities per slope, so should be adjusted accordingly*) let comp (k1,_) (k2,_) = - let v1 = BatHashtbl.find_default slopes (Q.abs @@ get_slope k1) 0 in - let v2 = BatHashtbl.find_default slopes (Q.abs @@ get_slope k2) 0 in + let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in + let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) in CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered @@ -1380,15 +1378,15 @@ module LinearInequalities: TwoVarInequalities = struct res let limit econj t = - let slopes = LinearInequality.slopes_from_econj econj in + let coeffs = coeffs_from_econj econj in let limit_single x y cs = - Coeffs.limit (BatHashtbl.find_default slopes (min x y, max x y) (Hashtbl.create 0)) cs + Coeffs.limit ( slopes_from_coeffs coeffs (min x y, max x y)) cs in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> Coeffs.ignore_empty @@ limit_single x y cs) ys) t let limit e t = timing_wrap "limit" (limit e) t let copy_to_new_representants econj_old econj_new t = - let slopes = LinearInequality.slopes_from_econj econj_new in + let coeffs = coeffs_from_econj econj_new in (*a var is representant if it does not show up in the sparse map*) let all_representants_in_new = let rec aux acc n = @@ -1402,7 +1400,7 @@ module LinearInequalities: TwoVarInequalities = struct match IntMap.find v_new (snd econj_old) with | None,_,_ -> t_acc (*skip constants*) | (Some (c,old_rep), o, d) -> - let allowed_slopes = Hashtbl.keys @@ Hashtbl.find slopes (min v_new other_var, max v_new other_var) in + let allowed_slopes = Hashtbl.keys @@ slopes_from_coeffs coeffs (min v_new other_var, max v_new other_var) in (*inverse rhs so that we can translate the inequalities of the old representant to slopes corresponding to the new representant*) let (_, (mi,oi,di)) = EConj.inverse v_new (c,old_rep,o,d) in let ci,_ = BatOption.get mi in @@ -1425,8 +1423,7 @@ module LinearInequalities: TwoVarInequalities = struct (*relations between the old representant and the other variable*) in let coeffs_old = BatOption.default Coeffs.empty @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in let add_single_slope c_acc s = - (*the given slope has been normed to be positive -> copy both it and the negative*) - let ineqs = [LinearInequality.OriginInequality.LT s, Q.zero; GT s, Q.zero; LT (Q.neg s), Q.zero; GT (Q.neg s), Q.zero;] + let ineqs = [LinearInequality.OriginInequality.LT s, Q.zero; GT s, Q.zero;] in let copy_single_ineq c_acc ineq = let k_old = fst @@ convert_to_old ineq in (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) @@ -1438,7 +1435,6 @@ module LinearInequalities: TwoVarInequalities = struct in List.fold copy_single_ineq c_acc ineqs in let coeffs_new = Enum.fold add_single_slope Coeffs.empty allowed_slopes in if Coeffs.CoeffMap.is_empty coeffs_new then t_acc else set_coeff (min v_new other_var) (max v_new other_var) coeffs_new t_acc - in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new let copy_to_new_representants econj_old econj_new t = timing_wrap "new_reps" (copy_to_new_representants econj_old econj_new) t @@ -1446,16 +1442,12 @@ module LinearInequalities: TwoVarInequalities = struct end (*TODOs:*) -(*limit: join and affine_transform*) -(*D.meet: transform to roots! +(* ArbitraryCoeaffsList.meet + affine_transform -> refinement - D.join, leq: splitting groups -*) -(*look at complexities. I expect: - Meet, join, leq, widen, forget: (n² log n) - assert ? - assign: same + refinement of equalities must be limited to have acceptable runtimes! *) +(*look at complexities. I expect for all: (n² log n) *) + (*rework relation to offset domain -> remove Eq? *) (*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*redo simple equalities (take advantage of the offset!, affine transform)*) From 549b38ad06298c4116d07f6c5b57622cbfd27d26 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 2 May 2025 13:52:54 +0200 Subject: [PATCH 53/86] invariant implemented, TODO cleanup and sorting --- .../value/cdomains/int/congruenceDomain.ml | 1 - ...inearTwoVarEqualityDomainPentagon.apron.ml | 11 +- .../apron/pentagonSubDomains.apron.ml | 131 +++++++++++++++--- 3 files changed, 115 insertions(+), 28 deletions(-) diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml index 1ab1b3e0c5..c3e9d5cff7 100644 --- a/src/cdomain/value/cdomains/int/congruenceDomain.ml +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -1,7 +1,6 @@ open IntDomain0 open GoblintCil -(*TODO Test and remove code duplication*) module type Norm = sig val normalize : ikind -> (Z.t * Z.t) option -> (Z.t * Z.t) option end diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 5788d8c0b1..c8cf944597 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -148,10 +148,10 @@ struct if M.tracing then M.tracel "modify_pentagon" "set_value before: %s eq: var_%d=%s -> %s " (show t) lhs (Value.show i) (show res); res - (*TODO: If we are uptdating a variable, we will overwrite the value again -> maybe skip setting it here, because of performance?*) let set_rhs (econ, is, ineq) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with + (*TODO remove from ineq, convert to interval information!*) | (None, _, _) -> econ', IntMap.remove lhs is, ineq (*when setting as a constant, we do not need a separate value *) | _ -> let new_constraint = get_value (econ', is, ineq) lhs in @@ -448,7 +448,6 @@ struct if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (match t.d with None -> "⊥" | Some d ->EConjI.show d) Texpr1.Expr.pretty texp (Value.show res); res - (*TODO Could be more precise with query*) (*TODO We also only catch variables on the first level, but miss e.g. (x+7)+7 -> use more recursion similar to negate?*) let rec to_inequalities (t:t) texpr = let open Apron.Texpr1 in @@ -655,7 +654,6 @@ struct if M.tracing then M.trace "refine_tcons" "refining var %s with %s" (Var.to_string var) (Value.show value) ; EConjI.meet_with_one_value dim value d false ) in - (*TODO Could be more precise with query ?? would need to convert back to Cil *) let eval d texpr = eval_texpr {d= Some d; env = t.env} texpr in let open Texpr1 in let rec refine_values d value expr = @@ -905,7 +903,7 @@ struct if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) && IntMap.for_all (implies_value m1') (vs2) - && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 + && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 (*TODO the transformations are likely the most expensive part. -> only do it when both above options did not already deterime the result *) let leq a b = timing_wrap "leq" (leq a) b @@ -1270,7 +1268,10 @@ struct in match t.d with | None -> [] - | Some d -> d |> fun ((_,map),_,_) -> IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map [] + | Some ((_,map),vs,ineq) -> + let from_ineq = Ineq.invariant ineq t.env in + let with_eq = IntMap.fold (fun lhs rhs list -> get_const list lhs rhs) map from_ineq in + IntMap.fold (Value.invariant t.env) vs with_eq let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 2817e89076..3ec8b784f6 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1,6 +1,7 @@ open Batteries open GoblintCil open VectorMatrix +open GobApron module M = Messages @@ -149,8 +150,7 @@ struct else Int i let to_bigint t = Int_t.to_bigint @@ get_int_t t - (*TODO*) - let arbitrary () = failwith "arbitrary not implemented yet" + let arbitrary () = failwith "arbitrary not implemented" end (*TODO this is a copy of the IntOpsDecorator, but we keep the constructor of type t -> is there a better way??*) @@ -284,6 +284,35 @@ module IntervalAndCongruence = struct | _ -> None in refine (interval, IntDomain.IntDomTuple.to_congruence tuple) + let invariant env var ((i,c):t) acc = + let with_i = + let lower l = + (*x - l >= 0*) + let expr = Linexpr1.make env in + Linexpr1.set_coeff expr (Environment.var_of_dim env var) (GobApron.Coeff.s_of_int 1); + Linexpr1.set_cst expr (GobApron.Coeff.s_of_z @@ Z.neg l); + Lincons1.make expr Lincons0.SUPEQ + in + let higher u = + (*-x + u >= 0*) + let expr = Linexpr1.make env in + Linexpr1.set_coeff expr (Environment.var_of_dim env var) (GobApron.Coeff.s_of_int (-1)); + Linexpr1.set_cst expr (GobApron.Coeff.s_of_z u); + Lincons1.make expr Lincons0.SUPEQ + in + match i with + | Some (TopIntOps.Int l, TopIntOps.Int u) -> lower l :: higher u :: acc + | Some (TopIntOps.Int l, _) -> lower l :: acc + | Some (_, TopIntOps.Int u) -> higher u :: acc + | _ -> acc + in match c with + | Some (o, m) -> + (*x-o % m = 0*) + let expr = Linexpr1.make env in + Linexpr1.set_coeff expr (Environment.var_of_dim env var) (GobApron.Coeff.s_of_int 1); + Linexpr1.set_cst expr (GobApron.Coeff.s_of_z @@ Z.neg o); + Lincons1.make expr (Lincons0.EQMOD (Mpqf (Z_mlgmpidl.mpqf_of_q @@ Q.of_bigint m))) :: with_i + | _ -> Lincons1.make_unsat env :: with_i end module Value = IntervalAndCongruence @@ -358,6 +387,8 @@ module type TwoVarInequalities = sig val modify_variables_in_domain : t -> int array -> (int -> int -> int) -> t val forget_variable : t -> int -> t + val invariant : t -> Environment.t -> Lincons1.t list + end module NoInequalties : TwoVarInequalities = struct @@ -389,6 +420,9 @@ module NoInequalties : TwoVarInequalities = struct let copy_to_new_representants _ _ _ = () let transfer _ _ _ _ _ _ _ _ = () + + let invariant _ _ = [] + end module type Coeffs = sig @@ -404,6 +438,8 @@ module type Coeffs = sig val equal : t -> t -> bool val compare : t -> t -> int val show_formatted : string -> string -> t -> string + + val invariant : Environment.t -> int -> int -> t -> Lincons1.t list -> Lincons1.t list end module CommonActions (Coeffs : Coeffs) = struct @@ -476,6 +512,8 @@ module CommonActions (Coeffs : Coeffs) = struct let join = join' false let widen = join' true + let invariant t env = IntMap.fold (fun x ys acc -> IntMap.fold (Coeffs.invariant env x) ys acc) t [] + end (* TODO Redo this @@ -689,7 +727,7 @@ module LinearInequality = struct (*Normalised representation of an inequality through the origin a/b x <= y (or >=) bzw. slope and direction. infinite slope represents 0 <= x / 0 >= x*) module OriginInequality = struct (*Separate module so we can use it as key in a map*) - type t = LT of Q.t | GT of Q.t + type t = LT of Q.t | GT of Q.t (*TODO rename into LE / GE*) (*make the representation of inequalities without y unique*) let norm = function @@ -885,6 +923,21 @@ module LinearInequality = struct | LT s_rel, LT s -> Some (LT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) | GT s_rel, GT s -> Some (GT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + let invariant env x y k o acc = + (*for LE, we need to swap signs of all coefficients*) + let s, o = match k with + | OriginInequality.LT s -> Q.neg s, Q.neg o + | GT s -> s, o + in + let o' = if Q.equal s Q.inf then Q.neg o else Q.neg @@ Q.mul o @@ Q.of_bigint @@ Q.den s in + let coeffs = [ + GobApron.Coeff.s_of_z (Q.num s), Environment.var_of_dim env x; + GobApron.Coeff.s_of_z @@ Z.neg @@ Q.den s, Environment.var_of_dim env y + ] in + let expr = Linexpr1.make env in + Linexpr1.set_list expr coeffs (Some (GobApron.Coeff.s_of_mpq @@ Z_mlgmpidl.mpq_of_q o')); + Lincons1.make expr Lincons0.SUPEQ :: acc + end (*very small wrapper to make the following code clearer to me*) @@ -906,7 +959,14 @@ let coeffs_from_econj (dim, map) = let add_rhs _ = function | (Some (cy,y),oy,dy) -> let s = Q.make cy dy in - BatHashtbl.modify_def (MultiSet.create ()) y (fun set -> MultiSet.change_member_count set s 1; set) m (*TODO unneccessary readding!*) + begin + match BatHashtbl.find_option m y with + | None -> + let set = MultiSet.create () in + MultiSet.change_member_count set s 1; + BatHashtbl.add m y set; + | Some set -> MultiSet.change_member_count set s 1; + end | _ -> () (*ignore constants*) in IntMap.iter add_rhs map; @@ -1136,7 +1196,6 @@ module ArbitraryCoeffsSet = struct (* merge the two sets. if one inequality is in both, take the less tight bound *) (* we make two passes over the list: first the relaxation, then adding all other inequalities*) (* this prevents an inequality from being deemed redundant by an inequality that is later relaxed*) - (* TODO: test if this increased precision is worth the time?*) let relax k c2 (t1_f, t2_f) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) match CoeffMap.find_opt k t1 with (*look up in original t1 so that we can take care of widening for inequalities that get filtered*) | None -> (t1_f, t2_f) @@ -1187,6 +1246,8 @@ module ArbitraryCoeffsSet = struct let t' = CoeffMap.fold fold_fun t CoeffMap.empty in if CoeffMap.is_empty t' then None else Some t' + let invariant env x y t acc = CoeffMap.fold (LinearInequality.invariant env x y) t acc + end @@ -1228,7 +1289,7 @@ module LinearInequalities: TwoVarInequalities = struct let c' = Q.mul factor ( Q.add c_ineq c_rhs) in (Gt, Z.add Z.minus_one @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound end - | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) + | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*Should probably enforced by the type system :) *) let get_relations x y t = let res = get_relations x y t in @@ -1240,7 +1301,7 @@ module LinearInequalities: TwoVarInequalities = struct let rhs = get_rhs lhs in match rhs with | (Some (c,var), o ,d) -> (c,o,d), var - | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO I think we should not save relations to constants here, as that information will be saved in the intervals, but am not sure if this is always done*) + | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO do not save relations to constants -> interval refinement*) in let (rhs_x, x) = get_rhs' x' in let (rhs_y, y) = get_rhs' y' in if x > y then @@ -1271,7 +1332,7 @@ module LinearInequalities: TwoVarInequalities = struct let min = Q.div c' s' in t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t - in let factor = (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) + in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in if Q.equal b Q.zero then a else b @@ -1344,7 +1405,7 @@ module LinearInequalities: TwoVarInequalities = struct | (Some (coeff_old,x_root_old), off_old, divi_old), ((Some (coeff,x_root), off, divi) as rhs) -> (*convert the relation to a linear inequality refering to the old root *) let (k,c) = LinearInequality.from_rhss (coeff_old, off_old, divi_old) (coeff_old, off_old, divi_old) (Some (match fst cond with Relation.Lt -> true | _ -> false)) - in let factor = Q.make coeff_old divi_old (*we need to divide o by this factor because LinearInequalities scales everything down. TODO is there a better way?*) + in let factor = Q.make coeff_old divi_old (*we need to divide o by this factor because LinearInequalities normalizes*) in let ineq_from_cond = match cond with | Relation.Lt, o -> k, (Q.add c @@ Q. div (Q.of_bigint o) factor) | Gt, o -> (Coeffs.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) @@ -1442,17 +1503,43 @@ module LinearInequalities: TwoVarInequalities = struct end (*TODOs:*) -(* - ArbitraryCoeaffsList.meet + affine_transform -> refinement - refinement of equalities must be limited to have acceptable runtimes! + +(*! ArbitraryCoeaffsList meet_single: be sure about rounding*) +(*!!substitute: swap side if necessary*) +(*+ Why do inverted conditions work strangely?*) + +(*+ + ArbitraryCoeaffsList meet_single: take intervals into account better + re-add them every time, remove them afterwards and update interval with this information + ArbitraryCoeaffsList.meet + affine_transform -> refinement + refinement of equalities must be limited to have acceptable runtimes! + substitute refinement + set_rhs constant refinement + meet_relations: refinement of intervals if var is constant + meet_relations: do some transitivity ! + *) -(*look at complexities. I expect for all: (n² log n) *) - -(*rework relation to offset domain -> remove Eq? *) -(*store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) -(*redo simple equalities (take advantage of the offset!, affine transform)*) -(*domain inbetween these two: with offset between roots? -> should be trivial to implement*) -(*what is required of narrow?*) -(*widening thresholds: from offsets of rhs?*) -(*general renaming*) -(*rebase to main branch*) \ No newline at end of file +(*-- assign expr restore ineqs based on value *) + +(*!! options for limit function*) + +(*+ look at complexities. I expect for all: (n² log n) *) +(*+ How to do a useful narrow?*) +(* widening thresholds: from offsets of rhs?*) +(* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) +(*- copy_to_new: introduces too many inequlities?*) + +(*+ redo simple equalities (take advantage of the offset!, affine transform)*) +(* domain inbetween these two: with offset between roots? -> should be trivial to implement*) +(*- better to_inequalities? with query?*) +(*- ineq refine_with_tcons: normalisation*) + +(*+ rework relation to offset domain -> remove Eq? *) +(*- memo_bumbvar created 3 times*) +(*- leq performance?*) +(*--eval_int: answer nonlinear*) +(*! general renaming*) +(*+ rename constuctor in OriginInequality into LE / GE*) + +(*!!rebase to main branch*) +(*!!documentation (failing check!!) *) \ No newline at end of file From 64f08102bb238f01a961f1544e7a6a529825968e Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 2 May 2025 18:47:00 +0200 Subject: [PATCH 54/86] fix substitution not handeling swapping sides --- .../apron/pentagonSubDomains.apron.ml | 72 +++++++++++-------- 1 file changed, 43 insertions(+), 29 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 3ec8b784f6..c8fb8b8241 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1246,6 +1246,13 @@ module ArbitraryCoeffsSet = struct let t' = CoeffMap.fold fold_fun t CoeffMap.empty in if CoeffMap.is_empty t' then None else Some t' + let swap_sides t = + let fold_fun k c acc = + let (k', c') = LinearInequality.swap_sides (k,c) in + CoeffMap.add k' c' acc + in + CoeffMap.fold fold_fun t CoeffMap.empty + let invariant env x y t acc = CoeffMap.fold (LinearInequality.invariant env x y) t acc end @@ -1351,9 +1358,9 @@ module LinearInequalities: TwoVarInequalities = struct if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (List.fold (fun acc (var,value) -> Printf.sprintf "var_%d: %s, %s" var (Value.show value) acc) "" refine_acc); res, refine_acc - (*TODO switching sides ov variables because of substitution??*) let substitute t i (coeff, j, offs, divi) = let fold_x x ys acc = + (*check for contradictions if both sides refer to the same variable*) let check_for_contradiction cs = let check_single k c = match k with @@ -1363,34 +1370,42 @@ module LinearInequalities: TwoVarInequalities = struct in Coeffs.CoeffMap.iter check_single cs in if x < i then - let ys' = match IntMap.find_opt i ys with - | None -> Some ys - | Some cs -> - let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in - if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictions*) - (check_for_contradiction cs'; None) - else - let combine = function - | None -> Some cs' - | Some cs_j -> Some (Coeffs.meet Value.top Value.top cs' cs_j) - in Some (IntMap.update_stdlib j combine (IntMap.remove i ys)) - in match ys' with - | Some ys' -> IntMap.add x ys' acc - | _ -> acc + match IntMap.find_opt i ys with + | None -> acc + | Some cs -> + let ys' = IntMap.remove i ys in + let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in + if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictions*) + (check_for_contradiction cs'; IntMap.add x ys' acc) + else if x < j then + let cs_j = IntMap.find_default (Coeffs.empty) j ys' in + let cs_new = Coeffs.meet Value.top Value.top cs' cs_j in + let ys'' = if Coeffs.CoeffMap.is_empty cs_new then ys' else IntMap.add j cs_new ys' in + if IntMap.is_empty ys'' then IntMap.remove x acc else IntMap.add x ys'' acc + else (*x > j -> swap sides and add to correct map*) + let cs'' = Coeffs.swap_sides cs' in + let acc' = if IntMap.is_empty ys' then IntMap.remove x acc else IntMap.add x ys' acc in + let cs_x_j = BatOption.default Coeffs.empty @@ get_coeff j x acc' in + let cs_new = Coeffs.meet Value.top Value.top cs'' cs_x_j in + if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff x j cs_new acc' else if x = i then - let convert y cs = - let tranformed = Coeffs.substitute_left (coeff, offs, divi) cs in - if y = j - then (check_for_contradiction tranformed; None) - else Some tranformed - in let ys' = IntMap.filter_map convert ys in - if IntMap.is_empty ys' then - acc - else - let combine = function - | None -> Some ys' - | Some js -> Some (IntMap.union (fun y c1 c2 -> Some (Coeffs.meet Value.top Value.top c1 c2)) ys' js) - in IntMap.update_stdlib j combine acc + let acc' = IntMap.remove x acc in + let fold_y y cs acc = + let cs' = Coeffs.substitute_left (coeff, offs, divi) cs in + if j < y then + let cs_j_y = BatOption.default Coeffs.empty @@ get_coeff j y acc' in + let cs_new = Coeffs.meet Value.top Value.top cs' cs_j_y in + if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff j y cs_new acc' + else if j = y then begin + check_for_contradiction cs'; + acc' + end else + let cs'' = Coeffs.swap_sides cs' in + let cs_y_j = BatOption.default Coeffs.empty @@ get_coeff y j acc' in + let cs_new = Coeffs.meet Value.top Value.top cs'' cs_y_j in + if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff y j cs_new acc' + in + IntMap.fold fold_y ys acc' else acc in IntMap.fold fold_x t IntMap.empty @@ -1505,7 +1520,6 @@ end (*TODOs:*) (*! ArbitraryCoeaffsList meet_single: be sure about rounding*) -(*!!substitute: swap side if necessary*) (*+ Why do inverted conditions work strangely?*) (*+ From c3a6db2cb79e081ac4e98653fb27f6197016bae1 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 3 May 2025 01:45:51 +0200 Subject: [PATCH 55/86] small fixes --- src/cdomains/apron/pentagonSubDomains.apron.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index c8fb8b8241..3af4c09a5b 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -887,7 +887,7 @@ module LinearInequality = struct | LT _ -> LT s' | GT _ -> GT s' in if Q.lt f Q.zero - then (negate k', Q.neg o') + then (negate k', o') else k', o' let swap_sides (k,o) = @@ -1134,7 +1134,9 @@ module ArbitraryCoeffsSet = struct | GT _ -> Q.lt c' c in match get_best_offset (Key.negate k) t with - | Some c' when contradicts c' -> raise EConj.Contradiction + | Some c' when contradicts c' -> + if M.tracing then M.trace "meet" "single_ineq new: %s contradicts existing information %s" (LinearInequality.show "x" "y" (k,c)) (show_formatted "x" "y" t); + raise EConj.Contradiction (*TODO if c = c', then we have an equality -> maybe we can update the econj domain *) | _ -> (*add the inequality, while making sure that we do not save redundant inequalities*) @@ -1408,11 +1410,12 @@ module LinearInequalities: TwoVarInequalities = struct IntMap.fold fold_y ys acc' else acc - in IntMap.fold fold_x t IntMap.empty + in IntMap.fold fold_x t t let substitute t i (c,j,o,d) = + if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s" i (show t) (Rhs.show (Some (c,j), o, d)); let res = substitute t i (c,j,o,d) in - if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s -> %s" i (show t) (Rhs.show (Some (c,j), o, d)) (show res); + if M.tracing then M.trace "substitute" "resulting in %s" (show res); res let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = From 8c4de9f73146cefcdeedf946ca5182995a6894f9 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 3 May 2025 14:40:24 +0200 Subject: [PATCH 56/86] renaming GT/LT to GE/LE to better reflect current purpose. Bugfixing in swapsides and substitute --- .../apron/pentagonSubDomains.apron.ml | 216 +++++++++--------- 1 file changed, 106 insertions(+), 110 deletions(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 3af4c09a5b..a68b57bbaf 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -727,31 +727,31 @@ module LinearInequality = struct (*Normalised representation of an inequality through the origin a/b x <= y (or >=) bzw. slope and direction. infinite slope represents 0 <= x / 0 >= x*) module OriginInequality = struct (*Separate module so we can use it as key in a map*) - type t = LT of Q.t | GT of Q.t (*TODO rename into LE / GE*) + type t = LE of Q.t | GE of Q.t (*TODO rename into LE / GE*) (*make the representation of inequalities without y unique*) let norm = function - | GT s when Q.equal s Q.minus_inf -> LT Q.inf - | LT s when Q.equal s Q.minus_inf -> GT Q.inf + | GE s when Q.equal s Q.minus_inf -> LE Q.inf + | LE s when Q.equal s Q.minus_inf -> GE Q.inf | t -> t (*We want the inequalities to be ordered by angle (with arbitrary start point and direction), which is tan(slope) (+ pi for other direction) *) - (*because tan is monotone, we can simply sort by slope: LT < GT, LT ordered by a, GT ordered by -a*) + (*because tan is monotone, we can simply sort by slope: LE < GE, LE ordered by a, GE ordered by -a*) let compare t1 t2 = match t1, t2 with - | LT _, GT _ -> -1 - | GT _, LT _ -> 1 - | LT a1, LT a2 -> Q.compare a1 a2 - | GT a1, GT a2 -> -(Q.compare a1 a2) + | LE _, GE _ -> -1 + | GE _, LE _ -> 1 + | LE a1, LE a2 -> Q.compare a1 a2 + | GE a1, GE a2 -> -(Q.compare a1 a2) let equal t1 t2 = 0 = compare t1 t2 - let hash = function LT q -> qhash q | GT q -> 7 * qhash q + let hash = function LE q -> qhash q | GE q -> 7 * qhash q - let get_slope = function LT a -> a | GT a -> a + let get_slope = function LE a -> a | GE a -> a let negate = function - | LT s -> GT s - | GT s -> LT s + | LE s -> GE s + | GE s -> LE s end @@ -774,17 +774,17 @@ module LinearInequality = struct let s = OriginInequality.get_slope k in Printf.sprintf "%s%s %s%s" (show_var (Q.num s) x true) - (match k with LT _ -> "<=" | GT _ -> ">=") + (match k with LE _ -> "<=" | GE _ -> ">=") (show_var (Q.den s) y (Q.equal c Q.zero)) (show_offset @@ if Q.equal s Q.inf then c else Q.mul c @@ Q.of_bigint @@ Q.den s ) (*Convert into coefficients of inequality ax + by <= c Useful because the TVLI paper (DOI: 10.1007/3-540-45013-0_7) uses this representation *) let to_coeffs = function - | OriginInequality.LT s, c when Q.equal s Q.inf -> (Q.one,Q.zero,c) - | GT s, c when Q.equal s Q.inf -> (Q.minus_one, Q.zero, Q.neg c) - | LT s, c -> (s,Q.minus_one,c) - | GT s, c -> (Q.neg s, Q.one, Q.neg c) + | OriginInequality.LE s, c when Q.equal s Q.inf -> (Q.one,Q.zero,c) + | GE s, c when Q.equal s Q.inf -> (Q.minus_one, Q.zero, Q.neg c) + | LE s, c -> (s,Q.minus_one,c) + | GE s, c -> (Q.neg s, Q.one, Q.neg c) let to_coeffs t = let a,b,c as res = to_coeffs t in @@ -792,7 +792,7 @@ module LinearInequality = struct res (*From TVLI: check if one or two inequalities imply an inequality*) - let entails1 (s1,c1) (s2,c2) = OriginInequality.equal s1 s2 && match s1 with LT _ -> Q.leq c1 c2 | GT _ -> Q.geq c1 c2 + let entails1 (s1,c1) (s2,c2) = OriginInequality.equal s1 s2 && match s1 with LE _ -> Q.leq c1 c2 | GE _ -> Q.geq c1 c2 let entails1 t1 t2 = let res = entails1 t1 t2 in @@ -834,23 +834,23 @@ module LinearInequality = struct then None else let c = l1 * c1 + l2 * c2 in - let c' = match k with LT _ -> c | GT _ -> neg c in + let c' = match k with LE _ -> c | GE _ -> neg c in Some c' (*convert interval information into inequalities*) let from_values x_val y_val = let open OriginInequality in let ineqs = match Value.maximal x_val with - | Some (Int z) -> (*x <= z *) [LT Q.inf, Q.of_bigint z] + | Some (Int z) -> (*x <= z *) [LE Q.inf, Q.of_bigint z] | _ -> [] in let ineqs = match Value.minimal x_val with - | Some (Int z) -> (*x >= z *) (GT Q.inf, Q.of_bigint z) :: ineqs + | Some (Int z) -> (*x >= z *) (GE Q.inf, Q.of_bigint z) :: ineqs | _ -> ineqs in let ineqs = match Value.maximal y_val with - | Some (Int z) -> (*y <= z *) (GT Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs + | Some (Int z) -> (*y <= z *) (GE Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs | _ -> ineqs in let ineqs = match Value.minimal y_val with - | Some (Int z) -> (*y >= z *) (LT Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs + | Some (Int z) -> (*y >= z *) (LE Q.zero, Q.neg @@ Q.of_bigint z ) :: ineqs | _ -> ineqs in ineqs @@ -860,10 +860,10 @@ module LinearInequality = struct let a,b,c = (Q.make cx dx, Q.make cy dy, Q.add non_strict_offset @@ Q.sub (Q.make oy dy) (Q.make ox dx)) in (*subtracting one to convert it into a nonstrict inequality*) let s = Q.div a b in if Q.equal b Q.zero - then OriginInequality.norm (LT s), Q.div c a + then OriginInequality.norm (LE s), Q.div c a else if Q.gt b Q.zero - then LT s, Q.div c b - else GT s, Q.div c b + then LE s, Q.div c b + else GE s, Q.div c b (*apply the transformation to the variable on the left side*) @@ -873,8 +873,8 @@ module LinearInequality = struct let s' = Q.mul s (Q.make coeff divi) in let o' = Q.sub o @@ Q.mul s @@ Q.make offs divi in match k with - | LT _ -> LT s', o' - | GT _ -> GT s', o' + | LE _ -> LE s', o' + | GE _ -> GE s', o' (*apply the transformation to the variable on the right side*) let substitute_right (coeff, offs, divi) (k,o) = @@ -884,8 +884,8 @@ module LinearInequality = struct let s' = Q.div s f in let o' = Q.add (Q.div o f) @@ Q.make offs coeff in let k' = match k with - | LT _ -> LT s' - | GT _ -> GT s' + | LE _ -> LE s' + | GE _ -> GE s' in if Q.lt f Q.zero then (negate k', o') else k', o' @@ -894,10 +894,10 @@ module LinearInequality = struct let open Q in let open OriginInequality in match k with - | LT s when s < zero -> (GT (inv s), - (o / s)) - | LT s -> (LT (inv s), - (o / s)) - | GT s when s < zero -> (LT (inv s), - (o / s)) - | GT s -> (GT (inv s), - (o / s)) + | LE s when s < zero -> (LE (inv s), - (o / s)) + | LE s -> (GE (inv s), - (o / s)) + | GE s when s < zero -> (GE (inv s), - (o / s)) + | GE s -> (LE (inv s), - (o / s)) (*combine an inequaliy x_old -> x_new with x_old -> y to x_new -> y*) let combine_left (k_rel, o_rel) (k, o) = @@ -906,10 +906,10 @@ module LinearInequality = struct let f = Q.div (get_slope k) (get_slope k_rel) in let k_rel' = if Q.geq f Q.zero then k_rel else negate k_rel in match k_rel', k with - | LT _, LT _ - | GT _, GT _ -> None (*no useable inequality x_new -> y*) - | GT _, LT _ -> Some (LT f, Q.sub o (Q.mul f o_rel)) - | LT _, GT _ -> Some (GT f, Q.sub o (Q.mul f o_rel)) + | LE _, LE _ + | GE _, GE _ -> None (*no useable inequality x_new -> y*) + | GE _, LE _ -> Some (LE f, Q.sub o (Q.mul f o_rel)) + | LE _, GE _ -> Some (GE f, Q.sub o (Q.mul f o_rel)) (*combine an inequaliy y_old -> y_new with x -> y_old to x-> y_new*) let combine_right (k_rel, o_rel) (k, o) = @@ -918,16 +918,16 @@ module LinearInequality = struct let f = (get_slope k) in let k' = if Q.geq f Q.zero then k else negate k in match k_rel, k' with - | LT _, GT _ - | GT _, LT _ -> None - | LT s_rel, LT s -> Some (LT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) - | GT s_rel, GT s -> Some (GT (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + | LE _, GE _ + | GE _, LE _ -> None + | LE s_rel, LE s -> Some (LE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + | GE s_rel, GE s -> Some (GE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) let invariant env x y k o acc = (*for LE, we need to swap signs of all coefficients*) let s, o = match k with - | OriginInequality.LT s -> Q.neg s, Q.neg o - | GT s -> s, o + | OriginInequality.LE s -> Q.neg s, Q.neg o + | GE s -> s, o in let o' = if Q.equal s Q.inf then Q.neg o else Q.neg @@ Q.mul o @@ Q.of_bigint @@ Q.den s in let coeffs = [ @@ -1086,25 +1086,25 @@ module ArbitraryCoeffsSet = struct | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_y with - | Int max -> [x, Value.ending @@ Z.add max @@ round_up @@ Q.div c s] (*TODO I'm not sure anymore: why are we rounding up?*) + | Int max -> [x, Value.ending @@ Z.add max @@ round_down @@ Q.div c s] | _ -> [] in let lower_bound s = (*x >= y / s + c / s*) let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_y with - | Int min -> [x, Value.starting @@ Z.add min @@ round_down @@ Q.div c s] + | Int min -> [x, Value.starting @@ Z.add min @@ round_up @@ Q.div c s] | _ -> [] in match k with - | LT s when Q.sign s > 0 -> upper_bound s - | GT s when Q.sign s < 0 -> upper_bound s - | LT s when Q.sign s < 0 -> lower_bound s - | GT s when Q.sign s > 0 -> lower_bound s + | LE s when Q.sign s > 0 -> upper_bound s + | GE s when Q.sign s < 0 -> upper_bound s + | LE s when Q.sign s < 0 -> lower_bound s + | GE s when Q.sign s > 0 -> lower_bound s | _ -> [] (*Should never be used in this case*) in let y_refine = match k with - | LT s -> begin (*sx -c <= y*) + | LE s -> begin (*sx -c <= y*) let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" @@ -1112,7 +1112,7 @@ module ArbitraryCoeffsSet = struct | Int min -> [y, Value.starting @@ Z.sub min @@ round_up c] | _ -> [] end - | GT s -> (*s x - c >= y*) + | GE s -> (*s x - c >= y*) let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" @@ -1120,18 +1120,18 @@ module ArbitraryCoeffsSet = struct | Int max -> [y, Value.ending @@ Z.sub max @@ round_down c] | _ -> [] in match k with - | LT s when Q.equal Q.zero s -> (* -c >= y *) [y, Value.ending @@ round_up @@ Q.neg c] , true - | GT s when Q.equal Q.zero s -> (* -c <= y *) [y, Value.starting @@ round_down @@ Q.neg c] , true - | LT s when Q.equal Q.inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true - | GT s when Q.equal Q.minus_inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true - | LT s when Q.equal Q.minus_inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true - | GT s when Q.equal Q.inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true + | LE s when Q.equal Q.zero s -> (* -c >= y *) [y, Value.ending @@ round_up @@ Q.neg c] , true + | GE s when Q.equal Q.zero s -> (* -c <= y *) [y, Value.starting @@ round_down @@ Q.neg c] , true + | LE s when Q.equal Q.inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true + | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true + | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true + | GE s when Q.equal Q.inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true | k -> (*an actual inequality *) x_refine @ y_refine, false in if skip_adding then t, refinements else (*Look for contradicting inequality*) let contradicts c' = match k with - | LT _ -> Q.gt c' c - | GT _ -> Q.lt c' c + | LE _ -> Q.gt c' c + | GE _ -> Q.lt c' c in match get_best_offset (Key.negate k) t with | Some c' when contradicts c' -> @@ -1208,7 +1208,7 @@ module ArbitraryCoeffsSet = struct in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) in let merged = CoeffMap.fold add_inequality t2_filtered' t1_filtered' (*remove the explicetly stored interval inequalities*) - in ignore_empty @@ CoeffMap.remove (LT Q.zero) @@ CoeffMap.remove (GT Q.zero) @@ CoeffMap.remove (LT Q.inf) @@ CoeffMap.remove (GT Q.inf) merged + in ignore_empty @@ CoeffMap.remove (LE Q.zero) @@ CoeffMap.remove (GE Q.zero) @@ CoeffMap.remove (LE Q.inf) @@ CoeffMap.remove (GE Q.inf) merged let join = join' false let widen = join' true @@ -1328,11 +1328,11 @@ module LinearInequalities: TwoVarInequalities = struct let s = Coeffs.Key.get_slope k in if Q.equal Q.one s then (* x <= x + c (or >=) *) match k with - | LT _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - | GT _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) else (* sx <= x + c (or =>) -> refine the value in this case*) let s' = Q.sub s Q.one in - let s', c' = match k with LT _ -> s',c | GT _ -> Q.neg s', Q.neg c in + let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in (*s'x <= c' *) if Q.gt s' Q.zero then let max = Q.div c' s' in @@ -1361,56 +1361,52 @@ module LinearInequalities: TwoVarInequalities = struct res, refine_acc let substitute t i (coeff, j, offs, divi) = + (*check for contradictions if both sides refer to the same variable*) + let check_for_contradiction cs = + let check_single k c = + match k with + | LinearInequality.OriginInequality.LE s when Q.equal s Q.one -> if Q.lt c Q.zero then raise EConj.Contradiction + | GE s when Q.equal s Q.one -> if Q.gt c Q.zero then raise EConj.Contradiction + | _ -> () (*TODO value refinement?*) + in Coeffs.CoeffMap.iter check_single cs + in + (*add to bindings, meeting with existing if necessary*) + let merge_single x y cs_new t = + let cs_curr = BatOption.default Coeffs.empty @@ get_coeff x y t in + let cs_combined = Coeffs.meet Value.top Value.top cs_new cs_curr in + if Coeffs.CoeffMap.is_empty cs_combined then t else set_coeff x y cs_combined t + in + let merge_ys x ys t = IntMap.fold (merge_single x) ys t in let fold_x x ys acc = - (*check for contradictions if both sides refer to the same variable*) - let check_for_contradiction cs = - let check_single k c = - match k with - | Coeffs.Key.LT s when Q.equal s Q.one -> if Q.lt c Q.zero then raise EConj.Contradiction - | GT s when Q.equal s Q.one -> if Q.gt c Q.zero then raise EConj.Contradiction - | _ -> () (*TODO value refinement?*) - in Coeffs.CoeffMap.iter check_single cs - in if x < i then match IntMap.find_opt i ys with - | None -> acc + | None -> merge_ys x ys acc | Some cs -> let ys' = IntMap.remove i ys in + let acc' = merge_ys x ys' acc in (*everything else is added unchanged*) let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in - if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictions*) - (check_for_contradiction cs'; IntMap.add x ys' acc) + if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictionsand do not add*) + (check_for_contradiction cs'; acc') else if x < j then - let cs_j = IntMap.find_default (Coeffs.empty) j ys' in - let cs_new = Coeffs.meet Value.top Value.top cs' cs_j in - let ys'' = if Coeffs.CoeffMap.is_empty cs_new then ys' else IntMap.add j cs_new ys' in - if IntMap.is_empty ys'' then IntMap.remove x acc else IntMap.add x ys'' acc - else (*x > j -> swap sides and add to correct map*) + merge_single x j cs' acc' + else (*x > j -> swap sides*) let cs'' = Coeffs.swap_sides cs' in - let acc' = if IntMap.is_empty ys' then IntMap.remove x acc else IntMap.add x ys' acc in - let cs_x_j = BatOption.default Coeffs.empty @@ get_coeff j x acc' in - let cs_new = Coeffs.meet Value.top Value.top cs'' cs_x_j in - if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff x j cs_new acc' + merge_single x j cs'' acc' else if x = i then - let acc' = IntMap.remove x acc in let fold_y y cs acc = let cs' = Coeffs.substitute_left (coeff, offs, divi) cs in if j < y then - let cs_j_y = BatOption.default Coeffs.empty @@ get_coeff j y acc' in - let cs_new = Coeffs.meet Value.top Value.top cs' cs_j_y in - if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff j y cs_new acc' + merge_single j y cs' acc else if j = y then begin - check_for_contradiction cs'; - acc' + check_for_contradiction cs'; acc end else let cs'' = Coeffs.swap_sides cs' in - let cs_y_j = BatOption.default Coeffs.empty @@ get_coeff y j acc' in - let cs_new = Coeffs.meet Value.top Value.top cs'' cs_y_j in - if Coeffs.CoeffMap.is_empty cs_new then acc' else set_coeff y j cs_new acc' + merge_single y j cs'' acc in - IntMap.fold fold_y ys acc' + IntMap.fold fold_y ys acc else - acc - in IntMap.fold fold_x t t + merge_ys x ys acc + in IntMap.fold fold_x t IntMap.empty let substitute t i (c,j,o,d) = if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s" i (show t) (Rhs.show (Some (c,j), o, d)); @@ -1502,7 +1498,7 @@ module LinearInequalities: TwoVarInequalities = struct (*relations between the old representant and the other variable*) in let coeffs_old = BatOption.default Coeffs.empty @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in let add_single_slope c_acc s = - let ineqs = [LinearInequality.OriginInequality.LT s, Q.zero; GT s, Q.zero;] + let ineqs = [LinearInequality.OriginInequality.LE s, Q.zero; GE s, Q.zero;] in let copy_single_ineq c_acc ineq = let k_old = fst @@ convert_to_old ineq in (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) @@ -1522,18 +1518,17 @@ end (*TODOs:*) -(*! ArbitraryCoeaffsList meet_single: be sure about rounding*) -(*+ Why do inverted conditions work strangely?*) -(*+ - ArbitraryCoeaffsList meet_single: take intervals into account better - re-add them every time, remove them afterwards and update interval with this information - ArbitraryCoeaffsList.meet + affine_transform -> refinement - refinement of equalities must be limited to have acceptable runtimes! - substitute refinement - set_rhs constant refinement - meet_relations: refinement of intervals if var is constant - meet_relations: do some transitivity ! +(*++ + ArbitraryCoeaffsList meet_single: take intervals into account better + re-add them every time, remove them afterwards and update interval with this information + ArbitraryCoeaffsList.meet + affine_transform -> refinement + refinement of equalities must be limited to have acceptable runtimes! + substitute refinement + set_rhs constant refinement + meet_relations: refinement of intervals if var is constant + + *) (*-- assign expr restore ineqs based on value *) @@ -1542,10 +1537,12 @@ end (*+ look at complexities. I expect for all: (n² log n) *) (*+ How to do a useful narrow?*) +(* meet_relations: do some transitivity: possible in complexity, but maybe expensive!*) (* widening thresholds: from offsets of rhs?*) (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*- copy_to_new: introduces too many inequlities?*) +(*+ Why do inverted conditions work strangely?*) (*+ redo simple equalities (take advantage of the offset!, affine transform)*) (* domain inbetween these two: with offset between roots? -> should be trivial to implement*) (*- better to_inequalities? with query?*) @@ -1556,7 +1553,6 @@ end (*- leq performance?*) (*--eval_int: answer nonlinear*) (*! general renaming*) -(*+ rename constuctor in OriginInequality into LE / GE*) (*!!rebase to main branch*) (*!!documentation (failing check!!) *) \ No newline at end of file From 41f69c2d26c5ab7ff249a1dbb511961625d01707 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 3 May 2025 16:24:37 +0200 Subject: [PATCH 57/86] small fix: order correctly --- src/cdomains/apron/pentagonSubDomains.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index a68b57bbaf..99512a74b5 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1391,7 +1391,7 @@ module LinearInequalities: TwoVarInequalities = struct merge_single x j cs' acc' else (*x > j -> swap sides*) let cs'' = Coeffs.swap_sides cs' in - merge_single x j cs'' acc' + merge_single j x cs'' acc' else if x = i then let fold_y y cs acc = let cs' = Coeffs.substitute_left (coeff, offs, divi) cs in From 992c54c7b123e439713992e3a4c0c87dd025ac39 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 3 May 2025 23:41:22 +0200 Subject: [PATCH 58/86] refinement: general structure, allow for equality refinement, refine values from inequalities --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 40 ++++++-- .../apron/pentagonSubDomains.apron.ml | 97 ++++++++++++++----- .../82-lin2vareq_p/03-loop_increment.c | 18 ++-- 3 files changed, 115 insertions(+), 40 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index c8cf944597..19652ce8be 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -239,10 +239,10 @@ struct let value = get_value t x in if vary = None then begin if d <> Z.one then - (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (var,offs,divi)); + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, which is not an integer" i (Rhs.show (vary,o,d)); raise EConj.Contradiction); - if not @@ Value.contains value (Z.div offs divi) then - (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (var,offs,divi)) (Value.show value); + if not @@ Value.contains value (Z.div o d) then + (if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj substituting var_%d with constant %s, Contradicts %s" (i) (Rhs.show (vary,o,d)) (Value.show value); raise EConj.Contradiction) end; let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) @@ -312,6 +312,31 @@ struct in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res + let apply_refinements (refs : Refinement.t) (t:t) = + let apply_single t = function + | var, Either.Left value -> + begin try + meet_with_one_value var value t false + with EConj.Contradiction -> + if M.tracing then M.trace "refinements" "Contradiction when applying var_%d=%s in %s" var (Value.show value) (show t); + raise EConj.Contradiction + end + | var, Right rhs -> + begin try + meet_with_one_conj t var rhs + with EConj.Contradiction -> + if M.tracing then M.trace "refinements" "Contradiction when applying var_%d=%s in %s" var (Rhs.show rhs) (show t); + raise EConj.Contradiction + end + in + List.fold apply_single t refs + + let apply_refinements refs t = + if M.tracing then M.trace "refinements" "applying %s to %s" (Refinement.show refs) (show t); + let res = apply_refinements refs t in + if M.tracing then M.trace "refinements" "resulted in %s" (show res); + res + end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -768,12 +793,7 @@ struct | _ -> ineq, refine end | _, _,_ -> ineq, [] - in let d' = (econ, vs, ineq') - in let refine_value d (var,value) = - let res = EConjI.meet_with_one_value var value d false in - if M.tracing then M.tracel "refine_tcons" "refinement from ineq: var_%d: %s => %s -> %s" var (Value.show value) (EConjI.show d) (EConjI.show res); - res - in List.fold (refine_value) d' value_refinements + in EConjI.apply_refinements value_refinements (econ, vs, ineq') in match expr with (*TODO we could do this in a more general way -> normalisation??*) (*currently only hits if two variables are at the first two levels. Also, we only choose one pattern even if multiple are possible e.g. x + y - z arbitrarily selects x or y to convert into an interval, instead we could meet for both*) @@ -1031,7 +1051,7 @@ struct let dim = Environment.dim_of_var t.env var in if dim <> var_i then let ineq', refinements = Ineq.meet_relation var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq - in List.fold (fun d (var,value) -> EConjI.meet_with_one_value var value d false) (e,v,ineq') refinements + in EConjI.apply_refinements refinements (e,v,ineq') else e,v,Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') in diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 99512a74b5..f065dc0acf 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -348,6 +348,24 @@ module Relation = struct | Gt, Lt -> None end +module Refinement = struct + type t = (int * (Value.t, Rhs.t) Either.t) list + + let show_formatted_single formatter (var, ref) = + let rhs = match ref with + | Either.Left x -> Value.show x + | Right x -> Rhs.show_rhs_formatted formatter x + in + Printf.sprintf "%s = %s" (formatter var) rhs + + let show_formatted formatter t = "[" ^ List.fold (fun acc r -> Printf.sprintf "%s, %s" (show_formatted_single formatter r) acc) "]" t + + let show = show_formatted (fun x -> "var_"^Int.to_string x) + + let of_value var v = (var, Either.Left v) + let of_rhs var r = (var, Either.right r) + +end module type TwoVarInequalities = sig type t @@ -356,7 +374,7 @@ module type TwoVarInequalities = sig val get_relations : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> Relation.t list (*meet relation between two variables. also returns a list of value refinements *) - val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * (int * Value.t) list + val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * Refinement.t (*substitutes all occurences of a variable by a rhs*) val substitute : t -> int -> Z.t * int * Z.t * Z.t -> t @@ -1075,25 +1093,25 @@ module ArbitraryCoeffsSet = struct let meet_single_inequality refine_data narrow x_val y_val k c t = (*calculate value refine. If one of the coefficients is zero, we should not add it to the map*) + let round_up q = Z.cdiv (Q.num q) (Q.den q) in + let round_down q = Z.fdiv (Q.num q) (Q.den q) in let refinements, skip_adding = match refine_data with | None -> [], (Q.equal Q.zero @@ Key.get_slope k) || not @@ Q.is_real @@ Key.get_slope k | Some (x,y) -> - let round_up q = Z.cdiv (Q.num q) (Q.den q) in - let round_down q = Z.fdiv (Q.num q) (Q.den q) in let x_refine = let upper_bound s = (*x <= y / s + c / s*) let max_y = match Value.maximal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_y with - | Int max -> [x, Value.ending @@ Z.add max @@ round_down @@ Q.div c s] + | Int max -> [Refinement.of_value x (Value.ending @@ Z.add max @@ round_down @@ Q.div c s)] | _ -> [] in let lower_bound s = (*x >= y / s + c / s*) let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_y with - | Int min -> [x, Value.starting @@ Z.add min @@ round_up @@ Q.div c s] + | Int min -> [Refinement.of_value x (Value.starting @@ Z.add min @@ round_up @@ Q.div c s)] | _ -> [] in match k with @@ -1109,7 +1127,7 @@ module ArbitraryCoeffsSet = struct | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" in match min_x with - | Int min -> [y, Value.starting @@ Z.sub min @@ round_up c] + | Int min -> [Refinement.of_value y (Value.starting @@ Z.sub min @@ round_up c)] | _ -> [] end | GE s -> (*s x - c >= y*) @@ -1117,15 +1135,15 @@ module ArbitraryCoeffsSet = struct | Some a, Some b -> TopIntOps.max a b | _,_ -> failwith "trying to refine bot in inequalities" in match max_x with - | Int max -> [y, Value.ending @@ Z.sub max @@ round_down c] + | Int max -> [Refinement.of_value y (Value.ending @@ Z.sub max @@ round_down c)] | _ -> [] in match k with - | LE s when Q.equal Q.zero s -> (* -c >= y *) [y, Value.ending @@ round_up @@ Q.neg c] , true - | GE s when Q.equal Q.zero s -> (* -c <= y *) [y, Value.starting @@ round_down @@ Q.neg c] , true - | LE s when Q.equal Q.inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true - | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [x, Value.starting @@ round_down c ], true - | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true - | GE s when Q.equal Q.inf s -> (*x <= c*) [x, Value.ending @@ round_up c], true + | LE s when Q.equal Q.zero s -> (* -c >= y *) [Refinement.of_value y @@ Value.ending @@ round_up @@ Q.neg c] , true + | GE s when Q.equal Q.zero s -> (* -c <= y *) [Refinement.of_value y @@ Value.starting @@ round_down @@ Q.neg c] , true + | LE s when Q.equal Q.inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true + | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true + | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true + | GE s when Q.equal Q.inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true | k -> (*an actual inequality *) x_refine @ y_refine, false in if skip_adding then t, refinements else (*Look for contradicting inequality*) @@ -1137,14 +1155,51 @@ module ArbitraryCoeffsSet = struct | Some c' when contradicts c' -> if M.tracing then M.trace "meet" "single_ineq new: %s contradicts existing information %s" (LinearInequality.show "x" "y" (k,c)) (show_formatted "x" "y" t); raise EConj.Contradiction - (*TODO if c = c', then we have an equality -> maybe we can update the econj domain *) + (*we have an equality -> update the econj domain sn / sd x = y + cn/cd -> x = (sd y cd + sd cn) / sn cd *) + | Some c' when c = c' -> begin + let s = Key.get_slope k in + let sn, sd = Q.num s, Q.den s in + let cn, cd = Q.num c, Q.den c in + let open Z in + match refine_data with + | Some (x,y) -> + if M.tracing then begin + let show_var = (fun x -> "var_"^Int.to_string x) in + M.trace "refinements" "single_ineq new: %s with %s results in equality" + (LinearInequality.show (show_var x) (show_var y) (k,c)) + (show_formatted (show_var x) (show_var y) t) + end; + t, (Refinement.of_rhs x @@ Rhs.canonicalize (Some (sd * cd, y), sd*cn, sn * cd)) :: refinements + | _ -> t, [] + end | _ -> (*add the inequality, while making sure that we do not save redundant inequalities*) (*TODO make this consider the intervals! -> adapt get_next and get_previous?*) let t' = match CoeffMap.find_opt k t with | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) (*TODO narrow?*) | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) - in t', refinements (*TODO: lookup the best interval information from the inequalities!*) + in + (*lookup the best interval bounds from the inequalities!*) + match refine_data with + | Some (x,y) -> + let refinements = match get_best_offset (LE Q.inf) t' with + | Some upper -> (Refinement.of_value x @@ Value.ending @@ round_down upper ):: refinements + | _ -> refinements + in + let refinements = match get_best_offset (GE Q.inf) t' with + | Some lower -> (Refinement.of_value x @@ Value.starting @@ round_up lower ):: refinements + | _ -> refinements + in + let refinements = match get_best_offset (GE Q.zero) t' with + | Some upper -> (Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg upper ):: refinements + | _ -> refinements + in + let refinements = match get_best_offset (LE Q.zero) t' with + | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: refinements + | _ -> refinements + in + t', refinements + | _ -> t', refinements (*when meeting, the values should already been refined before -> ignore the refinement data*) (*TODO is this actually true?*) let meet' narrow x_val y_val t1 t2 = CoeffMap.fold (fun k c t -> fst @@ meet_single_inequality None narrow x_val y_val k c t) t1 t2 @@ -1336,10 +1391,10 @@ module LinearInequalities: TwoVarInequalities = struct (*s'x <= c' *) if Q.gt s' Q.zero then let max = Q.div c' s' in - t, [x, Value.ending @@ Z.cdiv (Q.num max) (Q.den max)] + t, [x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))] else let min = Q.div c' s' in - t, [x, Value.starting @@ Z.fdiv (Q.num min) (Q.den min)] + t, [x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))] else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in @@ -1357,7 +1412,7 @@ module LinearInequalities: TwoVarInequalities = struct let meet_relation x y c r v t = if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); let res, refine_acc = meet_relation x y c r v t in - if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (List.fold (fun acc (var,value) -> Printf.sprintf "var_%d: %s, %s" var (Value.show value) acc) "" refine_acc); + if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (Refinement.show refine_acc); res, refine_acc let substitute t i (coeff, j, offs, divi) = @@ -1521,15 +1576,13 @@ end (*++ ArbitraryCoeaffsList meet_single: take intervals into account better - re-add them every time, remove them afterwards and update interval with this information + re-add them every time, remove them afterwards? ArbitraryCoeaffsList.meet + affine_transform -> refinement - refinement of equalities must be limited to have acceptable runtimes! substitute refinement + in those cases: refinement of equalities must be limited to have acceptable runtimes! set_rhs constant refinement meet_relations: refinement of intervals if var is constant - - *) (*-- assign expr restore ineqs based on value *) diff --git a/tests/regression/82-lin2vareq_p/03-loop_increment.c b/tests/regression/82-lin2vareq_p/03-loop_increment.c index 7ed6adef9e..b92c0cb843 100644 --- a/tests/regression/82-lin2vareq_p/03-loop_increment.c +++ b/tests/regression/82-lin2vareq_p/03-loop_increment.c @@ -3,19 +3,21 @@ int main() { int i, j, k; - int size = 5; + int size; //with a fixed size, the inequalities lead to a discovery of exact constants and no relations i = 0; j = 0; k = 5; - for (i = 1; i < size; ++i) { - j = i; - k = j + 5; - } - - __goblint_check(j + 1 == i); // SUCCESS + if (size > 0) { + for (i = 1; i < size; ++i) { + j = i; + k = j + 5; + } - __goblint_check(k == i + 4); // SUCCESS + __goblint_check(j + 1 == i); // SUCCESS + __goblint_check(k == i + 4); // SUCCESS + + } return 0; } From 069d3de4a6cd7c680266a1ff29f311f9002dec13 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sun, 4 May 2025 01:33:59 +0200 Subject: [PATCH 59/86] allow conversion to tcons for inverted conditions --- src/cdomains/apron/pentagonSubDomains.apron.ml | 1 - src/cdomains/apron/sharedFunctions.apron.ml | 6 ++++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index f065dc0acf..774fbce8bb 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -1595,7 +1595,6 @@ end (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*- copy_to_new: introduces too many inequlities?*) -(*+ Why do inverted conditions work strangely?*) (*+ redo simple equalities (take advantage of the offset!, affine transform)*) (* domain inbetween these two: with offset between roots? -> should be trivial to implement*) (*- better to_inequalities? with query?*) diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index fd6c578e60..a4e3f26a66 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -211,6 +211,12 @@ struct let tcons1_of_cil_exp ask d env e negate no_ov = let e = Cil.constFold false e in + let rec unwrap_inversion e negate = + match e with + | UnOp (LNot,e',_) -> unwrap_inversion e' (not negate) + | _ -> e, negate + in + let e, negate = unwrap_inversion e negate in let (texpr1_plus, texpr1_minus, typ) = match e with | BinOp (r, e1, e2, _) -> From 3ed88f27ed826c2bdbf225855320f26d87c8d9d8 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 6 May 2025 19:07:34 +0200 Subject: [PATCH 60/86] refinement: refinement everywhere + some cleanup --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 107 ++-- .../apron/pentagonSubDomains.apron.ml | 458 +++++++++--------- 2 files changed, 296 insertions(+), 269 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 19652ce8be..efdbab81cc 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -65,15 +65,10 @@ struct (*Does not check the values directly, only the inequality domain, so we can use this to detect contradictions *) - let get_relations ((_,vs,ineq) as t) x y = - let get_information lhs = - let rhs = get_rhs t lhs in - match rhs with - | (Some (_,var), _ ,_) -> (rhs, get_value t var) - (*We need to know which root a constant is referring to, so we use this the trivial equation to carry that information*) - | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) - in - Ineq.get_relations (get_information x) (get_information y) ineq + let get_relations ((_,vs,ineq) as t) x' y' = + match get_rhs t x', get_rhs t y' with + | (Some (c_x, x),o_x,d_x), (Some (c_y, y),o_y,d_y) -> Ineq.get_relations ((c_x, x,o_x,d_x), get_value t x) ((c_y, y,o_y,d_y), get_value t y) ineq + | _, _ -> [] (*One of the variables is a constant -> there are no inequalities*) let get_value t lhs = @@ -199,8 +194,8 @@ struct match newRoot with | None -> (econj'', vs'', Ineq.forget_variable ineq' var) | Some (Some (coeff,y),offs,divi) -> - (*modify inequalities*) - let ineq'' = Ineq.substitute ineq' var (coeff,y,offs,divi) + (*modify inequalities. We ignore refinements as they should not matter in this case*) + let ineq'', _ = Ineq.substitute ineq' var (coeff,y,offs,divi) (*restoring value information*) in set_value (econj'', vs'', ineq'') y @@ get_value d y | _ -> failwith "Should not happen" (*transformation can not be a constant*) @@ -224,7 +219,18 @@ struct let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in (econj'', v'', ineq'')) - let meet_with_one_conj ((ts, is, ineq) as t:t) i (var, offs, divi) = + let meet_with_one_value var value t narrow = + let meet_function = if narrow then Value.narrow else Value.meet in + let new_value = meet_function value (get_value t var) + in if Value.is_bot new_value then raise EConj.Contradiction else + let res = set_value t var new_value (*TODO because we meet with an already saved values, we already confirm to the congruence constraints -> skip calculating them again!*) + in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); + res + + (*TODO make this configureable with options*) + let refine_depth = 5 + + let rec meet_with_one_conj ?(refine_depth = refine_depth) ((ts, is, ineq) as t:t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = let subst_var (((dim,econj), is, ineq) as t) x (vary, o, d) = @@ -248,10 +254,11 @@ struct let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) match vary with | Some (c,y) -> (*x was a representant but is not anymore*) - let ineq' = Ineq.substitute ineq x (c, y, o, d) + let ineq', refinements = Ineq.substitute ineq x (c, y, o, d) in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) let t' = econj', is', ineq' in - set_value t' x value + let t'' = set_value t' x value in + apply_refinements ~refine_depth refinements t'' | None -> econj', IntMap.remove x is, Ineq.forget_variable ineq x (*we replaced x (and all connected vars) by a constant -> do not save a value and inequality anymore*) in (match var, (EConj.get_rhs ts i) with @@ -291,28 +298,7 @@ struct if M.tracing then M.tracel "meet_with_one_conj" "meet_with_one_conj conj: %s eq: var_%d=%s -> %s " (show t) i (Rhs.show (var,offs,divi)) (show res) ; res - let affine_transform (econ, vs, ineq) i rhs = - (*This is a place we want to use the original set_rhs (therefore use EConj directly), as the implied congruence might contradict each other during the transformation*) - (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) - (*This is only called in assign_texpr, after which the value will be set correctly.*) - let (_, (m,o,d)) = EConj.inverse i rhs in - let c,_ = BatOption.get m in - (EConj.affine_transform econ i rhs, vs, Ineq.substitute ineq i (c,i,o,d)) - - let affine_transform econ i (c,v,o,d) = - let res = affine_transform econ i (c,v,o,d) in - if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); - res - - let meet_with_one_value var value t narrow = - let meet_function = if narrow then Value.narrow else Value.meet in - let new_value = meet_function value (get_value t var) - in if Value.is_bot new_value then raise EConj.Contradiction else - let res = set_value t var new_value (*TODO because we meet with an already saved values, we already confirm to the congruence constraints -> skip calculating them again!*) - in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); - res - - let apply_refinements (refs : Refinement.t) (t:t) = + and apply_refinements ?(refine_depth = refine_depth) (refs : Refinement.t) (t:t) = let apply_single t = function | var, Either.Left value -> begin try @@ -323,18 +309,34 @@ struct end | var, Right rhs -> begin try - meet_with_one_conj t var rhs + meet_with_one_conj ~refine_depth:(refine_depth-1) t var rhs with EConj.Contradiction -> if M.tracing then M.trace "refinements" "Contradiction when applying var_%d=%s in %s" var (Rhs.show rhs) (show t); raise EConj.Contradiction end in - List.fold apply_single t refs + if refine_depth > 0 then begin + if M.tracing then M.trace "refinements" "applying %s to %s, remaining depth: %d" (Refinement.show refs) (show t) refine_depth; + let res = List.fold apply_single t refs in + if M.tracing then M.trace "refinements" "resulted in %s" (show res); + res + end else begin + if M.tracing then M.trace "refinements" "call with depth 0 ignored"; + t + end - let apply_refinements refs t = - if M.tracing then M.trace "refinements" "applying %s to %s" (Refinement.show refs) (show t); - let res = apply_refinements refs t in - if M.tracing then M.trace "refinements" "resulted in %s" (show res); + let affine_transform (econ, vs, ineq) i rhs = + (*This is a place we want to use the original set_rhs (therefore use EConj directly), as the implied congruence might contradict each other during the transformation*) + (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) + (*This is only called in assign_texpr, after which the value will be set correctly.*) + let (_, (m,o,d)) = EConj.inverse i rhs in + let c,_ = BatOption.get m in + let ineq', refinements = Ineq.substitute ineq i (c,i,o,d) in + apply_refinements refinements (EConj.affine_transform econ i rhs, vs, ineq') + + let affine_transform econ i (c,v,o,d) = + let res = affine_transform econ i (c,v,o,d) in + if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); res end @@ -854,9 +856,11 @@ struct | None, _ -> t | Some (_,_,ineq), Some ((econ, vs, ineq2) as d) -> try - let new_ineqs = (if narrow then Ineq.narrow else Ineq.meet) (EConjI.get_value d) ineq ineq2 + let new_ineqs, refinements = (if narrow then Ineq.narrow else Ineq.meet) (EConjI.get_value d) ineq ineq2 in let new_ineqs = Ineq.limit econ new_ineqs - in { d = Some (econ, vs, new_ineqs); env = t.env} + in let d' = (econ, vs, new_ineqs) + in let d''= EConjI.apply_refinements refinements d' + in { d = Some d''; env = t.env} with EConj.Contradiction -> if M.tracing then M.trace "meet" " -> Contradiction with inequalities\n"; { d = None; env = t.env} @@ -912,10 +916,9 @@ struct match m with | None -> ineq_acc | Some (c,v) -> - if M.tracing then M.trace "leq" "econ2 not representant: %s with rhs: %s" (Var.show @@ Environment.var_of_dim t2.env var) (Rhs.show (m,o,d)); match EConj.get_rhs econ1 var with - | Some (_,v),_,_ when v <> var -> (if M.tracing then M.trace "leq" "and not representant in econ1 -> do nothing"); ineq_acc - | _ -> (if M.tracing then M.trace "leq" "and representant in econ1 -> transform"); Ineq.substitute ineq_acc var (c,v,o,d) + | Some (_,v),_,_ when v <> var -> ineq_acc + | _ -> let ineq', _ = Ineq.substitute ineq_acc var (c,v,o,d) in ineq' in let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in (*further, econ2 might have some new representants -> transform further*) @@ -951,7 +954,7 @@ struct (*transform the inequalities to represent only representants, and make the inequalities for new representants explicit*) let transform_non_representant var rhs ineq_acc = match rhs with - | (Some (c,v), o, d) when v <> var -> Ineq.substitute ineq_acc var (c,v,o,d) + | (Some (c,v), o, d) when v <> var -> let ineq', _ = Ineq.substitute ineq_acc var (c,v,o,d) in ineq' | _ -> ineq_acc in let ineq_x_split = IntMap.fold (transform_non_representant) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' ineq_x in @@ -1048,12 +1051,14 @@ struct | Some d' -> if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some d'; env = t.env}); let meet_cond (e,v,ineq) (cond, var) = + (*TODO value for i will be overwritten -> delay refinement?*) let dim = Environment.dim_of_var t.env var in if dim <> var_i then let ineq', refinements = Ineq.meet_relation var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq in EConjI.apply_refinements refinements (e,v,ineq') else - e,v,Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') + let ineq', refinements = Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') + in EConjI.apply_refinements refinements (e,v,ineq') in let d'' = List.fold meet_cond d' (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some d''; env = t.env}); @@ -1196,12 +1201,10 @@ struct | SUP when Z.gt constant Z.zero -> t | DISEQ when not @@ Z.equal constant Z.zero -> t | EQMOD _ -> t - | _ -> if M.tracing then M.tracel "meet_tcons" "meet_one_conj case 0"; - bot_env (* all other results are violating the guard *) + | _ -> bot_env (* all other results are violating the guard *) end | [(coeff, index, divi)] -> (* guard has a single reference variable only *) if Tcons1.get_typ tcons = EQ then begin - if M.tracing then M.tracel "meet_tcons" "meet_one_conj case 1"; meet_with_one_conj t index (Rhs.canonicalize (None, Z.neg @@ Z.(divi*constant),Z.(coeff*divisor))) end else t (* only EQ is supported in equality based domains *) diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 774fbce8bb..f0770349c4 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -328,7 +328,7 @@ module Relation = struct let show x (c,o) y = x ^ show_cond c ^ y ^ " + " ^ Z.to_string o - let invert (cond, o) = + let swap_sides (cond, o) = let o' = Z.neg o in match cond with | Lt -> Gt, o' @@ -346,6 +346,17 @@ module Relation = struct | Eq, Gt -> Some ( Gt, Z.add o1 o2 ) | Lt, Gt | Gt, Lt -> None + + + let value_with_const_right (cond,o) const = + let open Z in + match cond with + | Lt -> Value.ending (o + const - one) + | Gt -> Value.starting (o + const + one) + | Eq -> Value.of_bigint (o + const) + + let value_with_const_left t const = value_with_const_right (swap_sides t) const + end module Refinement = struct @@ -365,36 +376,38 @@ module Refinement = struct let of_value var v = (var, Either.Left v) let of_rhs var r = (var, Either.right r) + let rhs_only t = List.filter (BatEither.is_right) t + end module type TwoVarInequalities = sig type t (*returns the best lower and upper bound for the relation between variables with the given Rhs*) - val get_relations : (Rhs.t * Value.t) -> (Rhs.t * Value.t) -> t -> Relation.t list + val get_relations : ((Z.t * int * Z.t * Z.t) * Value.t) -> ((Z.t * int * Z.t * Z.t) * Value.t) -> t -> Relation.t list (*meet relation between two variables. also returns a list of value refinements *) val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * Refinement.t (*substitutes all occurences of a variable by a rhs*) - val substitute : t -> int -> Z.t * int * Z.t * Z.t -> t + val substitute : t -> int -> Z.t * int * Z.t * Z.t -> t * Refinement.t (*called after every operation to limit the inequalities to the most relevant*) val limit : EConj.t -> t -> t - val meet : (int -> Value.t) -> t -> t -> t - val narrow : (int -> Value.t) -> t -> t -> t + val meet : (int -> Value.t) -> t -> t -> t * Refinement.t + val narrow : (int -> Value.t) -> t -> t -> t * Refinement.t val leq : t -> (int -> Value.t) -> t -> bool val join : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t - (*a join can split groups of variables. This function copies the relevant inequalities to all new representants*) + (*second loop of transform: e.g. a join can split groups of variables. This function copies the relevant inequalities to all new representants*) val copy_to_new_representants : EConj.t -> EConj.t -> t -> t - (*restore inequalities after an assignment that makes the assigned to variable have a known relation to before the assignment *) - val transfer : int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t + (*restore inequalities after an assignment that makes the assigned-to variable have a known relation to before the assignment*) + val transfer : int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t * Refinement.t val show_formatted : (int -> string) -> t -> string val hash : t -> int @@ -417,8 +430,8 @@ module NoInequalties : TwoVarInequalities = struct let limit _ _ = () - let meet _ _ _ = () - let narrow _ _ _ = () + let meet _ _ _ = () , [] + let narrow _ _ _ = () , [] let leq _ _ _ = true let join _ _ _ _ = () @@ -433,11 +446,11 @@ module NoInequalties : TwoVarInequalities = struct let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () - let substitute _ _ _ = () + let substitute _ _ _ = (), [] let copy_to_new_representants _ _ _ = () - let transfer _ _ _ _ _ _ _ _ = () + let transfer _ _ _ _ _ _ _ _ = (), [] let invariant _ _ = [] @@ -446,8 +459,8 @@ end module type Coeffs = sig type t val implies : Value.t -> Value.t -> t option -> t -> bool - val meet : Value.t -> Value.t -> t -> t -> t - val narrow : Value.t -> Value.t -> t -> t -> t + val meet : (int * Value.t) -> (int * Value.t) -> t -> t -> Refinement.t -> t * Refinement.t + val narrow : (int * Value.t) -> (int * Value.t) -> t -> t -> Refinement.t -> t * Refinement.t val join : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option val widen : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option @@ -504,18 +517,18 @@ module CommonActions (Coeffs : Coeffs) = struct in IntMap.for_all (fun x ys -> IntMap.for_all (implies x) ys) t2 - let meet_one_coeff narrow get_value x y coeff t = + let meet_one_coeff narrow get_value x y coeff (t,ref_acc) = let coeff_t = get_coeff x y t in - let coeff_met = match coeff_t with - | None -> coeff - | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (get_value x) (get_value y) coeff coeff_t - in set_coeff x y coeff_met t + let coeff_met, ref_acc' = match coeff_t with + | None -> coeff, ref_acc + | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (x, get_value x) (y, get_value y) coeff coeff_t ref_acc + in set_coeff x y coeff_met t, ref_acc' let meet get_value t1 t2 = - IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff false get_value x) ys t) t2 t1 + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y coeff acc) ys acc) t2 (t1,[]) let narrow get_value t1 t2 = - IntMap.fold (fun x ys t -> IntMap.fold (meet_one_coeff true get_value x) ys t) t2 t1 + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t2 (t1,[]) let join' widen t1 get_val_t1 t2 get_val_t2 = let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 @@ -1091,61 +1104,61 @@ module ArbitraryCoeffsSet = struct if M.tracing then M.trace "get_offset" "%s implies %s" (show_formatted "x" "y" t) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing for this slope" res); res - let meet_single_inequality refine_data narrow x_val y_val k c t = - (*calculate value refine. If one of the coefficients is zero, we should not add it to the map*) + let meet_single_inequality narrow (x,x_val) (y,y_val) k c (t,ref_acc) = let round_up q = Z.cdiv (Q.num q) (Q.den q) in let round_down q = Z.fdiv (Q.num q) (Q.den q) in - let refinements, skip_adding = match refine_data with - | None -> [], (Q.equal Q.zero @@ Key.get_slope k) || not @@ Q.is_real @@ Key.get_slope k - | Some (x,y) -> - let x_refine = - let upper_bound s = (*x <= y / s + c / s*) - let max_y = match Value.maximal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with - | Some a, Some b -> TopIntOps.max a b - | _,_ -> failwith "trying to refine bot in inequalities" - in match max_y with - | Int max -> [Refinement.of_value x (Value.ending @@ Z.add max @@ round_down @@ Q.div c s)] - | _ -> [] - in let lower_bound s = (*x >= y / s + c / s*) - let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with + (*calculate value refinement. If one of the coefficients is zero, we should not add the inequality to the map*) + let refinements, skip_adding = + let x_refine = + let upper_bound s = (*x <= y / s + c / s*) + let max_y = match Value.maximal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.maximal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with + | Some a, Some b -> TopIntOps.max a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match max_y with + | Int max -> [Refinement.of_value x (Value.ending @@ Z.add max @@ round_down @@ Q.div c s)] + | _ -> [] + in let lower_bound s = (*x >= y / s + c / s*) + let min_y = match Value.minimal (Value.mul y_val (Value.of_bigint (round_down (Q.inv s)))) , Value.minimal @@ Value.mul y_val (Value.of_bigint (round_up (Q.inv s))) with + | Some a, Some b -> TopIntOps.min a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match min_y with + | Int min -> [Refinement.of_value x (Value.starting @@ Z.add min @@ round_up @@ Q.div c s)] + | _ -> [] + in + match k with + | LinearInequality.OriginInequality.LE s when Q.sign s > 0 -> upper_bound s + | GE s when Q.sign s < 0 -> upper_bound s + | LE s when Q.sign s < 0 -> lower_bound s + | GE s when Q.sign s > 0 -> lower_bound s + | _ -> [] (*Should never be used in this case*) + in let y_refine = + match k with + | LE s -> begin (*sx -c <= y*) + let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up s)) with | Some a, Some b -> TopIntOps.min a b | _,_ -> failwith "trying to refine bot in inequalities" - in match min_y with - | Int min -> [Refinement.of_value x (Value.starting @@ Z.add min @@ round_up @@ Q.div c s)] - | _ -> [] - in - match k with - | LE s when Q.sign s > 0 -> upper_bound s - | GE s when Q.sign s < 0 -> upper_bound s - | LE s when Q.sign s < 0 -> lower_bound s - | GE s when Q.sign s > 0 -> lower_bound s - | _ -> [] (*Should never be used in this case*) - in let y_refine = - match k with - | LE s -> begin (*sx -c <= y*) - let min_x = match Value.minimal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.minimal @@ Value.mul x_val (Value.of_bigint (round_up s)) with - | Some a, Some b -> TopIntOps.min a b - | _,_ -> failwith "trying to refine bot in inequalities" - in match min_x with - | Int min -> [Refinement.of_value y (Value.starting @@ Z.sub min @@ round_up c)] - | _ -> [] - end - | GE s -> (*s x - c >= y*) - let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up s)) with - | Some a, Some b -> TopIntOps.max a b - | _,_ -> failwith "trying to refine bot in inequalities" - in match max_x with - | Int max -> [Refinement.of_value y (Value.ending @@ Z.sub max @@ round_down c)] + in match min_x with + | Int min -> [Refinement.of_value y (Value.starting @@ Z.sub min @@ round_up c)] | _ -> [] - in match k with - | LE s when Q.equal Q.zero s -> (* -c >= y *) [Refinement.of_value y @@ Value.ending @@ round_up @@ Q.neg c] , true - | GE s when Q.equal Q.zero s -> (* -c <= y *) [Refinement.of_value y @@ Value.starting @@ round_down @@ Q.neg c] , true - | LE s when Q.equal Q.inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true - | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true - | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true - | GE s when Q.equal Q.inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true - | k -> (*an actual inequality *) x_refine @ y_refine, false - in if skip_adding then t, refinements + end + | GE s -> (*s x - c >= y*) + let max_x = match Value.maximal (Value.mul x_val (Value.of_bigint (round_down s))) , Value.maximal @@ Value.mul x_val (Value.of_bigint (round_up s)) with + | Some a, Some b -> TopIntOps.max a b + | _,_ -> failwith "trying to refine bot in inequalities" + in match max_x with + | Int max -> [Refinement.of_value y (Value.ending @@ Z.sub max @@ round_down c)] + | _ -> [] + in match k with + | LinearInequality.OriginInequality.LE s when Q.equal Q.zero s -> (* -c >= y *) [Refinement.of_value y @@ Value.ending @@ round_up @@ Q.neg c] , true + | GE s when Q.equal Q.zero s -> (* -c <= y *) [Refinement.of_value y @@ Value.starting @@ round_down @@ Q.neg c] , true + | LE s when Q.equal Q.inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true + | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true + | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true + | GE s when Q.equal Q.inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true + | k -> (*an actual inequality *) x_refine @ y_refine, false + in + let ref_acc = refinements @ ref_acc in + if skip_adding then t, ref_acc else (*Look for contradicting inequality*) let contradicts c' = match k with | LE _ -> Q.gt c' c @@ -1161,16 +1174,13 @@ module ArbitraryCoeffsSet = struct let sn, sd = Q.num s, Q.den s in let cn, cd = Q.num c, Q.den c in let open Z in - match refine_data with - | Some (x,y) -> - if M.tracing then begin - let show_var = (fun x -> "var_"^Int.to_string x) in - M.trace "refinements" "single_ineq new: %s with %s results in equality" - (LinearInequality.show (show_var x) (show_var y) (k,c)) - (show_formatted (show_var x) (show_var y) t) - end; - t, (Refinement.of_rhs x @@ Rhs.canonicalize (Some (sd * cd, y), sd*cn, sn * cd)) :: refinements - | _ -> t, [] + if M.tracing then begin + let show_var = (fun x -> "var_"^Int.to_string x) in + M.trace "refinements" "single_ineq new: %s with %s results in equality" + (LinearInequality.show (show_var x) (show_var y) (k,c)) + (show_formatted (show_var x) (show_var y) t) + end; + t, (Refinement.of_rhs x @@ Rhs.canonicalize (Some (sd * cd, y), sd*cn, sn * cd)) :: ref_acc end | _ -> (*add the inequality, while making sure that we do not save redundant inequalities*) @@ -1180,29 +1190,25 @@ module ArbitraryCoeffsSet = struct | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) in (*lookup the best interval bounds from the inequalities!*) - match refine_data with - | Some (x,y) -> - let refinements = match get_best_offset (LE Q.inf) t' with - | Some upper -> (Refinement.of_value x @@ Value.ending @@ round_down upper ):: refinements - | _ -> refinements - in - let refinements = match get_best_offset (GE Q.inf) t' with - | Some lower -> (Refinement.of_value x @@ Value.starting @@ round_up lower ):: refinements - | _ -> refinements - in - let refinements = match get_best_offset (GE Q.zero) t' with - | Some upper -> (Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg upper ):: refinements - | _ -> refinements - in - let refinements = match get_best_offset (LE Q.zero) t' with - | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: refinements - | _ -> refinements - in - t', refinements - | _ -> t', refinements - - (*when meeting, the values should already been refined before -> ignore the refinement data*) (*TODO is this actually true?*) - let meet' narrow x_val y_val t1 t2 = CoeffMap.fold (fun k c t -> fst @@ meet_single_inequality None narrow x_val y_val k c t) t1 t2 + let ref_acc = match get_best_offset (LE Q.inf) t' with + | Some upper -> (Refinement.of_value x @@ Value.ending @@ round_down upper ):: ref_acc + | _ -> ref_acc + in + let ref_acc = match get_best_offset (GE Q.inf) t' with + | Some lower -> (Refinement.of_value x @@ Value.starting @@ round_up lower ):: ref_acc + | _ -> ref_acc + in + let ref_acc = match get_best_offset (GE Q.zero) t' with + | Some upper -> (Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg upper ):: ref_acc + | _ -> ref_acc + in + let ref_acc = match get_best_offset (LE Q.zero) t' with + | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: ref_acc + | _ -> ref_acc + in + t', ref_acc + + let meet' narrow x_val y_val t1 t2 ref_acc = CoeffMap.fold (fun k c acc -> meet_single_inequality narrow x_val y_val k c acc) t1 (t2,ref_acc) let implies x_val y_val t1_opt t2 = let t1 = match t1_opt with @@ -1315,7 +1321,7 @@ module ArbitraryCoeffsSet = struct end -module LinearInequalities: TwoVarInequalities = struct +module LinearInequalities : TwoVarInequalities = struct module Coeffs = ArbitraryCoeffsSet include CommonActions(Coeffs) @@ -1323,91 +1329,99 @@ module LinearInequalities: TwoVarInequalities = struct if IntMap.is_empty ls then None else Some ls - let rec get_relations (((var_x,o_x,d_x), x_val) as x') (((var_y,o_y,d_y), y_val) as y') t = - match var_x, var_y with - | Some (c_x, x), Some (c_y, y) -> - if x > y then - (*We save information only in one of the directions -> check the other one*) - List.map Relation.invert @@ get_relations y' x' t - else begin - if M.tracing then M.trace "get_relations" "checking x': %s, y': %s" (Rhs.show @@ fst x') (Rhs.show @@ fst y'); - match get_coeff x y t with - | None -> begin if M.tracing then M.trace "get_relations" "no inequality for roots"; [] end (*No information*) - | Some coeff -> - let interval_ineqs = LinearInequality.from_values x_val y_val in - let coeff = List.fold (fun t (k,c) -> Coeffs.add_inequality k c t) coeff interval_ineqs in - let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) None in - let factor = (*we need to muliply c' with this factor because LinearInequalities scales them down*) - let a = Q.make c_x d_x in - let b = Q.make c_y d_y in - if Q.equal b Q.zero then a else b - in - let upper_bound = match Coeffs.get_best_offset k coeff with - | None -> [] - | Some c_ineq -> - let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in - [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) - in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) - | None -> upper_bound + let rec get_relations (((c_x, x,o_x,d_x), x_val) as x') (((c_y, y,o_y,d_y), y_val) as y') t = + if x > y then + (*We save information only in one of the directions -> check the other one*) + List.map Relation.swap_sides @@ get_relations y' x' t + else begin + if M.tracing then M.trace "get_relations" "checking x'=%s, y'=%s" (Rhs.show (Some (c_x, x), o_x, d_x)) (Rhs.show (Some (c_y, y), o_y, d_y)); + match get_coeff x y t with + | None -> begin if M.tracing then M.trace "get_relations" "no inequality for roots"; [] end (*No information*) + | Some coeff -> + let interval_ineqs = LinearInequality.from_values x_val y_val in + let coeff = List.fold (fun t (k,c) -> Coeffs.add_inequality k c t) coeff interval_ineqs in + let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) None in + let factor = (*we need to muliply c' with this factor because LinearInequalities scales them down*) + let a = Q.make c_x d_x in + let b = Q.make c_y d_y in + if Q.equal b Q.zero then a else b + in + let upper_bound = match Coeffs.get_best_offset k coeff with + | None -> [] | Some c_ineq -> - let c' = Q.mul factor ( Q.add c_ineq c_rhs) in - (Gt, Z.add Z.minus_one @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound - end - | _, _ -> failwith "Inequalities.is_less_than does not take constants directly" (*Should probably enforced by the type system :) *) + let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in + [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) + in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) + | None -> upper_bound + | Some c_ineq -> + let c' = Q.mul factor ( Q.add c_ineq c_rhs) in + (Gt, Z.add Z.minus_one @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound + end let get_relations x y t = let res = get_relations x y t in if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); res - let rec meet_relation x' y' cond get_rhs get_value t = - let get_rhs' lhs = - let rhs = get_rhs lhs in - match rhs with - | (Some (c,var), o ,d) -> (c,o,d), var - | (None, o ,d)-> (Z.one,Z.zero,Z.one), lhs (*TODO do not save relations to constants -> interval refinement*) - in let (rhs_x, x) = get_rhs' x' - in let (rhs_y, y) = get_rhs' y' - in if x > y then - (*We save information only in one of the directions*) - meet_relation y' x' (Relation.invert cond) get_rhs get_value t - else - let coeffs = match get_coeff x y t with - | None -> Coeffs.empty - | Some c -> c - in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y (Some (match fst cond with Relation.Lt -> true | _ -> false)) - in let meet_relation_roots k c t = - if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); - (*do not save inequalities refering to the same variable*) - if x = y then - let s = Coeffs.Key.get_slope k in - if Q.equal Q.one s then (* x <= x + c (or >=) *) - match k with - | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - else (* sx <= x + c (or =>) -> refine the value in this case*) - let s' = Q.sub s Q.one in - let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in - (*s'x <= c' *) - if Q.gt s' Q.zero then - let max = Q.div c' s' in - t, [x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))] - else - let min = Q.div c' s' in - t, [x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))] - else Coeffs.meet_single_inequality (Some (x,y)) false (get_value x) (get_value y) k c t - in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) - let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in - let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in - if Q.equal b Q.zero then a else b - (*TODO: transfer some transitivity, similar to the simple inequalities*) - in let (new_coeffs, refine_acc) = match cond with - | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q.div (Q.of_bigint o) factor) coeffs - | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q.div (Q.of_bigint o) factor) ) coeffs - | Eq, o -> coeffs, [] (*This should always be stored by the lin2vareq domain (at least the way we are generating this information)*) - in if Coeffs.CoeffMap.is_empty new_coeffs - then remove_coeff x y t , refine_acc - else set_coeff x y new_coeffs t, refine_acc + let rec meet_relation x' y' cond get_rhs get_value t = + match get_rhs x', get_rhs y' with + | (Some (c_x, x),o_x,d_x), (Some (c_y, y),o_y,d_y) -> begin + let rhs_x = (c_x,o_x,d_x) in + let rhs_y = (c_y,o_y,d_y) in + if x > y then + (*We save information only in one of the directions*) + meet_relation y' x' (Relation.swap_sides cond) get_rhs get_value t + else + let coeffs = match get_coeff x y t with + | None -> Coeffs.empty + | Some c -> c + in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y (Some (match fst cond with Relation.Lt -> true | _ -> false)) + in let meet_relation_roots k c (t:Coeffs.t) = + if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); + (*do not save inequalities refering to the same variable*) + if x = y then + let s = Coeffs.Key.get_slope k in + if Q.equal Q.one s then (* x <= x + c (or >=) *) + match k with + | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + else (* sx <= x + c (or =>) -> refine the value in this case*) + let s' = Q.sub s Q.one in + let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in + (*s'x <= c' *) + if Q.gt s' Q.zero then + let max = Q.div c' s' in + t, [x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))] + else + let min = Q.div c' s' in + t, [x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))] + (*TODO: transfer some transitivity, similar to the simple inequalities + idea: for every z combine every inequality relating z,x with this for a ineq relating z,y + same for z,y -> z,x + is this too arbitrary to be useful??? *) + else Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (t,[]) + in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) + let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in + let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in + if Q.equal b Q.zero then a else b + in let (new_coeffs, refine_acc) = match cond with + | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q.div (Q.of_bigint o) factor) coeffs + | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q.div (Q.of_bigint o) factor) ) coeffs + | Eq, o -> coeffs, [] (*This should always be stored by the lin2vareq domain (at least the way we are generating this information)*) + in if Coeffs.CoeffMap.is_empty new_coeffs + then remove_coeff x y t , refine_acc + else set_coeff x y new_coeffs t, refine_acc + end + (*Cases where one of the variables is a constant -> refine value*) + | (None, o_x, _), (Some (_,y),_,_) -> t, [Refinement.of_value y @@ Relation.value_with_const_left cond o_x] + | (Some (_,x),_,_), (None, o_y, _) -> t, [Refinement.of_value x @@ Relation.value_with_const_right cond o_y] + | (None, o_x, _), (None, o_y, _) -> + let v = Relation.value_with_const_right cond o_y in + if Value.contains v o_x then + t, [] + else + raise EConj.Contradiction + let meet_relation x y c r v t = if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); @@ -1416,22 +1430,33 @@ module LinearInequalities: TwoVarInequalities = struct res, refine_acc let substitute t i (coeff, j, offs, divi) = - (*check for contradictions if both sides refer to the same variable*) - let check_for_contradiction cs = - let check_single k c = - match k with - | LinearInequality.OriginInequality.LE s when Q.equal s Q.one -> if Q.lt c Q.zero then raise EConj.Contradiction - | GE s when Q.equal s Q.one -> if Q.gt c Q.zero then raise EConj.Contradiction - | _ -> () (*TODO value refinement?*) - in Coeffs.CoeffMap.iter check_single cs + (*if both sides refer to the same variable: check for contradictions or refine the value*) + let constraints_same_variable cs = + let check_single k c value = + let s = Coeffs.Key.get_slope k in + if Q.equal Q.one s then (* x <= x + c (or >=) *) + match k with + | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else value (*trivially true*) + | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else value (*trivially true*) + else (* sx <= x + c (or =>) -> refine the value in this case*) + let s' = Q.sub s Q.one in + let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in + (*s'x <= c' *) + if Q.gt s' Q.zero then + let max = Q.div c' s' in + Value.meet value @@ Value.ending @@ Z.cdiv (Q.num max) (Q.den max) + else + let min = Q.div c' s' in + Value.meet value @@ Value.starting @@ Z.fdiv (Q.num min) (Q.den min) + in Coeffs.CoeffMap.fold check_single cs Value.top in (*add to bindings, meeting with existing if necessary*) - let merge_single x y cs_new t = + let merge_single x y cs_new (t,ref_acc) = let cs_curr = BatOption.default Coeffs.empty @@ get_coeff x y t in - let cs_combined = Coeffs.meet Value.top Value.top cs_new cs_curr in - if Coeffs.CoeffMap.is_empty cs_combined then t else set_coeff x y cs_combined t + let cs_combined, ref_acc = Coeffs.meet (x,Value.top) (y,Value.top) cs_new cs_curr ref_acc in + if Coeffs.CoeffMap.is_empty cs_combined then t,ref_acc else set_coeff x y cs_combined t, ref_acc in - let merge_ys x ys t = IntMap.fold (merge_single x) ys t in + let merge_ys x ys acc = IntMap.fold (merge_single x) ys acc in let fold_x x ys acc = if x < i then match IntMap.find_opt i ys with @@ -1440,8 +1465,10 @@ module LinearInequalities: TwoVarInequalities = struct let ys' = IntMap.remove i ys in let acc' = merge_ys x ys' acc in (*everything else is added unchanged*) let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in - if x = j then (*We now have inequalities with the same variable on both sides -> check for contradictionsand do not add*) - (check_for_contradiction cs'; acc') + if x = j then (*We now have inequalities with the same variable on both sides *) + let t,ref_acc = acc' in + let v = constraints_same_variable cs' in + t, Refinement.of_value x v :: ref_acc else if x < j then merge_single x j cs' acc' else (*x > j -> swap sides*) @@ -1453,7 +1480,9 @@ module LinearInequalities: TwoVarInequalities = struct if j < y then merge_single j y cs' acc else if j = y then begin - check_for_contradiction cs'; acc + let t,ref_acc = acc in + let v = constraints_same_variable cs' in + t, Refinement.of_value x v :: ref_acc end else let cs'' = Coeffs.swap_sides cs' in merge_single y j cs'' acc @@ -1461,13 +1490,13 @@ module LinearInequalities: TwoVarInequalities = struct IntMap.fold fold_y ys acc else merge_ys x ys acc - in IntMap.fold fold_x t IntMap.empty + in IntMap.fold fold_x t (IntMap.empty, []) let substitute t i (c,j,o,d) = if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s" i (show t) (Rhs.show (Some (c,j), o, d)); - let res = substitute t i (c,j,o,d) in - if M.tracing then M.trace "substitute" "resulting in %s" (show res); - res + let t, ref_acc = substitute t i (c,j,o,d) in + if M.tracing then M.trace "substitute" "resulting in %s, refinements: %s" (show t) (Refinement.show ref_acc); + t, ref_acc let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = match get_rhs_old x, get_rhs x with @@ -1489,23 +1518,24 @@ module LinearInequalities: TwoVarInequalities = struct ignore_empty @@ IntMap.filter_map combine_2 v2s in let filtered = IntMap.filter_map combine_1 t_old in - if M.tracing then M.tracel "transfer" "filtered: %s" (show filtered); + if M.tracing then M.tracel "transfer" "filtered + combined %s" (show filtered); (*transform all inequalities to refer to new root of x*) (*invert old rhs, then substitute the new rhs for x*) let (m, o, d) = Rhs.subst rhs x @@ snd @@ EConj.inverse x (coeff_old,x_root_old, off_old, divi_old) in let c, v = BatOption.get m in - let transformed = substitute filtered x_root (c, v, o, d) in - if M.tracing then M.tracel "transfer" "transformed: %s" (show transformed); + let transformed, ref_acc = substitute filtered x_root (c, v, o, d) in + if M.tracing then M.tracel "transfer" "transformed: %s, refinements: %s" (show transformed) (Refinement.show ref_acc); (*meet with this set of equations*) - meet get_value t transformed - | _,_ -> t (*ignore constants*) + let t', ref_acc_2 = meet get_value t transformed in + t', ref_acc @ ref_acc_2 + | _,_ -> t, [] (*ignore constants*) let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s" (Relation.show ("var_" ^ Int.to_string x ^ "_old") cond ("var_" ^ Int.to_string x ^ "_new") ) (show t_old) (show t); - let res = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in - if M.tracing then M.tracel "transfer" "result: %s" (show res); - res + let res, ref_acc = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in + if M.tracing then M.tracel "transfer" "result: %s, refinements: %s" (show res) (Refinement.show ref_acc); + res, ref_acc let limit econj t = let coeffs = coeffs_from_econj econj in @@ -1573,16 +1603,10 @@ end (*TODOs:*) - (*++ ArbitraryCoeaffsList meet_single: take intervals into account better re-add them every time, remove them afterwards? - ArbitraryCoeaffsList.meet + affine_transform -> refinement - substitute refinement - in those cases: refinement of equalities must be limited to have acceptable runtimes! set_rhs constant refinement - meet_relations: refinement of intervals if var is constant - *) (*-- assign expr restore ineqs based on value *) @@ -1590,7 +1614,7 @@ end (*+ look at complexities. I expect for all: (n² log n) *) (*+ How to do a useful narrow?*) -(* meet_relations: do some transitivity: possible in complexity, but maybe expensive!*) +(*! meet_relations: do some transitivity: possible in complexity, but maybe expensive!*) (* widening thresholds: from offsets of rhs?*) (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) (*- copy_to_new: introduces too many inequlities?*) From 5d8207cbb0752d6e83ec3de85e25f2e523202d74 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 7 May 2025 19:05:21 +0200 Subject: [PATCH 61/86] leq: do value refinement until fixpoint to properly represent relations, fix bug when adding and ordering inequalities --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 25 ++- .../apron/pentagonSubDomains.apron.ml | 161 +++++++++++++----- 2 files changed, 140 insertions(+), 46 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index efdbab81cc..d7b6acdeb1 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -910,7 +910,7 @@ struct if is_bot_env t1 || is_top t2 then true else if is_bot_env t2 || is_top t1 then false else let m1, (econ2, vs2, ineq2) = Option.get t1.d, Option.get t2.d in - let (econ1, _, ineq1) as m1' = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in + let (econ1, vs1, ineq1) = if env_comp = 0 then m1 else VarManagement.dim_add (Environment.dimchange t1.env t2.env) m1 in (*make ineq1 refer to the new representants*) let transform_non_representant var (m,o,d) ineq_acc = match m with @@ -923,10 +923,25 @@ struct let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in (*further, econ2 might have some new representants -> transform further*) let ineq1' = Ineq.copy_to_new_representants econ1 econ2 ineq1' in - if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); - IntMap.for_all (implies econ1) (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) - && IntMap.for_all (implies_value m1') (vs2) - && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 (*TODO the transformations are likely the most expensive part. -> only do it when both above options did not already deterime the result *) + if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); + (*Normally, we do not apply closure to the intervals because it is too expensive (O(n^3)), but if we do not do it here, we get some actually implied elements being not leq, failing verifying*) + let rec refine_intervals_until_fixpoint t = + let refinements = Ineq.interval_refinements (EConjI.get_value t) (Tuple3.third t) in + if M.tracing then M.trace "leq" "refined with %s" (Refinement.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) refinements); + let t' = EConjI.apply_refinements ~refine_depth:1 refinements t in + if t = t' then t else refine_intervals_until_fixpoint t' + in + try + let (econ1', _, ineq1') as m1' = timing_wrap "leq_refine" refine_intervals_until_fixpoint (econ1, vs1, ineq1') in + if M.tracing then M.trace "leq" "refined into %s" (EConjI.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) m1'); + (*TODO the transformations are likely the most expensive part. -> only do it when econj did not rule it out*) + IntMap.for_all (implies econ1') (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) + && IntMap.for_all (implies_value m1') (vs2) + && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 + with EConj.Contradiction -> + if M.tracing then M.trace "leq" "refinement showed contradiction"; + true (*t1 was secretely bot -> leq all*) + let leq a b = timing_wrap "leq" (leq a) b diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index f0770349c4..856412ed1a 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -386,7 +386,7 @@ module type TwoVarInequalities = sig (*returns the best lower and upper bound for the relation between variables with the given Rhs*) val get_relations : ((Z.t * int * Z.t * Z.t) * Value.t) -> ((Z.t * int * Z.t * Z.t) * Value.t) -> t -> Relation.t list - (*meet relation between two variables. also returns a list of value refinements *) + (*meet a single relation between two variables.*) val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * Refinement.t (*substitutes all occurences of a variable by a rhs*) @@ -418,6 +418,8 @@ module type TwoVarInequalities = sig val modify_variables_in_domain : t -> int array -> (int -> int -> int) -> t val forget_variable : t -> int -> t + val interval_refinements : (int -> Value.t) -> t -> Refinement.t + val invariant : t -> Environment.t -> Lincons1.t list end @@ -452,6 +454,8 @@ module NoInequalties : TwoVarInequalities = struct let transfer _ _ _ _ _ _ _ _ = (), [] + let interval_refinements _ _ = [] + let invariant _ _ = [] end @@ -470,6 +474,8 @@ module type Coeffs = sig val compare : t -> t -> int val show_formatted : string -> string -> t -> string + val interval_refinements :(int * Value.t) -> (int * Value.t) -> t -> Refinement.t -> Refinement.t + val invariant : Environment.t -> int -> int -> t -> Lincons1.t list -> Lincons1.t list end @@ -543,6 +549,15 @@ module CommonActions (Coeffs : Coeffs) = struct let join = join' false let widen = join' true + let interval_refinements get_value t = IntMap.fold (fun x ys acc -> + IntMap.fold (fun y cs acc -> + Coeffs.interval_refinements + (x, get_value x) + (y, get_value y) + cs acc + ) ys acc + ) t [] + let invariant t env = IntMap.fold (fun x ys acc -> IntMap.fold (Coeffs.invariant env x) ys acc) t [] end @@ -753,6 +768,8 @@ end let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) +let round_up q = Z.cdiv (Q.num q) (Q.den q) +let round_down q = Z.fdiv (Q.num q) (Q.den q) module LinearInequality = struct (*Normalised representation of an inequality through the origin @@ -766,13 +783,30 @@ module LinearInequality = struct | LE s when Q.equal s Q.minus_inf -> GE Q.inf | t -> t + (*We want the inequalities to be ordered by angle (with arbitrary start point and direction), which is tan(slope) (+ pi for other direction) *) - (*because tan is monotone, we can simply sort by slope: LE < GE, LE ordered by a, GE ordered by -a*) - let compare t1 t2 = match t1, t2 with - | LE _, GE _ -> -1 - | GE _, LE _ -> 1 - | LE a1, LE a2 -> Q.compare a1 a2 - | GE a1, GE a2 -> -(Q.compare a1 a2) + let compare t1 t2 = + let classify t = + let a,b = match t with + | LE s when Q.equal s Q.inf -> (Q.one,Q.zero) + | GE s when Q.equal s Q.inf -> (Q.minus_one, Q.zero) + | LE s -> (s,Q.minus_one) + | GE s -> (Q.neg s, Q.one) + in let open Q in + let c = if a < zero then + Int.(-) 7 (sign b) + else if a = zero then + (if b <= zero then 1 else 5) + else + Int.(+) 3 (sign b) + in a, b, c + in + let a1, b1, class1 = classify t1 in + let a2, b2, class2 = classify t2 in + if class1 <> class2 then + class1 - class2 + else + let open Q in compare (a1 * b2) (a2*b1) let equal t1 t2 = 0 = compare t1 t2 @@ -1057,13 +1091,13 @@ module ArbitraryCoeffsSet = struct (*get the next key in anti-clockwise order*) let get_previous k t = - match CoeffMap.find_first_opt (fun key -> Key.compare key k >= 0) t with + match CoeffMap.find_first_opt (fun key -> Key.compare key k > 0) t with | None -> CoeffMap.min_binding_opt t (*there is no larger key -> take the first one*) | s -> s (*get the next key in clockwise order*) let get_next k t = - match CoeffMap.find_last_opt (fun key -> Key.compare key k <= 0) t with + match CoeffMap.find_last_opt (fun key -> Key.compare key k < 0) t with | None -> CoeffMap.max_binding_opt t (*there is no smaller key -> take the last one*) | s -> s @@ -1072,25 +1106,66 @@ module ArbitraryCoeffsSet = struct match get_previous k t, get_next k t with | None, None -> CoeffMap.add k c t (* the map is empty *) | Some prev, Some next -> - if LinearInequality.entails2 prev next (k,c) then t (*new inequality is already implied*) + if LinearInequality.entails2 prev next (k,c) then ( + if M.tracing then M.trace "add_ineq" "new %s entailed by prev: %s, next %s" (LinearInequality.show "x" "y" (k,c)) (LinearInequality.show "x" "y" prev) (LinearInequality.show "x" "y" next); + t) (*new inequality is already implied*) else (*check in both direction if the next inequality is now implied, and remove those that are. recursive because multiple may now be implied*) let rec remove_prev prev t = match get_previous (fst prev) t with - | None -> t + | None -> + if M.tracing then M.trace "add_ineq" "remove_prev?: none left to remove"; + t | Some prev_prev -> - if not (LinearInequality.equal prev prev_prev) && LinearInequality.entails2 prev_prev (k,c) prev then + if LinearInequality.equal prev prev_prev then begin + if M.tracing then M.trace "add_ineq" "remove_prev?: only one left in %s -> no removal" (show_formatted "x" "y" t); + t + end else if LinearInequality.entails2 prev_prev (k,c) prev then begin + if M.tracing then M.trace "add_ineq" "remove_prev?: new: %s and prev_prev: %s imply prev %s -> removing and continuing" (LinearInequality.show "x" "y" (k,c)) (LinearInequality.show "x" "y" prev_prev) (LinearInequality.show "x" "y" prev); remove_prev prev_prev @@ CoeffMap.remove (fst prev) t - else t + end else begin + if M.tracing then M.trace "add_ineq" "remove_prev?: new: %s and prev_prev: %s do not imply prev %s -> stop" (LinearInequality.show "x" "y" (k,c)) (LinearInequality.show "x" "y" prev_prev) (LinearInequality.show "x" "y" prev); + t + end in let rec remove_next next t = match get_next (fst next) t with - | None -> t + | None -> + if M.tracing then M.trace "add_ineq" "remove_next?: none left to remove"; + t | Some next_next -> - if not (LinearInequality.equal next next_next) && LinearInequality.entails2 next_next (k,c) next then + if LinearInequality.equal next next_next then begin + if M.tracing then M.trace "add_ineq" "remove_next?: only one left in %s -> no removal" (show_formatted "x" "y" t); + t + end else if LinearInequality.entails2 next_next (k,c) next then begin + if M.tracing then M.trace "add_ineq" "remove_next?: new: %s and next_next: %s imply next %s -> removing and continuing" (LinearInequality.show "x" "y" (k,c)) (LinearInequality.show "x" "y" next_next) (LinearInequality.show "x" "y" next); remove_next next_next @@ CoeffMap.remove (fst next) t - else t + end else begin + if M.tracing then M.trace "add_ineq" "remove_next?: new: %s and next_next: %s do not imply next %s -> stop" (LinearInequality.show "x" "y" (k,c)) (LinearInequality.show "x" "y" next_next) (LinearInequality.show "x" "y" next); + t + end in CoeffMap.add k c @@ remove_prev prev @@ remove_next next t | _,_ -> failwith "impossible state" + let add_inequality k c t = + let res = add_inequality k c t in + if M.tracing then M.trace "add_ineq" "adding %s to %s -> %s" (LinearInequality.show "x" "y" (k,c)) (show_formatted "x" "y" t) (show_formatted "x" "y" res); + res + + + let test () = () (* + let t = empty in + let t = add_inequality (LE Q.inf) (Q.of_int 5) t in + let t = add_inequality (GE Q.minus_one) (Q.of_int (-7)) t in + let t = add_inequality (LE Q.zero) (Q.of_int 5) t in + let t = add_inequality (GE Q.one) (Q.of_int (-7)) t in + let t = add_inequality (GE Q.inf) (Q.of_int (-5)) t in + let t = add_inequality (LE Q.minus_one) (Q.of_int 7) t in + let t = add_inequality (GE Q.zero) (Q.of_int (-5)) t in + let t = add_inequality (LE Q.one) (Q.of_int 7) t in + if M.tracing then M.trace "test" "%s" (show_formatted "x" "y" t); + let t = add_inequality (GE (Q.of_int (2))) (Q.of_int 9) t in + if M.tracing then M.trace "test" "with more: %s" (show_formatted "x" "y" t) +*) + (*get the thightest offset for an inequality with a given slope that is implied by the current set of inequalities*) let get_best_offset k t = match CoeffMap.find_opt k t with @@ -1104,9 +1179,28 @@ module ArbitraryCoeffsSet = struct if M.tracing then M.trace "get_offset" "%s implies %s" (show_formatted "x" "y" t) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing for this slope" res); res + (*lookup the best interval bounds from the inequalities!*) + let interval_refinements (x,x_val) (y,y_val) t ref_acc = + test (); + let ineqs = LinearInequality.from_values x_val y_val in + let t = List.fold (fun t (k,c) -> add_inequality k c t) t ineqs in + let ref_acc = match get_best_offset (LE Q.inf) t with + | Some upper -> (Refinement.of_value x @@ Value.ending @@ round_down upper ):: ref_acc + | _ -> ref_acc + in + let ref_acc = match get_best_offset (GE Q.inf) t with + | Some lower -> (Refinement.of_value x @@ Value.starting @@ round_up lower ):: ref_acc + | _ -> ref_acc + in + let ref_acc = match get_best_offset (GE Q.zero) t with + | Some upper -> (Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg upper ):: ref_acc + | _ -> ref_acc + in + match get_best_offset (LE Q.zero) t with + | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: ref_acc + | _ -> ref_acc + let meet_single_inequality narrow (x,x_val) (y,y_val) k c (t,ref_acc) = - let round_up q = Z.cdiv (Q.num q) (Q.den q) in - let round_down q = Z.fdiv (Q.num q) (Q.den q) in (*calculate value refinement. If one of the coefficients is zero, we should not add the inequality to the map*) let refinements, skip_adding = let x_refine = @@ -1149,12 +1243,12 @@ module ArbitraryCoeffsSet = struct | Int max -> [Refinement.of_value y (Value.ending @@ Z.sub max @@ round_down c)] | _ -> [] in match k with - | LinearInequality.OriginInequality.LE s when Q.equal Q.zero s -> (* -c >= y *) [Refinement.of_value y @@ Value.ending @@ round_up @@ Q.neg c] , true - | GE s when Q.equal Q.zero s -> (* -c <= y *) [Refinement.of_value y @@ Value.starting @@ round_down @@ Q.neg c] , true - | LE s when Q.equal Q.inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true - | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_down c ], true - | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true - | GE s when Q.equal Q.inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_up c], true + | LinearInequality.OriginInequality.LE s when Q.equal Q.zero s -> (* -c >= y *) [Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg c] , true + | GE s when Q.equal Q.zero s -> (* -c <= y *) [Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg c] , true + | LE s when Q.equal Q.inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_up c ], true + | GE s when Q.equal Q.minus_inf s -> (*x >= c*) [Refinement.of_value x @@ Value.starting @@ round_up c ], true + | LE s when Q.equal Q.minus_inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_down c], true + | GE s when Q.equal Q.inf s -> (*x <= c*) [Refinement.of_value x @@ Value.ending @@ round_down c], true | k -> (*an actual inequality *) x_refine @ y_refine, false in let ref_acc = refinements @ ref_acc in @@ -1189,23 +1283,7 @@ module ArbitraryCoeffsSet = struct | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) (*TODO narrow?*) | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) in - (*lookup the best interval bounds from the inequalities!*) - let ref_acc = match get_best_offset (LE Q.inf) t' with - | Some upper -> (Refinement.of_value x @@ Value.ending @@ round_down upper ):: ref_acc - | _ -> ref_acc - in - let ref_acc = match get_best_offset (GE Q.inf) t' with - | Some lower -> (Refinement.of_value x @@ Value.starting @@ round_up lower ):: ref_acc - | _ -> ref_acc - in - let ref_acc = match get_best_offset (GE Q.zero) t' with - | Some upper -> (Refinement.of_value y @@ Value.ending @@ round_down @@ Q.neg upper ):: ref_acc - | _ -> ref_acc - in - let ref_acc = match get_best_offset (LE Q.zero) t' with - | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: ref_acc - | _ -> ref_acc - in + let ref_acc = interval_refinements (x,x_val) (y,y_val) t' ref_acc in t', ref_acc let meet' narrow x_val y_val t1 t2 ref_acc = CoeffMap.fold (fun k c acc -> meet_single_inequality narrow x_val y_val k c acc) t1 (t2,ref_acc) @@ -1607,6 +1685,7 @@ end ArbitraryCoeaffsList meet_single: take intervals into account better re-add them every time, remove them afterwards? set_rhs constant refinement + set_value constant refinement *) (*-- assign expr restore ineqs based on value *) From b825fc0a8bb6bbbe88367cd20c9d47768f891e8a Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 12 May 2025 15:35:14 +0200 Subject: [PATCH 62/86] in meet_relation, add some transitive inequalities. small fixes and cleanups --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 165 ++++++------ .../apron/pentagonSubDomains.apron.ml | 242 +++++++++++------- 2 files changed, 234 insertions(+), 173 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index d7b6acdeb1..d847daa932 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -104,7 +104,10 @@ struct in IntMap.fold meet_with_rhs (snd econ) i - let set_value ((econ, is, ineq) as t:t) lhs i = + (*TODO make this configureable with options*) + let refine_depth = 5 + + let rec set_value ((econ, is, ineq) as t:t) lhs i = if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show t); if Value.is_bot i then raise EConj.Contradiction; let set_value_for_root lhs i = @@ -114,13 +117,8 @@ struct if i = Value.top then (econ, IntMap.remove lhs is, ineq) (*stay sparse*) else if Value.is_bot i then raise EConj.Contradiction else match Value.to_int i with - | Some (Int x) -> (*If we have a constant, update all equations refering to this root*) - let update_references = function - | (Some (coeff, v), o, d) when v = lhs -> (None, Z.div (Z.add o @@ Z.mul x coeff) d, Z.one) - | t -> t - in - ((fst econ, IntMap.add lhs (None, x, Z.one) @@ IntMap.map update_references (snd econ)), IntMap.remove lhs is, ineq) - | _ -> (econ, IntMap.add lhs i is, ineq) (*Not a constant*) + | Some (Int x) -> meet_with_one_conj t lhs (None, x, Z.one) (*constant value*) + | _ -> (econ, IntMap.add lhs i is, ineq) in let (v,o,d) = get_rhs t lhs in if (v,o,d) = Rhs.var_zero lhs then @@ -138,16 +136,15 @@ struct if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Value.show i) (Value.show i1) (Value.show i2) (Value.show i3); set_value_for_root v i_transformed - let set_value t lhs i = - let res = set_value t lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_value before: %s eq: var_%d=%s -> %s " (show t) lhs (Value.show i) (show res); - res - - let set_rhs (econ, is, ineq) lhs rhs = + and set_rhs (econ, is, ineq) lhs rhs = let econ' = EConj.set_rhs econ lhs rhs in match rhs with - (*TODO remove from ineq, convert to interval information!*) - | (None, _, _) -> econ', IntMap.remove lhs is, ineq (*when setting as a constant, we do not need a separate value *) + | (None, o, d) -> + if not @@ Z.equal d Z.one then + raise EConj.Contradiction; + let ineq', refinements = Ineq.set_constant lhs o ineq in + let t' = econ', IntMap.remove lhs is, ineq' in (*when setting as a constant, we do not need a separate value *) + apply_refinements refinements t' (*TODO limit depth ?*) | _ -> let new_constraint = get_value (econ', is, ineq) lhs in let old_constraint = get_value (econ, is, ineq) lhs in @@ -155,71 +152,8 @@ struct if Value.is_bot new_value then raise EConj.Contradiction else set_value (econ', is, ineq) lhs new_value - let set_rhs t lhs rhs = - let res = set_rhs t lhs rhs in - if M.tracing then M.tracel "modify_pentagon" "set_rhs before: %s eq: var_%d=%s -> %s " (show t) lhs (Rhs.show rhs) (show res); - res - let forget_variable ((econj, _, _) as d) var = - let rhs_var = get_rhs d var in - (*Forgetting EConj, but also return relation of new representative to the old if this changes*) - let (econj', vs', ineq'), newRoot = - (let ref_var_opt = Tuple3.first rhs_var in - match ref_var_opt with - | Some (_,ref_var) when ref_var = var -> - if M.tracing then M.trace "forget" "headvar var_%d" var; - (* var is the reference variable of its connected component *) - (let cluster = List.sort (Int.compare) @@ IntMap.fold - (fun i (refe,_,_) l -> BatOption.map_default (fun (coeff,refe) -> if (refe=ref_var) then i::l else l) l refe) (snd econj) [] in - if M.tracing then M.trace "forget" "cluster varindices: [%s]" (String.concat ", " (List.map (string_of_int) cluster)); - (* obtain cluster with common reference variable ref_var*) - match cluster with (* new ref_var is taken from head of the cluster *) - | head :: clusterrest -> - (* head: divi*x = coeff*y + offs *) - (* divi*x = coeff*y + offs =inverse=> y =( divi*x - offs)/coeff *) - let (newref,offs,divi) = (get_rhs d head) in - let (coeff,y) = BatOption.get newref in - let (y,yrhs) = EConj.inverse head (coeff,y,offs,divi) in (* reassemble yrhs out of components *) - let shifted_cluster = (List.fold (fun map i -> - let irhs = (get_rhs d i) in (* old entry is i = irhs *) - Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) - set_rhs map i - ) d clusterrest) in - set_rhs shifted_cluster head (Rhs.var_zero head), Some yrhs (* finally make sure that head is now trivial *) - | [] -> d, None) (* empty cluster means no work for us *) - | _ -> d, None) (* variable is either a constant or expressed by another refvar *) in - (*Forget old information*) - let econj'' = (fst econj', IntMap.remove var (snd econj')) in - let vs'' = IntMap.remove var vs' in - match newRoot with - | None -> (econj'', vs'', Ineq.forget_variable ineq' var) - | Some (Some (coeff,y),offs,divi) -> - (*modify inequalities. We ignore refinements as they should not matter in this case*) - let ineq'', _ = Ineq.substitute ineq' var (coeff,y,offs,divi) - (*restoring value information*) - in set_value (econj'', vs'', ineq'') y @@ get_value d y - | _ -> failwith "Should not happen" (*transformation can not be a constant*) - - let forget_variable d var = - if M.tracing then M.tracel "forget" "forget var_%d in { %s } " var (show d); - let res = forget_variable d var in - if M.tracing then M.trace "forget" "-> { %s }" (show res); - res - - - let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = - if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then - (econj, v, ineq) - else ( - let cpy = Array.copy ch.dim in - Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) - let (econj', v', ineq') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, v, ineq) cpy in (* clear m' from relations concerning ch.dim *) - let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in - let v'' = modify_variables_in_domain_values v' cpy (-) in - let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in - (econj'', v'', ineq'')) - - let meet_with_one_value var value t narrow = + and meet_with_one_value var value t narrow = let meet_function = if narrow then Value.narrow else Value.meet in let new_value = meet_function value (get_value t var) in if Value.is_bot new_value then raise EConj.Contradiction else @@ -227,10 +161,7 @@ struct in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); res - (*TODO make this configureable with options*) - let refine_depth = 5 - - let rec meet_with_one_conj ?(refine_depth = refine_depth) ((ts, is, ineq) as t:t) i (var, offs, divi) = + and meet_with_one_conj ?(refine_depth = refine_depth) ((ts, is, ineq) as t:t) i (var, offs, divi) = let (var,offs,divi) = Rhs.canonicalize (var,offs,divi) in (* make sure that the one new conj is properly canonicalized *) let res : t = let subst_var (((dim,econj), is, ineq) as t) x (vary, o, d) = @@ -259,7 +190,10 @@ struct let t' = econj', is', ineq' in let t'' = set_value t' x value in apply_refinements ~refine_depth refinements t'' - | None -> econj', IntMap.remove x is, Ineq.forget_variable ineq x (*we replaced x (and all connected vars) by a constant -> do not save a value and inequality anymore*) + | None -> + let ineq', refinements = Ineq.set_constant x (Z.div o d) ineq in + let t' = econj', IntMap.remove x is, ineq' in (*we replaced x (and all connected vars) by a constant -> do not save a value and inequality anymore*) + apply_refinements ~refine_depth refinements t' in (match var, (EConj.get_rhs ts i) with (*| new conj , old conj *) @@ -325,6 +259,66 @@ struct t end + let forget_variable ((econj, _, _) as d) var = + let rhs_var = get_rhs d var in + (*Forgetting EConj, but also return relation of new representative to the old if this changes*) + let (econj', vs', ineq'), newRoot = + (let ref_var_opt = Tuple3.first rhs_var in + match ref_var_opt with + | Some (_,ref_var) when ref_var = var -> + if M.tracing then M.trace "forget" "headvar var_%d" var; + (* var is the reference variable of its connected component *) + (let cluster = List.sort (Int.compare) @@ IntMap.fold + (fun i (refe,_,_) l -> BatOption.map_default (fun (coeff,refe) -> if (refe=ref_var) then i::l else l) l refe) (snd econj) [] in + if M.tracing then M.trace "forget" "cluster varindices: [%s]" (String.concat ", " (List.map (string_of_int) cluster)); + (* obtain cluster with common reference variable ref_var*) + match cluster with (* new ref_var is taken from head of the cluster *) + | head :: clusterrest -> + (* head: divi*x = coeff*y + offs *) + (* divi*x = coeff*y + offs =inverse=> y =( divi*x - offs)/coeff *) + let (newref,offs,divi) = (get_rhs d head) in + let (coeff,y) = BatOption.get newref in + let (y,yrhs) = EConj.inverse head (coeff,y,offs,divi) in (* reassemble yrhs out of components *) + let shifted_cluster = (List.fold (fun map i -> + let irhs = (get_rhs d i) in (* old entry is i = irhs *) + Rhs.subst yrhs y irhs |> (* new entry for i is irhs [yrhs/y] *) + set_rhs map i + ) d clusterrest) in + set_rhs shifted_cluster head (Rhs.var_zero head), Some yrhs (* finally make sure that head is now trivial *) + | [] -> d, None) (* empty cluster means no work for us *) + | _ -> d, None) (* variable is either a constant or expressed by another refvar *) in + (*Forget old information*) + let econj'' = (fst econj', IntMap.remove var (snd econj')) in + let vs'' = IntMap.remove var vs' in + match newRoot with + | None -> (econj'', vs'', Ineq.forget_variable ineq' var) + | Some (Some (coeff,y),offs,divi) -> + (*modify inequalities. We ignore refinements as they should not matter in this case*) + let ineq'', _ = Ineq.substitute ineq' var (coeff,y,offs,divi) + (*restoring value information*) + in set_value (econj'', vs'', ineq'') y @@ get_value d y + | _ -> failwith "Should not happen" (*transformation can not be a constant*) + + let forget_variable d var = + if M.tracing then M.tracel "forget" "forget var_%d in { %s } " var (show d); + let res = forget_variable d var in + if M.tracing then M.trace "forget" "-> { %s }" (show res); + res + + + let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) ~del = + if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then + (econj, v, ineq) + else ( + let cpy = Array.copy ch.dim in + Array.modifyi (+) cpy; (* this is a hack to restore the original https://antoinemine.github.io/Apron/doc/api/ocaml/Dim.html remove_dimensions semantics for dim_remove *) + let (econj', v', ineq') = Array.fold_lefti (fun y i x -> forget_variable y (x)) (econj, v, ineq) cpy in (* clear m' from relations concerning ch.dim *) + let econj'' = EConj.modify_variables_in_domain econj' cpy (-) in + let v'' = modify_variables_in_domain_values v' cpy (-) in + let ineq'' = Ineq.modify_variables_in_domain ineq' cpy (-) in + (econj'', v'', ineq'')) + + let affine_transform (econ, vs, ineq) i rhs = (*This is a place we want to use the original set_rhs (therefore use EConj directly), as the implied congruence might contradict each other during the transformation*) (*e.g. with 2x = y and 2z = y, and the assignment y = y+1 *) @@ -463,7 +457,6 @@ struct let relations = EConjI.get_relations d dim_a dim_b in let meet_relation v = function | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.sub o Z.one - | Relation.Eq, o -> Value.of_bigint o | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.add o Z.one in List.fold meet_relation v relations end diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 856412ed1a..6aa42abd3d 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -318,12 +318,11 @@ end module Value = IntervalAndCongruence module Relation = struct - type cond = Lt | Eq | Gt + type cond = Lt | Gt type t = cond * Z.t let show_cond c = match c with | Lt -> "<" - | Eq -> "=" | Gt -> ">" let show x (c,o) y = x ^ show_cond c ^ y ^ " + " ^ Z.to_string o @@ -333,17 +332,11 @@ module Relation = struct match cond with | Lt -> Gt, o' | Gt -> Lt, o' - | Eq -> Eq, o' (*Tries to combine two relations, with the variable on the rhs of the first condition being equal to the one at the lhs of the second*) let combine (c1, o1) (c2, o2) = match c1, c2 with | Lt, Lt -> Some ( Lt, Z.add o1 @@ Z.add o2 Z.one ) - | Lt, Eq - | Eq, Lt -> Some ( Lt, Z.add o1 o2 ) - | Eq, Eq -> Some ( Eq, Z.add o1 o2 ) | Gt, Gt -> Some ( Gt, Z.add o1 @@ Z.add o2 Z.one ) - | Gt, Eq - | Eq, Gt -> Some ( Gt, Z.add o1 o2 ) | Lt, Gt | Gt, Lt -> None @@ -353,7 +346,6 @@ module Relation = struct match cond with | Lt -> Value.ending (o + const - one) | Gt -> Value.starting (o + const + one) - | Eq -> Value.of_bigint (o + const) let value_with_const_left t const = value_with_const_right (swap_sides t) const @@ -418,7 +410,8 @@ module type TwoVarInequalities = sig val modify_variables_in_domain : t -> int array -> (int -> int -> int) -> t val forget_variable : t -> int -> t - val interval_refinements : (int -> Value.t) -> t -> Refinement.t + val interval_refinements : (int -> Value.t) -> t -> Refinement.t + val set_constant : int -> Z.t -> t -> t * Refinement.t val invariant : t -> Environment.t -> Lincons1.t list @@ -456,6 +449,8 @@ module NoInequalties : TwoVarInequalities = struct let interval_refinements _ _ = [] + let set_constant _ _ _ = (), [] + let invariant _ _ = [] end @@ -474,7 +469,10 @@ module type Coeffs = sig val compare : t -> t -> int val show_formatted : string -> string -> t -> string - val interval_refinements :(int * Value.t) -> (int * Value.t) -> t -> Refinement.t -> Refinement.t + val interval_refinements : (int * Value.t) -> (int * Value.t) -> t -> Refinement.t -> Refinement.t + + val set_constant_lhs : int -> Z.t -> t -> Refinement.t -> Refinement.t + val set_constant_rhs : int -> Z.t -> t -> Refinement.t -> Refinement.t val invariant : Environment.t -> int -> int -> t -> Lincons1.t list -> Lincons1.t list end @@ -558,6 +556,18 @@ module CommonActions (Coeffs : Coeffs) = struct ) ys acc ) t [] + let set_constant var const t = IntMap.fold (fun x ys (t_acc, ref_acc) -> + if x = var then + t_acc, IntMap.fold (fun y cs ref_acc -> Coeffs.set_constant_lhs y const cs ref_acc) ys ref_acc + else + match IntMap.find_opt var ys with + | None -> IntMap.add x ys t_acc, ref_acc + | Some cs -> + let ys' = IntMap.remove var ys in + let ref_acc = Coeffs.set_constant_rhs x const cs ref_acc in + if IntMap.is_empty ys' then t_acc, ref_acc else (IntMap.add x ys' t_acc, ref_acc) + ) t (IntMap.empty,[]) + let invariant t env = IntMap.fold (fun x ys acc -> IntMap.fold (Coeffs.invariant env x) ys acc) t [] end @@ -988,6 +998,30 @@ module LinearInequality = struct | LE s_rel, LE s -> Some (LE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) | GE s_rel, GE s -> Some (GE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + let set_constant_lhs rhs_var const (k,o) ref_acc = + let open Q in + let s = OriginInequality.get_slope k in + let bound = s * of_bigint const - o in + let new_ref = match k with + | LE _ -> Refinement.of_value rhs_var @@ Value.starting @@ round_up bound + | GE _ -> Refinement.of_value rhs_var @@ Value.ending @@ round_down bound + in new_ref :: ref_acc + + let set_constant_rhs lhs_var const (k,o) ref_acc = + let open Q in + let s = OriginInequality.get_slope k in + let bound = (of_bigint const + o) / s in + let is_leq = match k with + | LE _ -> s > zero + | GE _ -> s < zero + in let new_ref = + if is_leq then + Refinement.of_value lhs_var @@ Value.ending @@ round_down bound + else + Refinement.of_value lhs_var @@ Value.starting @@ round_up bound + + in new_ref :: ref_acc + let invariant env x y k o acc = (*for LE, we need to swap signs of all coefficients*) let s, o = match k with @@ -1150,22 +1184,6 @@ module ArbitraryCoeffsSet = struct if M.tracing then M.trace "add_ineq" "adding %s to %s -> %s" (LinearInequality.show "x" "y" (k,c)) (show_formatted "x" "y" t) (show_formatted "x" "y" res); res - - let test () = () (* - let t = empty in - let t = add_inequality (LE Q.inf) (Q.of_int 5) t in - let t = add_inequality (GE Q.minus_one) (Q.of_int (-7)) t in - let t = add_inequality (LE Q.zero) (Q.of_int 5) t in - let t = add_inequality (GE Q.one) (Q.of_int (-7)) t in - let t = add_inequality (GE Q.inf) (Q.of_int (-5)) t in - let t = add_inequality (LE Q.minus_one) (Q.of_int 7) t in - let t = add_inequality (GE Q.zero) (Q.of_int (-5)) t in - let t = add_inequality (LE Q.one) (Q.of_int 7) t in - if M.tracing then M.trace "test" "%s" (show_formatted "x" "y" t); - let t = add_inequality (GE (Q.of_int (2))) (Q.of_int 9) t in - if M.tracing then M.trace "test" "with more: %s" (show_formatted "x" "y" t) -*) - (*get the thightest offset for an inequality with a given slope that is implied by the current set of inequalities*) let get_best_offset k t = match CoeffMap.find_opt k t with @@ -1181,7 +1199,6 @@ module ArbitraryCoeffsSet = struct (*lookup the best interval bounds from the inequalities!*) let interval_refinements (x,x_val) (y,y_val) t ref_acc = - test (); let ineqs = LinearInequality.from_values x_val y_val in let t = List.fold (fun t (k,c) -> add_inequality k c t) t ineqs in let ref_acc = match get_best_offset (LE Q.inf) t with @@ -1394,6 +1411,10 @@ module ArbitraryCoeffsSet = struct in CoeffMap.fold fold_fun t CoeffMap.empty + let set_constant_lhs rhs_var const t ref_acc = CoeffMap.fold (fun k c ref_acc -> LinearInequality.set_constant_lhs rhs_var const (k,c) ref_acc) t ref_acc + let set_constant_rhs lhs_var const t ref_acc = CoeffMap.fold (fun k c ref_acc -> LinearInequality.set_constant_rhs lhs_var const (k,c) ref_acc) t ref_acc + + let invariant env x y t acc = CoeffMap.fold (LinearInequality.invariant env x y) t acc end @@ -1442,53 +1463,101 @@ module LinearInequalities : TwoVarInequalities = struct res let rec meet_relation x' y' cond get_rhs get_value t = + let meet_relation_roots x y k c (t, ref_acc) = + if M.tracing then M.tracel "transitivity" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); + (*do not save inequalities refering to the same variable*) + if x = y then + let s = Coeffs.Key.get_slope k in + if Q.equal Q.one s then (* x <= x + c (or >=) *) + match k with + | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + else (* sx <= x + c (or =>) -> refine the value in this case*) + let s' = Q.sub s Q.one in + let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in + (*s'x <= c' *) + if Q.gt s' Q.zero then + let max = Q.div c' s' in + t, (x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))) :: ref_acc + else + let min = Q.div c' s' in + t, (x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))) :: ref_acc + else + let coeffs = match get_coeff x y t with + | None -> Coeffs.empty + | Some c -> c + in let coeffs', ref_acc = Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in + if Coeffs.CoeffMap.is_empty coeffs' + then remove_coeff x y t , ref_acc + else set_coeff x y coeffs' t, ref_acc + in + let apply_transivity x y k c t = + if M.tracing then M.tracel "transitivity" "transitivity with %s and %s" (LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c)) (show t); + IntMap.fold (fun w zs acc -> + if w = x then + IntMap.fold (fun z cs acc -> + match Coeffs.combine_left (k,c) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 1, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 1, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string y) ("var_" ^ Int.to_string z) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots y z k c acc) cs' acc + ) zs acc + else if w = y then + IntMap.fold (fun z cs acc -> + match Coeffs.combine_right (k,c) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 2, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 2, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string z) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots x z k c acc) cs' acc + ) zs acc + else + IntMap.fold (fun z cs acc -> + if z = x then + match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 3, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 3, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string y) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w y k c acc) cs' acc + else if z = y then + match Coeffs.combine_right (LinearInequality.swap_sides (k,c)) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 4, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 4, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string x) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w x k c acc) cs' acc + else + acc + ) zs acc + ) t (t, []) + in match get_rhs x', get_rhs y' with | (Some (c_x, x),o_x,d_x), (Some (c_y, y),o_y,d_y) -> begin - let rhs_x = (c_x,o_x,d_x) in - let rhs_y = (c_y,o_y,d_y) in if x > y then (*We save information only in one of the directions*) meet_relation y' x' (Relation.swap_sides cond) get_rhs get_value t else - let coeffs = match get_coeff x y t with - | None -> Coeffs.empty - | Some c -> c - in let (k,c) = LinearInequality.from_rhss rhs_x rhs_y (Some (match fst cond with Relation.Lt -> true | _ -> false)) - in let meet_relation_roots k c (t:Coeffs.t) = - if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); - (*do not save inequalities refering to the same variable*) - if x = y then - let s = Coeffs.Key.get_slope k in - if Q.equal Q.one s then (* x <= x + c (or >=) *) - match k with - | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - else (* sx <= x + c (or =>) -> refine the value in this case*) - let s' = Q.sub s Q.one in - let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in - (*s'x <= c' *) - if Q.gt s' Q.zero then - let max = Q.div c' s' in - t, [x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))] - else - let min = Q.div c' s' in - t, [x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))] - (*TODO: transfer some transitivity, similar to the simple inequalities - idea: for every z combine every inequality relating z,x with this for a ineq relating z,y - same for z,y -> z,x - is this too arbitrary to be useful??? *) - else Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (t,[]) + let (k,c) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) (Some (match fst cond with Relation.Lt -> true | _ -> false)) in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) - let a = Q.make (Tuple3.first rhs_x) (Tuple3.third rhs_x) in - let b = Q.make (Tuple3.first rhs_y) (Tuple3.third rhs_y) in + let a = Q.make c_x d_x in + let b = Q.make c_y d_y in if Q.equal b Q.zero then a else b - in let (new_coeffs, refine_acc) = match cond with - | Relation.Lt, o -> meet_relation_roots k (Q.add c @@ Q.div (Q.of_bigint o) factor) coeffs - | Gt, o -> meet_relation_roots (Coeffs.Key.negate k) ((Q.add c @@ Q.div (Q.of_bigint o) factor) ) coeffs - | Eq, o -> coeffs, [] (*This should always be stored by the lin2vareq domain (at least the way we are generating this information)*) - in if Coeffs.CoeffMap.is_empty new_coeffs - then remove_coeff x y t , refine_acc - else set_coeff x y new_coeffs t, refine_acc + in match cond with + | Relation.Lt, o -> + let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in + let t, ref_acc = apply_transivity x y k c' t in + meet_relation_roots x y k c' (t, ref_acc) + | Gt, o -> + let k = Coeffs.Key.negate k in + let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in + let t, ref_acc = apply_transivity x y k c' t in + meet_relation_roots x y k c' (t,ref_acc) end (*Cases where one of the variables is a constant -> refine value*) | (None, o_x, _), (Some (_,y),_,_) -> t, [Refinement.of_value y @@ Relation.value_with_const_left cond o_x] @@ -1502,9 +1571,9 @@ module LinearInequalities : TwoVarInequalities = struct let meet_relation x y c r v t = - if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); + if M.tracing then M.tracel "transitivity" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); let res, refine_acc = meet_relation x y c r v t in - if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (Refinement.show refine_acc); + if M.tracing then M.tracel "transitivity" "result: %s, refinements: skipped! " (show res) (*Refinement.show refine_acc*); res, refine_acc let substitute t i (coeff, j, offs, divi) = @@ -1585,7 +1654,6 @@ module LinearInequalities : TwoVarInequalities = struct in let ineq_from_cond = match cond with | Relation.Lt, o -> k, (Q.add c @@ Q. div (Q.of_bigint o) factor) | Gt, o -> (Coeffs.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) - | Eq, o -> undefined "TODO" (*Should we exclude EQ from relation?*) in (*combine the inequality from cond with all inequalities*) (*throw out all inequalities that do not contain the representative of x*) @@ -1681,33 +1749,33 @@ end (*TODOs:*) -(*++ - ArbitraryCoeaffsList meet_single: take intervals into account better +(*!! options for limit function*) + +(*++ redo simple equalities (take advantage of the offset!, affine transform)*) + +(*++ ArbitraryCoeaffsList meet_single: take intervals into account better re-add them every time, remove them afterwards? - set_rhs constant refinement - set_value constant refinement -*) -(*-- assign expr restore ineqs based on value *) +*) -(*!! options for limit function*) +(*+ value refinement after every step?? *) -(*+ look at complexities. I expect for all: (n² log n) *) +(*+ look at complexities. I expect for all: (n² log n) + not leq because of interval fixpoint!!!*) (*+ How to do a useful narrow?*) -(*! meet_relations: do some transitivity: possible in complexity, but maybe expensive!*) + +(* domain inbetween these two: with offset between roots? -> should be trivial to implement*) + (* widening thresholds: from offsets of rhs?*) (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) -(*- copy_to_new: introduces too many inequlities?*) -(*+ redo simple equalities (take advantage of the offset!, affine transform)*) -(* domain inbetween these two: with offset between roots? -> should be trivial to implement*) -(*- better to_inequalities? with query?*) +(*- copy_to_new: introduces too many inequlities?*) (*- ineq refine_with_tcons: normalisation*) +(*- better to_inequalities? with query?*) -(*+ rework relation to offset domain -> remove Eq? *) -(*- memo_bumbvar created 3 times*) -(*- leq performance?*) +(*-- assign expr restore ineqs based on value *) +(*--memo_bumbvar created 3 times*) (*--eval_int: answer nonlinear*) -(*! general renaming*) +(*! general renaming*) (*!!rebase to main branch*) (*!!documentation (failing check!!) *) \ No newline at end of file From 40b19c015dce79a68c6a666f5dc1508fe729d721 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 13 May 2025 01:59:07 +0200 Subject: [PATCH 63/86] small fixes --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 13 +- .../apron/pentagonSubDomains.apron.ml | 141 +++++++++--------- 2 files changed, 80 insertions(+), 74 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index d847daa932..a794db8ec2 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -929,8 +929,9 @@ struct if M.tracing then M.trace "leq" "refined into %s" (EConjI.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) m1'); (*TODO the transformations are likely the most expensive part. -> only do it when econj did not rule it out*) IntMap.for_all (implies econ1') (snd econ2) (* even on sparse m2, it suffices to check the non-trivial equalities, still present in sparse m2 *) - && IntMap.for_all (implies_value m1') (vs2) - && Ineq.leq ineq1' (EConjI.get_value m1') ineq2 + && (if M.tracing then M.trace "leq" "econj true"; + IntMap.for_all (implies_value m1') (vs2)) + && (if M.tracing then M.trace "leq" "values true"; Ineq.leq ineq1' (EConjI.get_value m1') ineq2) with EConj.Contradiction -> if M.tracing then M.trace "leq" "refinement showed contradiction"; true (*t1 was secretely bot -> leq all*) @@ -1059,14 +1060,14 @@ struct | Some d' -> if M.tracing then M.tracel "assign_texpr" "assigning %s = %s before inequality: %s" (Var.show var) (Texpr1.show (Texpr1.of_expr t.env texp)) (show {d = Some d'; env = t.env}); let meet_cond (e,v,ineq) (cond, var) = - (*TODO value for i will be overwritten -> delay refinement?*) let dim = Environment.dim_of_var t.env var in if dim <> var_i then let ineq', refinements = Ineq.meet_relation var_i dim cond (EConjI.get_rhs d') (EConjI.get_value d') ineq in EConjI.apply_refinements refinements (e,v,ineq') else let ineq', refinements = Ineq.transfer dim cond ineq_old (EConjI.get_rhs d) (EConjI.get_value d) ineq (EConjI.get_rhs d') (EConjI.get_value d') - in EConjI.apply_refinements refinements (e,v,ineq') + (*TODO value for i will be overwritten -> delay refinement?*) + in EConjI.apply_refinements (Refinement.rhs_only refinements) (e,v,ineq') in let d'' = List.fold meet_cond d' (VarManagement.to_inequalities t texp) in if M.tracing then M.tracel "assign_texpr" "after inequality: %s" (show {d = Some d''; env = t.env}); @@ -1074,7 +1075,9 @@ struct end | None -> bot_env - let assign_texpr t var texp = timing_wrap "assign_texpr" (assign_texpr t var) texp + let assign_texpr t var texp = + if M.tracing then M.tracel "assign_texpr" "before assign: %s" (show t); + timing_wrap "assign_texpr" (assign_texpr t var) texp (* no_ov -> no overflow if it's true then there is no overflow diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 6aa42abd3d..b296afba50 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -368,7 +368,7 @@ module Refinement = struct let of_value var v = (var, Either.Left v) let of_rhs var r = (var, Either.right r) - let rhs_only t = List.filter (BatEither.is_right) t + let rhs_only t = List.filter (fun x -> BatEither.is_right (snd x)) t end @@ -816,7 +816,7 @@ module LinearInequality = struct if class1 <> class2 then class1 - class2 else - let open Q in compare (a1 * b2) (a2*b1) + let open Q in compare (a2*b1) (a1 * b2) (*different from paper , but otherwise wrong?*) let equal t1 t2 = 0 = compare t1 t2 @@ -1358,7 +1358,7 @@ module ArbitraryCoeffsSet = struct match CoeffMap.find_opt k t1 with (*look up in original t1 so that we can take care of widening for inequalities that get filtered*) | None -> (t1_f, t2_f) | Some c1 when Q.equal c1 c2 -> (t1_f, CoeffMap.remove k t2_f) - | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) && widen-> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound -> do widening*) + | Some c1 when widen-> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound -> do widening*) | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound*) | Some c1 -> (t1_f, CoeffMap.remove k t2_f) (*last remaining case: t1 has more relaxed bound*) in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) @@ -1462,9 +1462,9 @@ module LinearInequalities : TwoVarInequalities = struct if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); res - let rec meet_relation x' y' cond get_rhs get_value t = - let meet_relation_roots x y k c (t, ref_acc) = - if M.tracing then M.tracel "transitivity" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); + let meet_relation x' y' cond get_rhs get_value t = + let rec meet_relation_roots x y k c (t, ref_acc) = + if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); (*do not save inequalities refering to the same variable*) if x = y then let s = Coeffs.Key.get_slope k in @@ -1482,7 +1482,10 @@ module LinearInequalities : TwoVarInequalities = struct else let min = Q.div c' s' in t, (x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))) :: ref_acc - else + else if x > y then + let k', c' = LinearInequality.swap_sides (k,c) in + meet_relation_roots y x k' c' (t, ref_acc) + else let coeffs = match get_coeff x y t with | None -> Coeffs.empty | Some c -> c @@ -1492,72 +1495,72 @@ module LinearInequalities : TwoVarInequalities = struct else set_coeff x y coeffs' t, ref_acc in let apply_transivity x y k c t = - if M.tracing then M.tracel "transitivity" "transitivity with %s and %s" (LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c)) (show t); - IntMap.fold (fun w zs acc -> - if w = x then - IntMap.fold (fun z cs acc -> - match Coeffs.combine_left (k,c) cs with - | None -> - if M.tracing then M.tracel "transitivity" "case 1, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); - acc - | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 1, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string y) ("var_" ^ Int.to_string z) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots y z k c acc) cs' acc - ) zs acc - else if w = y then - IntMap.fold (fun z cs acc -> - match Coeffs.combine_right (k,c) cs with - | None -> - if M.tracing then M.tracel "transitivity" "case 2, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); - acc - | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 2, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string z) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots x z k c acc) cs' acc - ) zs acc - else - IntMap.fold (fun z cs acc -> - if z = x then - match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with + if x = y then begin + if M.tracing then M.tracel "transitivity" "transitivity between same variable %d -> skip" x; + t, [] + end else begin + if M.tracing then M.tracel "transitivity" "transitivity with %s and %s" (LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c)) (show t); + IntMap.fold (fun w zs acc -> + if w = x then + IntMap.fold (fun z cs acc -> + match Coeffs.combine_left (k,c) cs with | None -> - if M.tracing then M.tracel "transitivity" "case 3, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + if M.tracing then M.tracel "transitivity" "case 1, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 3, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string y) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w y k c acc) cs' acc - else if z = y then - match Coeffs.combine_right (LinearInequality.swap_sides (k,c)) cs with + if M.tracing then M.tracel "transitivity" "case 1, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string y) ("var_" ^ Int.to_string z) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots y z k c acc) cs' acc + ) zs acc + else if w = y then + IntMap.fold (fun z cs acc -> + match Coeffs.combine_right (k,c) cs with | None -> - if M.tracing then M.tracel "transitivity" "case 4, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + if M.tracing then M.tracel "transitivity" "case 2, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 4, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string x) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w x k c acc) cs' acc - else - acc - ) zs acc - ) t (t, []) - in + if M.tracing then M.tracel "transitivity" "case 2, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string z) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots x z k c acc) cs' acc + ) zs acc + else + IntMap.fold (fun z cs acc -> + if z = x then + match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 3, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 3, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string y) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w y k c acc) cs' acc + else if z = y then + match Coeffs.combine_right (LinearInequality.swap_sides (k,c)) cs with + | None -> + if M.tracing then M.tracel "transitivity" "case 4, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); + acc + | Some cs' -> + if M.tracing then M.tracel "transitivity" "case 4, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string x) cs'); + Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w x k c acc) cs' acc + else + acc + ) zs acc + ) t (t, []) + end in match get_rhs x', get_rhs y' with | (Some (c_x, x),o_x,d_x), (Some (c_y, y),o_y,d_y) -> begin - if x > y then - (*We save information only in one of the directions*) - meet_relation y' x' (Relation.swap_sides cond) get_rhs get_value t - else - let (k,c) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) (Some (match fst cond with Relation.Lt -> true | _ -> false)) - in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) - let a = Q.make c_x d_x in - let b = Q.make c_y d_y in - if Q.equal b Q.zero then a else b - in match cond with - | Relation.Lt, o -> - let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in - let t, ref_acc = apply_transivity x y k c' t in - meet_relation_roots x y k c' (t, ref_acc) - | Gt, o -> - let k = Coeffs.Key.negate k in - let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in - let t, ref_acc = apply_transivity x y k c' t in - meet_relation_roots x y k c' (t,ref_acc) + let (k,c) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) (Some (match fst cond with Relation.Lt -> true | _ -> false)) + in let factor = (*we need to divide o by this factor because LinearInequalities normalises it.*) + let a = Q.make c_x d_x in + let b = Q.make c_y d_y in + if Q.equal b Q.zero then a else b + in match cond with + | Relation.Lt, o -> + let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in + let t, ref_acc = apply_transivity x y k c' t in + meet_relation_roots x y k c' (t, ref_acc) + | Gt, o -> + let k = Coeffs.Key.negate k in + let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in + let t, ref_acc = apply_transivity x y k c' t in + meet_relation_roots x y k c' (t,ref_acc) end (*Cases where one of the variables is a constant -> refine value*) | (None, o_x, _), (Some (_,y),_,_) -> t, [Refinement.of_value y @@ Relation.value_with_const_left cond o_x] @@ -1571,9 +1574,9 @@ module LinearInequalities : TwoVarInequalities = struct let meet_relation x y c r v t = - if M.tracing then M.tracel "transitivity" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); + if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); let res, refine_acc = meet_relation x y c r v t in - if M.tracing then M.tracel "transitivity" "result: %s, refinements: skipped! " (show res) (*Refinement.show refine_acc*); + if M.tracing then M.tracel "meet_relation" "result: %s, refinements: skipped! " (show res) (*Refinement.show refine_acc*); res, refine_acc let substitute t i (coeff, j, offs, divi) = @@ -1665,7 +1668,6 @@ module LinearInequalities : TwoVarInequalities = struct in let filtered = IntMap.filter_map combine_1 t_old in if M.tracing then M.tracel "transfer" "filtered + combined %s" (show filtered); - (*transform all inequalities to refer to new root of x*) (*invert old rhs, then substitute the new rhs for x*) let (m, o, d) = Rhs.subst rhs x @@ snd @@ EConj.inverse x (coeff_old,x_root_old, off_old, divi_old) in @@ -1677,7 +1679,8 @@ module LinearInequalities : TwoVarInequalities = struct t', ref_acc @ ref_acc_2 | _,_ -> t, [] (*ignore constants*) - let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = + let cond = Relation.swap_sides cond in (*The interface changed, but I do not want to reimplement this function*) if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s" (Relation.show ("var_" ^ Int.to_string x ^ "_old") cond ("var_" ^ Int.to_string x ^ "_new") ) (show t_old) (show t); let res, ref_acc = transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value in if M.tracing then M.tracel "transfer" "result: %s, refinements: %s" (show res) (Refinement.show ref_acc); From 9c534dbe6888ac3e5005353a69aa3a7ddc411c53 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 13 May 2025 17:56:23 +0200 Subject: [PATCH 64/86] more fixes --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 1 - .../apron/pentagonSubDomains.apron.ml | 82 +++++++++++-------- 2 files changed, 46 insertions(+), 37 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a794db8ec2..30e885ab31 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1275,7 +1275,6 @@ struct let relift t = t - (*TODO add inequalities (and value information?) to invariants*) (** representation as C expression This function returns all the equalities that are saved in our datastructure t. diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index b296afba50..4a8506f5c6 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -986,17 +986,27 @@ module LinearInequality = struct | GE _, LE _ -> Some (LE f, Q.sub o (Q.mul f o_rel)) | LE _, GE _ -> Some (GE f, Q.sub o (Q.mul f o_rel)) + let combine_left rel t = + let res = combine_left rel t in + if M.tracing then M.trace "combine" "combine_left %s with %s -> %s" (show "x_old" "x_new" rel) (show "x_old" "y" t) (BatOption.map_default (fun res -> show "x_new" "y" res) "Nothing" res); + res + (*combine an inequaliy y_old -> y_new with x -> y_old to x-> y_new*) let combine_right (k_rel, o_rel) (k, o) = let open OriginInequality in (*factor we need to multiply the inequality x -> y_old with so that y_old has the same coefficient in both inequalities *) - let f = (get_slope k) in + let f = get_slope k_rel in let k' = if Q.geq f Q.zero then k else negate k in match k_rel, k' with | LE _, GE _ | GE _, LE _ -> None - | LE s_rel, LE s -> Some (LE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) - | GE s_rel, GE s -> Some (GE (Q.mul s s_rel), Q.add o_rel @@ Q.mul s o) + | LE s_rel, LE s -> Some (LE (Q.mul s f), Q.add o_rel @@ Q.mul f o) + | GE s_rel, GE s -> Some (GE (Q.mul s f), Q.add o_rel @@ Q.mul f o) + + let combine_right rel t = + let res = combine_right rel t in + if M.tracing then M.trace "combine" "combine_right %s with %s -> %s" (show "y_old" "y_new" rel) (show "x" "y_old" t) (BatOption.map_default (fun res -> show "x" "y_new" res) "Nothing" res); + res let set_constant_lhs rhs_var const (k,o) ref_acc = let open Q in @@ -1356,9 +1366,9 @@ module ArbitraryCoeffsSet = struct (* this prevents an inequality from being deemed redundant by an inequality that is later relaxed*) let relax k c2 (t1_f, t2_f) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) match CoeffMap.find_opt k t1 with (*look up in original t1 so that we can take care of widening for inequalities that get filtered*) - | None -> (t1_f, t2_f) | Some c1 when Q.equal c1 c2 -> (t1_f, CoeffMap.remove k t2_f) - | Some c1 when widen-> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound -> do widening*) + | _ when widen -> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has different bound -> do widening*) + | None -> (t1_f, t2_f) | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound*) | Some c1 -> (t1_f, CoeffMap.remove k t2_f) (*last remaining case: t1 has more relaxed bound*) in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) @@ -1464,36 +1474,36 @@ module LinearInequalities : TwoVarInequalities = struct let meet_relation x' y' cond get_rhs get_value t = let rec meet_relation_roots x y k c (t, ref_acc) = - if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); - (*do not save inequalities refering to the same variable*) - if x = y then - let s = Coeffs.Key.get_slope k in - if Q.equal Q.one s then (* x <= x + c (or >=) *) - match k with - | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) - else (* sx <= x + c (or =>) -> refine the value in this case*) - let s' = Q.sub s Q.one in - let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in - (*s'x <= c' *) - if Q.gt s' Q.zero then - let max = Q.div c' s' in - t, (x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))) :: ref_acc - else - let min = Q.div c' s' in - t, (x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))) :: ref_acc - else if x > y then + if x > y then let k', c' = LinearInequality.swap_sides (k,c) in meet_relation_roots y x k' c' (t, ref_acc) - else - let coeffs = match get_coeff x y t with - | None -> Coeffs.empty - | Some c -> c - in let coeffs', ref_acc = Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in - if Coeffs.CoeffMap.is_empty coeffs' - then remove_coeff x y t , ref_acc - else set_coeff x y coeffs' t, ref_acc - in + else begin + if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); + if x = y then + let s = Coeffs.Key.get_slope k in + if Q.equal Q.one s then (* x <= x + c (or >=) *) + match k with + | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + | GE _ -> if Q.gt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) + else (* sx <= x + c (or =>) -> refine the value in this case*) + let s' = Q.sub s Q.one in + let s', c' = match k with LE _ -> s',c | GE _ -> Q.neg s', Q.neg c in + (*s'x <= c' *) + if Q.gt s' Q.zero then + let max = Q.div c' s' in + t, (x, Either.Left (Value.ending @@ Z.cdiv (Q.num max) (Q.den max))) :: ref_acc + else + let min = Q.div c' s' in + t, (x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))) :: ref_acc + else + let coeffs = match get_coeff x y t with + | None -> Coeffs.empty + | Some c -> c + in let coeffs', ref_acc = Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in + if Coeffs.CoeffMap.is_empty coeffs' + then remove_coeff x y t , ref_acc + else set_coeff x y coeffs' t, ref_acc + end in let apply_transivity x y k c t = if x = y then begin if M.tracing then M.tracel "transitivity" "transitivity between same variable %d -> skip" x; @@ -1513,7 +1523,7 @@ module LinearInequalities : TwoVarInequalities = struct ) zs acc else if w = y then IntMap.fold (fun z cs acc -> - match Coeffs.combine_right (k,c) cs with + match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with | None -> if M.tracing then M.tracel "transitivity" "case 2, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc @@ -1524,7 +1534,7 @@ module LinearInequalities : TwoVarInequalities = struct else IntMap.fold (fun z cs acc -> if z = x then - match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with + match Coeffs.combine_right (k,c) cs with | None -> if M.tracing then M.tracel "transitivity" "case 3, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc @@ -1576,7 +1586,7 @@ module LinearInequalities : TwoVarInequalities = struct let meet_relation x y c r v t = if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); let res, refine_acc = meet_relation x y c r v t in - if M.tracing then M.tracel "meet_relation" "result: %s, refinements: skipped! " (show res) (*Refinement.show refine_acc*); + if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (Refinement.show refine_acc); res, refine_acc let substitute t i (coeff, j, offs, divi) = From b2e7eaa9082634f1030fd358c326d90e461b5980 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 16 May 2025 15:43:59 +0200 Subject: [PATCH 65/86] fixed join not being monotonic, also join inequalities where the other element only has intervals, split and simplified widen --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 8 ++- .../apron/pentagonSubDomains.apron.ml | 69 ++++++++++--------- 2 files changed, 43 insertions(+), 34 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 30e885ab31..7c09d61576 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -325,12 +325,16 @@ struct (*This is only called in assign_texpr, after which the value will be set correctly.*) let (_, (m,o,d)) = EConj.inverse i rhs in let c,_ = BatOption.get m in - let ineq', refinements = Ineq.substitute ineq i (c,i,o,d) in + let ineq', refinements = + if EConj.nontrivial econ i + then ineq, [] + else Ineq.substitute ineq i (c,i,o,d) + in apply_refinements refinements (EConj.affine_transform econ i rhs, vs, ineq') let affine_transform econ i (c,v,o,d) = let res = affine_transform econ i (c,v,o,d) in - if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); + if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d'=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); res end diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 4a8506f5c6..42484b7d9b 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -535,14 +535,14 @@ module CommonActions (Coeffs : Coeffs) = struct IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t2 (t1,[]) let join' widen t1 get_val_t1 t2 get_val_t2 = - let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 - in let merge_x x ys1 ys2 = + let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in + let merge_x x ys1 ys2 = match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t2 x) (get_val_t2 y) None coeff ) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter (fun y coeff -> Coeffs.implies (get_val_t1 x) (get_val_t1 y) None coeff ) ys2) + | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) - | _, _ -> None in - IntMap.merge (merge_x) t1 t2 + | _, _ -> None + in IntMap.merge (merge_x) t1 t2 let join = join' false let widen = join' true @@ -1342,15 +1342,10 @@ module ArbitraryCoeffsSet = struct if M.tracing then M.trace "implies" "x = %s, y = %s, %s implies %s ? -> %b" (Value.show x_val) (Value.show y_val) (BatOption.map_default (show_formatted "x" "y") "{}" t1_opt) (show_formatted "x" "y" t2) res; res - let join' widen x y get_val_t1 get_val_t2 t1 t2 = - let implies_single_equality t k c = - let res = match get_best_offset k t with None -> false | Some c' -> LinearInequality.entails1 (k, c') (k,c) - in if M.tracing then M.trace "implies" "single ineq: %s implies %s ? -> %b" (show_formatted "x" "y" t) (LinearInequality.show "x" "y" (k,c)) res; - res - in + let join x y get_val_t1 get_val_t2 t1 t2 = let t1 = match t1 with None -> CoeffMap.empty | Some t1 -> t1 in let t2 = match t2 with None -> CoeffMap.empty | Some t2 -> t2 in - (*add interval inequalities to copies, because doing it at every filter step would be more work*) + (*add interval inequalities to copies*) let t1_with_interval = let ineqs = LinearInequality.from_values (get_val_t1 x) (get_val_t1 y) in List.fold (fun t (k,c) -> add_inequality k c t) t1 ineqs @@ -1358,26 +1353,35 @@ module ArbitraryCoeffsSet = struct let ineqs = LinearInequality.from_values (get_val_t2 x) (get_val_t2 y) in List.fold (fun t (k,c) -> add_inequality k c t) t2 ineqs in - (*we want to keep inequalities that are in one of the elements and implied by the other (maxbe by also being in there) *) - let t1_filtered = CoeffMap.filter (implies_single_equality t2_with_interval) t1_with_interval in - let t2_filtered = CoeffMap.filter (implies_single_equality t1_with_interval) t2_with_interval in - (* merge the two sets. if one inequality is in both, take the less tight bound *) - (* we make two passes over the list: first the relaxation, then adding all other inequalities*) - (* this prevents an inequality from being deemed redundant by an inequality that is later relaxed*) - let relax k c2 (t1_f, t2_f) = (*we need to modify t2 because in the case of widening, the key might not be in both after this first step *) - match CoeffMap.find_opt k t1 with (*look up in original t1 so that we can take care of widening for inequalities that get filtered*) - | Some c1 when Q.equal c1 c2 -> (t1_f, CoeffMap.remove k t2_f) - | _ when widen -> (CoeffMap.remove k t1_f, CoeffMap.remove k t2_f) (*t2 has different bound -> do widening*) - | None -> (t1_f, t2_f) - | Some c1 when LinearInequality.entails1 (k,c1) (k,c2) -> (CoeffMap.add k c2 t1_f, CoeffMap.remove k t2_f) (*t2 has more relaxed bound*) - | Some c1 -> (t1_f, CoeffMap.remove k t2_f) (*last remaining case: t1 has more relaxed bound*) - in let t1_filtered', t2_filtered' = CoeffMap.fold relax t2_filtered (t1_filtered, t2_filtered) - in let merged = CoeffMap.fold add_inequality t2_filtered' t1_filtered' - (*remove the explicetly stored interval inequalities*) - in ignore_empty @@ CoeffMap.remove (LE Q.zero) @@ CoeffMap.remove (GE Q.zero) @@ CoeffMap.remove (LE Q.inf) @@ CoeffMap.remove (GE Q.inf) merged + (*Keep slopes where the other element implies some inequality for the same slope *) + let relax t k c = + let res = match get_best_offset k t with + | None -> None (*drop if nothing is implied *) + | Some c' -> (* in this case, we need to take the more relaxed bound*) + if LinearInequality.entails1 (k, c') (k,c) then + Some c + else + Some c' + in + if M.tracing then M.trace "relax" "%s with %s relaxed to %s" (show_formatted "x" "y" t) (LinearInequality.show "x" "y" (k,c)) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing" res); + res + in + let t1_mapped = CoeffMap.filter_map (relax t2_with_interval) t1 in + let t2_mapped = CoeffMap.filter_map (relax t1_with_interval) t2 in + (* merge the two sets *) + (*the existing add assumes there to be no inequality with this key. this happens only if both have the same offset now *) + let add_inequality k c t = if CoeffMap.mem k t then t else add_inequality k c t in + let merged = CoeffMap.fold add_inequality t2_mapped t1_mapped + in ignore_empty merged + + let widen _ _ _ _ t1 t2 = + let open GobOption.Syntax in + (*only keep inequalities that are in both equations*) + let keep_same k c1 c2 = if c1 = c2 then c1 else None in + let* t1 = t1 in + let* t2 = t2 in + ignore_empty @@ CoeffMap.merge (keep_same) t1 t2 - let join = join' false - let widen = join' true let meet = meet' false let narrow = meet' true @@ -1764,6 +1768,7 @@ end (*!! options for limit function*) +(*!! fix cohencu tests*) (*++ redo simple equalities (take advantage of the offset!, affine transform)*) (*++ ArbitraryCoeaffsList meet_single: take intervals into account better From 2dacbbe802894253b4da97463224e5b37210297b Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 19 May 2025 09:21:56 +0200 Subject: [PATCH 66/86] accelerated narrowing, formatting --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 9 ++- .../apron/pentagonSubDomains.apron.ml | 59 ++++++++++++------- 2 files changed, 44 insertions(+), 24 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 7c09d61576..423ebb8b78 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -104,6 +104,9 @@ struct in IntMap.fold meet_with_rhs (snd econ) i + let constrain_with_congruence_from_rhs econ lhs i =(**TODO do not recalculate this every time?*) + timing_wrap "congruence" (constrain_with_congruence_from_rhs econ lhs) i + (*TODO make this configureable with options*) let refine_depth = 5 @@ -327,9 +330,9 @@ struct let c,_ = BatOption.get m in let ineq', refinements = if EConj.nontrivial econ i - then ineq, [] - else Ineq.substitute ineq i (c,i,o,d) - in + then ineq, [] + else Ineq.substitute ineq i (c,i,o,d) + in apply_refinements refinements (EConj.affine_transform econ i rhs, vs, ineq') let affine_transform econ i (c,v,o,d) = diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/pentagonSubDomains.apron.ml index 42484b7d9b..569b45f942 100644 --- a/src/cdomains/apron/pentagonSubDomains.apron.ml +++ b/src/cdomains/apron/pentagonSubDomains.apron.ml @@ -524,29 +524,34 @@ module CommonActions (Coeffs : Coeffs) = struct let meet_one_coeff narrow get_value x y coeff (t,ref_acc) = let coeff_t = get_coeff x y t in let coeff_met, ref_acc' = match coeff_t with - | None -> coeff, ref_acc - | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (x, get_value x) (y, get_value y) coeff coeff_t ref_acc + | None -> coeff, ref_acc (*also fine for narrow if t is the one on the righthandside*) + | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (x, get_value x) (y, get_value y) coeff_t coeff ref_acc in set_coeff x y coeff_met t, ref_acc' let meet get_value t1 t2 = - IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y coeff acc) ys acc) t2 (t1,[]) + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y coeff acc) ys acc) t1 (t2,[]) let narrow get_value t1 t2 = - IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t2 (t1,[]) + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t1 (t2,[]) let join' widen t1 get_val_t1 t2 get_val_t2 = let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in let merge_x x ys1 ys2 = - match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) - | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) - | _, _ -> None + match ys1, ys2 with + | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) + | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) + | _, _ -> None in IntMap.merge (merge_x) t1 t2 let join = join' false let widen = join' true + let widen a b c d = + let res = widen a b c d in + if M.tracing then M.trace "widen" "called for inequalities"; + res + let interval_refinements get_value t = IntMap.fold (fun x ys acc -> IntMap.fold (fun y cs acc -> Coeffs.interval_refinements @@ -1227,7 +1232,7 @@ module ArbitraryCoeffsSet = struct | Some lower -> (Refinement.of_value y @@ Value.starting @@ round_up @@ Q.neg lower ):: ref_acc | _ -> ref_acc - let meet_single_inequality narrow (x,x_val) (y,y_val) k c (t,ref_acc) = + let meet_single_inequality (x,x_val) (y,y_val) k c (t,ref_acc) = (*calculate value refinement. If one of the coefficients is zero, we should not add the inequality to the map*) let refinements, skip_adding = let x_refine = @@ -1307,13 +1312,28 @@ module ArbitraryCoeffsSet = struct (*add the inequality, while making sure that we do not save redundant inequalities*) (*TODO make this consider the intervals! -> adapt get_next and get_previous?*) let t' = match CoeffMap.find_opt k t with - | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) (*TODO narrow?*) + | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) in let ref_acc = interval_refinements (x,x_val) (y,y_val) t' ref_acc in t', ref_acc - let meet' narrow x_val y_val t1 t2 ref_acc = CoeffMap.fold (fun k c acc -> meet_single_inequality narrow x_val y_val k c acc) t1 (t2,ref_acc) + let meet x_val y_val t1 t2 ref_acc = CoeffMap.fold (meet_single_inequality x_val y_val) t1 (t2,ref_acc) + + let narrow x_val y_val t1 t2 ref_acc = + let narrow_single_inequality k c ((t,_) as acc) = + if CoeffMap.mem k t then + acc (*accelerated narowing: only restrict top bounds to only have finite number of narrowings*) + else + fst @@ meet_single_inequality x_val y_val k c acc, [] + in + CoeffMap.fold narrow_single_inequality t2 (t1,ref_acc) + + let narrow x_val y_val t1 t2 ref_acc = + let res = narrow x_val y_val t1 t2 ref_acc in + if M.tracing then M.trace "narrow" "narrow for coeffs a: %s b: %s -> %s" (show_formatted "x" "y" t1) (show_formatted "x" "y" t2) (show_formatted "x" "y" @@ fst res); + res + let implies x_val y_val t1_opt t2 = let t1 = match t1_opt with @@ -1355,16 +1375,16 @@ module ArbitraryCoeffsSet = struct in (*Keep slopes where the other element implies some inequality for the same slope *) let relax t k c = - let res = match get_best_offset k t with + let res = match get_best_offset k t with | None -> None (*drop if nothing is implied *) | Some c' -> (* in this case, we need to take the more relaxed bound*) if LinearInequality.entails1 (k, c') (k,c) then Some c else Some c' - in - if M.tracing then M.trace "relax" "%s with %s relaxed to %s" (show_formatted "x" "y" t) (LinearInequality.show "x" "y" (k,c)) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing" res); - res + in + if M.tracing then M.trace "relax" "%s with %s relaxed to %s" (show_formatted "x" "y" t) (LinearInequality.show "x" "y" (k,c)) (BatOption.map_default (fun c -> LinearInequality.show "x" "y" (k,c)) "Nothing" res); + res in let t1_mapped = CoeffMap.filter_map (relax t2_with_interval) t1 in let t2_mapped = CoeffMap.filter_map (relax t1_with_interval) t2 in @@ -1376,15 +1396,12 @@ module ArbitraryCoeffsSet = struct let widen _ _ _ _ t1 t2 = let open GobOption.Syntax in - (*only keep inequalities that are in both equations*) + (*only keep inequalities that the same are in both equations*) let keep_same k c1 c2 = if c1 = c2 then c1 else None in let* t1 = t1 in let* t2 = t2 in ignore_empty @@ CoeffMap.merge (keep_same) t1 t2 - let meet = meet' false - let narrow = meet' true - let substitute_left (coeff, offs, divi) t = let f k c t_acc = let (k',c') = LinearInequality.substitute_left (coeff, offs, divi) (k,c) in @@ -1503,7 +1520,7 @@ module LinearInequalities : TwoVarInequalities = struct let coeffs = match get_coeff x y t with | None -> Coeffs.empty | Some c -> c - in let coeffs', ref_acc = Coeffs.meet_single_inequality false (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in + in let coeffs', ref_acc = Coeffs.meet_single_inequality (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in if Coeffs.CoeffMap.is_empty coeffs' then remove_coeff x y t , ref_acc else set_coeff x y coeffs' t, ref_acc From 22eb2b3b3760130a7f04b8b4d89a2a111323058b Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 21 May 2025 23:11:52 +0200 Subject: [PATCH 67/86] Allow division in linear relation if congruence proves exactness, small fixes --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 118 +++++++++++------- 1 file changed, 70 insertions(+), 48 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 423ebb8b78..11899fe155 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -352,6 +352,53 @@ struct let dim_add = EConjI.dim_add let size t = BatOption.map_default (fun ((d,_),_,_) -> d) 0 t.d + let eval_texpr (t:t) texp = + let open Apron.Texpr1 in + let binop_function = function + | Add -> Value.add + | Sub -> Value.sub + | Mul -> Value.mul + | Div -> Value.div + | Mod -> Value.rem + | Pow -> failwith "power is not supported" + in let unop_function = function + | Neg -> Value.neg + | Cast -> identity + | Sqrt -> failwith "sqrt is not supported" + in let rec eval = function + | Cst (Scalar x) -> + begin match SharedFunctions.int_of_scalar ?round:None x with + | Some x -> Value.of_bigint x + | None -> Value.top + end + | Cst (Interval _) -> failwith "constant was an interval; this is not supported" + | Var x -> + let var_dim = Environment.dim_of_var t.env x in + begin match t.d with + | None -> Value.top + | Some d -> EConjI.get_value d var_dim + end + | Binop (Sub, Var a , Var b, Int, _) -> + let dim_a = Environment.dim_of_var t.env a in + let dim_b = Environment.dim_of_var t.env b in + begin match t.d with + | None -> Value.top + | Some d -> + let v = Value.sub (EConjI.get_value d dim_a) (EConjI.get_value d dim_b) in + let relations = EConjI.get_relations d dim_a dim_b in + let meet_relation v = function + | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.sub o Z.one + | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.add o Z.one + in List.fold meet_relation v relations + end + | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) + | Unop (op, a, Int, _) -> (unop_function op) (eval a) + | _ -> Value.top (*not integers*) + in + let res = eval texp in + if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (match t.d with None -> "⊥" | Some d ->EConjI.show d) Texpr1.Expr.pretty texp (Value.show res); + res + (** Parses a Texpr to obtain a (coefficient, variable) pair list to repr. a sum of a variables that have a coefficient. If variable is None, the coefficient represents a constant offset. *) let monomials_from_texp (t: t) texp = let open Apron.Texpr1 in @@ -390,6 +437,21 @@ struct | Binop (Add, e1, e2, _, _) -> convert_texpr e1 @ convert_texpr e2 | Binop (Sub, e1, e2, _, _) -> convert_texpr e1 @ negate (convert_texpr e2) | Binop (Mul, e1, e2, _, _) -> multiply (convert_texpr e1) (convert_texpr e2) + | Binop (Div, e1, e2, _, _) -> begin + match convert_texpr e2 with + | [(None,coeff, divi)] -> + if Z.equal (Z.rem coeff divi) Z.zero then + let d = Z.divexact coeff divi in + let e1_val = eval_texpr t e1 in + if Value.leq e1_val (Value.of_congruence (Z.zero, d)) then + (*the division is exact -> the expression is still linear*) + List.map (fun (monom, offs, divi) -> Rhs.canonicalize Z.(monom, offs, divi*d) ) (convert_texpr e1) + else + raise NotLinearExpr + else + raise NotLinearExpr + | _ -> raise NotLinearExpr + end | Binop _ -> raise NotLinearExpr end in match convert_texpr texp with | exception NotLinearExpr -> None @@ -428,53 +490,6 @@ struct let simplify_to_ref_and_offset t texp = timing_wrap "coeff_vec" (simplify_to_ref_and_offset t) texp - let eval_texpr (t:t) texp = - let open Apron.Texpr1 in - let binop_function = function - | Add -> Value.add - | Sub -> Value.sub - | Mul -> Value.mul - | Div -> Value.div - | Mod -> Value.rem - | Pow -> failwith "power is not supported" - in let unop_function = function - | Neg -> Value.neg - | Cast -> identity - | Sqrt -> failwith "sqrt is not supported" - in let rec eval = function - | Cst (Scalar x) -> - begin match SharedFunctions.int_of_scalar ?round:None x with - | Some x -> Value.of_bigint x - | None -> Value.top - end - | Cst (Interval _) -> failwith "constant was an interval; this is not supported" - | Var x -> - let var_dim = Environment.dim_of_var t.env x in - begin match t.d with - | None -> Value.top - | Some d -> EConjI.get_value d var_dim - end - | Binop (Sub, Var a , Var b, Int, _) -> - let dim_a = Environment.dim_of_var t.env a in - let dim_b = Environment.dim_of_var t.env b in - begin match t.d with - | None -> Value.top - | Some d -> - let v = Value.sub (EConjI.get_value d dim_a) (EConjI.get_value d dim_b) in - let relations = EConjI.get_relations d dim_a dim_b in - let meet_relation v = function - | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.sub o Z.one - | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.add o Z.one - in List.fold meet_relation v relations - end - | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) - | Unop (op, a, Int, _) -> (unop_function op) (eval a) - | _ -> Value.top (*not integers*) - in - let res = eval texp in - if M.tracing then M.tracel "eval_texp" "%s %a -> %s" (match t.d with None -> "⊥" | Some d ->EConjI.show d) Texpr1.Expr.pretty texp (Value.show res); - res - (*TODO We also only catch variables on the first level, but miss e.g. (x+7)+7 -> use more recursion similar to negate?*) let rec to_inequalities (t:t) texpr = let open Apron.Texpr1 in @@ -803,9 +818,12 @@ struct | Binop (Add, exp, (Binop (Sub, Var a, Var b,_,_)),_,_) | Binop (Add, (Binop (Sub, exp, Var b,_,_)), Var a, _,_) | Binop (Add, (Binop (Sub, Var a, Var b,_,_)), exp, _,_) + | Binop (Sub, (Binop (Add, Var a, exp,_,_)), Var b, _,_) + | Binop (Sub, (Binop (Add, exp, Var a,_,_)), Var b, _,_) | Binop (Sub, exp, (Binop (Sub, Var b, Var a,_,_)),_,_) -> meet_relation a b (eval_texpr {d=Some d;env=t.env} exp) | Binop (Sub, Var a, Var b, _, _) -> meet_relation a b (Value.of_bigint Z.zero) - | Binop (Sub, (Binop (Sub, Var a, Var b,_,_)), exp, _,_) + | Binop (Sub, (Binop (Sub, Var a, Var b,_,_)), exp, _,_) + | Binop (Sub, (Binop (Sub, Var a, exp,_,_)), Var b, _,_) | Binop (Sub, Var a, (Binop (Add, Var b, exp,_,_)),_,_) | Binop (Sub, Var a, (Binop (Add, exp, Var b,_,_)),_,_) -> meet_relation a b (Value.neg @@ eval_texpr {d=Some d;env=t.env} exp) | _ -> d @@ -905,6 +923,7 @@ struct in let implies_value v i value = Value.leq (EConjI.get_value v i) value in + if is_bot t1 then true else if BatOption.is_none t1.d then true else (*This kind of bot does not require the environment to be a superset*) if env_comp = -2 || env_comp > 0 then false else if is_bot_env t1 || is_top t2 then true @@ -979,6 +998,9 @@ struct let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in Some (e,v, Ineq.limit e i) in + (*This is a different kind of bot that we need to catch*) + if is_bot a then b else + if is_bot b then a else (*Normalize the two domains a and b such that both talk about the same variables*) match a.d, b.d with | None, _ -> b From de4e5bbda5b223c9eb4426b27a7b4bc995fbdcf2 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 24 May 2025 01:25:24 +0200 Subject: [PATCH 68/86] do not lose value information when entering a function body --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 46 ++++++++++--------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 11899fe155..0f7dadd069 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1001,20 +1001,20 @@ struct (*This is a different kind of bot that we need to catch*) if is_bot a then b else if is_bot b then a else - (*Normalize the two domains a and b such that both talk about the same variables*) - match a.d, b.d with - | None, _ -> b - | _, None -> a - | Some x, Some y when is_top a || is_top b -> - let new_env = Environment.lce a.env b.env in - top_of new_env - | Some x, Some y when (Environment.cmp a.env b.env <> 0) -> - let sup_env = Environment.lce a.env b.env in - let mod_x = dim_add (Environment.dimchange a.env sup_env) x in - let mod_y = dim_add (Environment.dimchange b.env sup_env) y in - {d = join_d mod_x mod_y sup_env; env = sup_env} - | Some x, Some y when EConjI.equal x y -> {d = Some x; env = a.env} - | Some x, Some y -> {d = join_d x y a.env; env = a.env} + (*Normalize the two domains a and b such that both talk about the same variables*) + match a.d, b.d with + | None, _ -> b + | _, None -> a + | Some x, Some y when is_top a || is_top b -> + let new_env = Environment.lce a.env b.env in + top_of new_env + | Some x, Some y when (Environment.cmp a.env b.env <> 0) -> + let sup_env = Environment.lce a.env b.env in + let mod_x = dim_add (Environment.dimchange a.env sup_env) x in + let mod_y = dim_add (Environment.dimchange b.env sup_env) y in + {d = join_d mod_x mod_y sup_env; env = sup_env} + | Some x, Some y when EConjI.equal x y -> {d = Some x; env = a.env} + | Some x, Some y -> {d = join_d x y a.env; env = a.env} let join = join' false @@ -1065,7 +1065,7 @@ struct (** implemented as described on page 10 in the paper about Fast Interprocedural Linear Two-Variable Equalities in the Section "Abstract Effect of Statements" This makes a copy of the data structure, it doesn't change it in-place. *) - let assign_texpr (t: VarManagement.t) var texp = + let assign_texpr (t: VarManagement.t) var texp assign_value = match t.d with | Some ((econj, vs, ineq_old) as d) -> let var_i = Environment.dim_of_var t.env var (* this is the variable we are assigning to *) in @@ -1078,12 +1078,14 @@ struct assign_const (forget_var t var) var_i off divi | Some (Some (coeff_var,exp_var), off, divi) when var_i = exp_var -> (* Statement "assigned_var = (coeff_var*assigned_var + off) / divi" *) - let econji' = econj, IntMap.remove var_i vs, ineq_old in (*value will be updated afterwards with query*) + let econji' = econj, IntMap.remove var_i vs, ineq_old in {d=Some (EConjI.affine_transform econji' var_i (coeff_var, var_i, off, divi)); env=t.env } | Some (Some monomial, off, divi) -> (* Statement "assigned_var = (monomial) + off / divi" (assigned_var is not the same as exp_var) *) meet_with_one_conj (forget_var t var) var_i (Some (monomial), off, divi) - in begin match t'.d with + in + let t' = if assign_value then meet_with_one_value false var_i (eval_texpr t texp) t' else t' (*value will be updated afterwards with query*) in + begin match t'.d with None -> if M.tracing then M.tracel "ops" "assign_texpr resulted in bot (before: %s, expr: %s) " (show t) (Texpr1.show (Texpr1.of_expr t.env texp)); bot_env | Some d' -> @@ -1104,9 +1106,9 @@ struct end | None -> bot_env - let assign_texpr t var texp = - if M.tracing then M.tracel "assign_texpr" "before assign: %s" (show t); - timing_wrap "assign_texpr" (assign_texpr t var) texp + let assign_texpr t var texp assign_value = + if M.tracing then M.tracel "assign_texpr" "before assign: %s, assign_value= %b" (show t) assign_value; + timing_wrap "assign_texpr" (assign_texpr t var texp) assign_value (* no_ov -> no overflow if it's true then there is no overflow @@ -1115,7 +1117,7 @@ struct let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in (*evaluate in the same way as is used for simplification*) let t = match Convert.texpr1_expr_of_cil_exp ask t t.env exp no_ov with - | texp -> assign_texpr t var texp + | texp -> assign_texpr t var texp false | exception Convert.Unsupported_CilExp _ -> forget_var t var in match t.d with | None -> t @@ -1150,7 +1152,7 @@ struct let assign_var (t: VarManagement.t) v v' = let t = add_vars t [v; v'] in - assign_texpr t v (Var v') + assign_texpr t v (Var v') true let assign_var t v v' = let res = assign_var t v v' in From 17e223be2a4c5cf9194a50a63c0b2c9cd92f96f9 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 14 Jun 2025 13:46:03 +0200 Subject: [PATCH 69/86] add missing --- src/goblint_lib.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index a13d6c9120..4b886188bd 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -80,6 +80,7 @@ module ApronAnalysis = ApronAnalysis module AffineEqualityAnalysis = AffineEqualityAnalysis module LinearTwoVarEqualityAnalysis = LinearTwoVarEqualityAnalysis module LinearTwoVarEqualityAnalysisPentagon = LinearTwoVarEqualityAnalysisPentagon +module PentagonSubDomains = PentagonSubDomains module VarEq = VarEq module CondVars = CondVars module TmpSpecial = TmpSpecial From bc169d8d24bb3b717e43be126c9367b57c15ada7 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sun, 15 Jun 2025 01:46:20 +0200 Subject: [PATCH 70/86] Rename file --- .../apron/linearTwoVarEqualityAnalysisPentagon.apron.ml | 4 ++-- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 2 +- ...ntagonSubDomains.apron.ml => representantDomains.apron.ml} | 0 ...SubDomains.no-apron.ml => representantDomains.no-apron.ml} | 0 src/goblint_lib.ml | 2 +- 5 files changed, 4 insertions(+), 4 deletions(-) rename src/cdomains/apron/{pentagonSubDomains.apron.ml => representantDomains.apron.ml} (100%) rename src/cdomains/apron/{pentagonSubDomains.no-apron.ml => representantDomains.no-apron.ml} (100%) diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml index 617d5cb4f9..3c1717f149 100644 --- a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -5,8 +5,8 @@ open Analyses include RelationAnalysis -module NoIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.NoInequalties) -module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(PentagonSubDomains.LinearInequalities) +module NoIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.NoInequalties) +module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.LinearInequalities) let spec_module: (module MCPSpec) Lazy.t = lazy ( diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 81890e7207..c4de65f907 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -4,7 +4,7 @@ open Batteries open GoblintCil open Pretty open GobApron -open PentagonSubDomains +open RepresentantDomains module EqualitiesConjunctionWithIntervals (Ineq : TwoVarInequalities) = struct diff --git a/src/cdomains/apron/pentagonSubDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml similarity index 100% rename from src/cdomains/apron/pentagonSubDomains.apron.ml rename to src/cdomains/apron/representantDomains.apron.ml diff --git a/src/cdomains/apron/pentagonSubDomains.no-apron.ml b/src/cdomains/apron/representantDomains.no-apron.ml similarity index 100% rename from src/cdomains/apron/pentagonSubDomains.no-apron.ml rename to src/cdomains/apron/representantDomains.no-apron.ml diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 8ced58ad04..a1431cd8a3 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -78,7 +78,7 @@ module ApronAnalysis = ApronAnalysis module AffineEqualityAnalysis = AffineEqualityAnalysis module LinearTwoVarEqualityAnalysis = LinearTwoVarEqualityAnalysis module LinearTwoVarEqualityAnalysisPentagon = LinearTwoVarEqualityAnalysisPentagon -module PentagonSubDomains = PentagonSubDomains +module RepresentantDomains = RepresentantDomains module VarEq = VarEq module CondVars = CondVars module TmpSpecial = TmpSpecial From 6890fa96b340028dde03f39565e6ae498aba821d Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sun, 15 Jun 2025 02:30:46 +0200 Subject: [PATCH 71/86] forgot adding dune file --- src/dune | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/dune b/src/dune index 7e6f436898..6fec8243cd 100644 --- a/src/dune +++ b/src/dune @@ -51,9 +51,9 @@ (apron -> linearTwoVarEqualityAnalysisPentagon.apron.ml) (-> linearTwoVarEqualityAnalysisPentagon.no-apron.ml) ) - (select pentagonSubDomains.ml from - (apron -> pentagonSubDomains.apron.ml) - (-> pentagonSubDomains.no-apron.ml) + (select representantDomains.ml from + (apron -> representantDomains.apron.ml) + (-> representantDomains.no-apron.ml) ) (select linearTwoVarEqualityDomainPentagon.ml from (apron -> linearTwoVarEqualityDomainPentagon.apron.ml) From 3019518d51fd458936180e2465c19106cd6360b2 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 20 Jun 2025 00:26:35 +0200 Subject: [PATCH 72/86] add weaker domains, proper options --- conf/svcomp25_testing.json | 6 +- ...earTwoVarEqualityAnalysisPentagon.apron.ml | 10 +- src/autoTune.ml | 6 +- ...inearTwoVarEqualityDomainPentagon.apron.ml | 18 +- .../apron/representantDomains.apron.ml | 752 ++++++++---------- src/config/options.schema.json | 35 +- 6 files changed, 394 insertions(+), 433 deletions(-) diff --git a/conf/svcomp25_testing.json b/conf/svcomp25_testing.json index 250760fc51..51402ffaf6 100644 --- a/conf/svcomp25_testing.json +++ b/conf/svcomp25_testing.json @@ -56,6 +56,9 @@ "free": false, "call": false }, + "lin2vareq_p": { + "inequalities" : "coeffs_threshold" + }, "autotune": { "enabled": false, "activated": [ @@ -71,7 +74,8 @@ "noOverflows", "termination", "tmpSpecialAnalysis" - ] + ], + "extraTerminationDomain": "lin2vareq_p" } }, "exp": { diff --git a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml index 3c1717f149..1a7fe4a106 100644 --- a/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml +++ b/src/analyses/apron/linearTwoVarEqualityAnalysisPentagon.apron.ml @@ -6,11 +6,17 @@ open Analyses include RelationAnalysis module NoIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.NoInequalties) -module WithIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.LinearInequalities) +module PentagonIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.InequalityFunctor(RepresentantDomains.PentagonCoeffs)) +module PentagonOffsetIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.InequalityFunctor(RepresentantDomains.PentagonOffsetCoeffs)) +module FullIneq = LinearTwoVarEqualityDomainPentagon.D2(RepresentantDomains.InequalityFunctor(RepresentantDomains.TwoVarInequalitySet)) let spec_module: (module MCPSpec) Lazy.t = lazy ( - let (module AD) = if GobConfig.get_bool "ana.lin2vareq_p" then (module WithIneq : RelationDomain.RD) else (module NoIneq : RelationDomain.RD) + let (module AD) = match GobConfig.get_string "ana.lin2vareq_p.inequalities" with + | "none" -> (module NoIneq : RelationDomain.RD) + | "pentagon" -> (module PentagonIneq : RelationDomain.RD) + | "pentagon_offset" -> (module PentagonOffsetIneq : RelationDomain.RD) + | _ -> (module FullIneq : RelationDomain.RD) (*Other options differ only in the limit function*) in let module Priv = (val RelationPriv.get_priv ()) in let module Spec = diff --git a/src/autoTune.ml b/src/autoTune.ml index 3bd81edda8..ec8259fff4 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -248,12 +248,12 @@ let focusOnMemSafetySpecification () = let focusOnTermination (spec: Svcomp.Specification.t) = match spec with | Termination -> - let terminationAnas = ["threadflag"; "apron"] in + let terminationAnas = ["threadflag"; get_string "ana.autotune.extraTerminationDomain"] in enableAnalyses "Specification: Termination" "termination analyses" terminationAnas; set_string "sem.int.signed_overflow" "assume_none"; set_bool "ana.int.interval" true; - set_string "ana.apron.domain" "polyhedra"; (* TODO: Needed? *) - () + if get_string "ana.autotune.extraTerminationDomain" = "apron" then + set_string "ana.apron.domain" "polyhedra"; (* TODO: Needed? *) | _ -> () let focusOnTermination () = diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index c4de65f907..385dae8cca 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -187,7 +187,7 @@ struct let econj' = (dim, IntMap.add x (vary, o, d) @@ IntMap.map adjust econj) in (* in case of sparse representation, make sure that the equality is now included in the conjunction *) match vary with | Some (c,y) -> (*x was a representant but is not anymore*) - let ineq', refinements = Ineq.substitute ineq x (c, y, o, d) + let ineq', refinements = Ineq.substitute (get_value (econj', is, ineq)) ineq x (c, y, o, d) in let is' = IntMap.remove x is in (*remove value and add it back in the new econj *) let t' = econj', is', ineq' in let t'' = set_value t' x value in @@ -296,7 +296,7 @@ struct | None -> (econj'', vs'', Ineq.forget_variable ineq' var) | Some (Some (coeff,y),offs,divi) -> (*modify inequalities. We ignore refinements as they should not matter in this case*) - let ineq'', _ = Ineq.substitute ineq' var (coeff,y,offs,divi) + let ineq'', _ = Ineq.substitute (get_value (econj'', vs'', ineq')) ineq' var (coeff,y,offs,divi) (*restoring value information*) in set_value (econj'', vs'', ineq'') y @@ get_value d y | _ -> failwith "Should not happen" (*transformation can not be a constant*) @@ -328,7 +328,7 @@ struct let ineq', refinements = if EConj.nontrivial econ i then ineq, [] - else Ineq.substitute ineq i (c,i,o,d) + else Ineq.substitute (get_value (econ, vs, ineq)) ineq i (c,i,o,d) in apply_refinements refinements (EConj.affine_transform econ i rhs, vs, ineq') @@ -936,11 +936,11 @@ struct | Some (c,v) -> match EConj.get_rhs econ1 var with | Some (_,v),_,_ when v <> var -> ineq_acc - | _ -> let ineq', _ = Ineq.substitute ineq_acc var (c,v,o,d) in ineq' + | _ -> let ineq', _ = Ineq.substitute (EConjI.get_value (econ1, vs1, ineq1)) ineq_acc var (c,v,o,d) in ineq' in let ineq1' = IntMap.fold transform_non_representant (snd econ2) ineq1 in (*further, econ2 might have some new representants -> transform further*) - let ineq1' = Ineq.copy_to_new_representants econ1 econ2 ineq1' in + let ineq1' = Ineq.copy_to_new_representants econ1 econ2 (EConjI.get_value (econ2, vs2, ineq2)) ineq1' in if M.tracing then M.trace "leq" "transformed %s into %s" (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1) (Ineq.show_formatted (fun i -> Var.show @@ Environment.var_of_dim t2.env i) ineq1'); (*Normally, we do not apply closure to the intervals because it is too expensive (O(n^3)), but if we do not do it here, we get some actually implied elements being not leq, failing verifying*) let rec refine_intervals_until_fixpoint t = @@ -986,13 +986,13 @@ struct | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); (*transform the inequalities to represent only representants, and make the inequalities for new representants explicit*) - let transform_non_representant var rhs ineq_acc = + let transform_non_representant get_value var rhs ineq_acc = match rhs with - | (Some (c,v), o, d) when v <> var -> let ineq', _ = Ineq.substitute ineq_acc var (c,v,o,d) in ineq' + | (Some (c,v), o, d) when v <> var -> let ineq', _ = Ineq.substitute get_value ineq_acc var (c,v,o,d) in ineq' | _ -> ineq_acc in - let ineq_x_split = IntMap.fold (transform_non_representant) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' ineq_x in - let ineq_y_split = IntMap.fold (transform_non_representant) (snd econj'') @@ Ineq.copy_to_new_representants econ_y econj'' ineq_y in + let ineq_x_split = IntMap.fold (transform_non_representant (EConjI.get_value x)) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' (EConjI.get_value x) ineq_x in + let ineq_y_split = IntMap.fold (transform_non_representant (EConjI.get_value y)) (snd econj'') @@ Ineq.copy_to_new_representants econ_y econj'' (EConjI.get_value y) ineq_y in let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split (EConjI.get_value x) ineq_y_split (EConjI.get_value y) in let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in Some (e,v, Ineq.limit e i) diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 227e03af61..46c01904d1 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -315,6 +315,7 @@ end module Value = IntervalAndCongruence +(*The type used for the simulated domain*) module Relation = struct type cond = Lt | Gt type t = cond * Z.t @@ -380,7 +381,7 @@ module type TwoVarInequalities = sig val meet_relation : int -> int -> Relation.t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> t * Refinement.t (*substitutes all occurences of a variable by a rhs*) - val substitute : t -> int -> Z.t * int * Z.t * Z.t -> t * Refinement.t + val substitute : (int -> Value.t) -> t -> int -> Z.t * int * Z.t * Z.t -> t * Refinement.t (*called after every operation to limit the inequalities to the most relevant*) val limit : EConj.t -> t -> t @@ -394,7 +395,7 @@ module type TwoVarInequalities = sig val widen : t -> (int -> Value.t) -> t -> (int -> Value.t) -> t (*second loop of transform: e.g. a join can split groups of variables. This function copies the relevant inequalities to all new representants*) - val copy_to_new_representants : EConj.t -> EConj.t -> t -> t + val copy_to_new_representants : EConj.t -> EConj.t -> (int -> Value.t) -> t -> t (*restore inequalities after an assignment that makes the assigned-to variable have a known relation to before the assignment*) val transfer : int -> Relation.t -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t -> (int -> Rhs.t) -> (int -> Value.t) -> t * Refinement.t @@ -439,9 +440,9 @@ module NoInequalties : TwoVarInequalities = struct let modify_variables_in_domain _ _ _ = () let forget_variable _ _ = () - let substitute _ _ _ = (), [] + let substitute _ _ _ _ = (), [] - let copy_to_new_representants _ _ _ = () + let copy_to_new_representants _ _ _ _ = () let transfer _ _ _ _ _ _ _ _ = (), [] @@ -453,333 +454,6 @@ module NoInequalties : TwoVarInequalities = struct end -module type Coeffs = sig - type t - val implies : Value.t -> Value.t -> t option -> t -> bool - val meet : (int * Value.t) -> (int * Value.t) -> t -> t -> Refinement.t -> t * Refinement.t - val narrow : (int * Value.t) -> (int * Value.t) -> t -> t -> Refinement.t -> t * Refinement.t - - val join : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option - val widen : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option - - val hash : t -> int - val equal : t -> t -> bool - val compare : t -> t -> int - val show_formatted : string -> string -> t -> string - - val interval_refinements : (int * Value.t) -> (int * Value.t) -> t -> Refinement.t -> Refinement.t - - val set_constant_lhs : int -> Z.t -> t -> Refinement.t -> Refinement.t - val set_constant_rhs : int -> Z.t -> t -> Refinement.t -> Refinement.t - - val invariant : Environment.t -> int -> int -> t -> Lincons1.t list -> Lincons1.t list -end - -module CommonActions (Coeffs : Coeffs) = struct - - type t = Coeffs.t IntMap.t IntMap.t [@@deriving eq, ord ] - - let empty = IntMap.empty - let is_empty = IntMap.is_empty - let hash t = IntMap.fold (fun _ ys acc -> IntMap.fold (fun _ coeff acc -> Coeffs.hash coeff + 3*acc) ys (5*acc)) t 0 - - let ignore_empty ls = - if IntMap.is_empty ls then None - else Some ls - - let show_formatted formatter t = - if IntMap.is_empty t then "{}" else - if IntMap.exists (fun _ -> IntMap.is_empty) t then failwith "Map not sparse" else - let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (Coeffs.show_formatted (formatter x) (formatter y) coeff) acc) ys acc) t "" - in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" - - let show = show_formatted (Printf.sprintf "var_%d") - - let forget_variable t v = - IntMap.filter_map (fun _ ys -> let ys' = IntMap.remove v ys in if IntMap.is_empty ys' then None else Some ys') (IntMap.remove v t) - - let modify_variables_in_domain map indexes op = - let map_fun bump_var ys = IntMap.fold (fun y -> IntMap.add (bump_var y) ) ys IntMap.empty in - EConj.modify_variables_in_domain_general map map_fun indexes op - - let get_coeff x y t = BatOption.bind (IntMap.find_opt x t) (fun ys -> IntMap.find_opt y ys) - - let set_coeff x y coeff t = - IntMap.add x (IntMap.add y coeff @@ IntMap.find_default IntMap.empty x t ) t - - let remove_coeff x y t = - let new_map = IntMap.remove y @@ IntMap.find_default IntMap.empty x t in - if IntMap.is_empty new_map then t - else IntMap.add x new_map t - - let leq t1 get_value_t1 t2 = - let implies x y t2_coeff = - let t1_coeff = get_coeff x y t1 in - Coeffs.implies (get_value_t1 x) (get_value_t1 y) t1_coeff t2_coeff - in - IntMap.for_all (fun x ys -> IntMap.for_all (implies x) ys) t2 - - let meet_one_coeff narrow get_value x y coeff (t,ref_acc) = - let coeff_t = get_coeff x y t in - let coeff_met, ref_acc' = match coeff_t with - | None -> coeff, ref_acc (*also fine for narrow if t is the one on the righthandside*) - | Some coeff_t -> (if narrow then Coeffs.narrow else Coeffs.meet) (x, get_value x) (y, get_value y) coeff_t coeff ref_acc - in set_coeff x y coeff_met t, ref_acc' - - let meet get_value t1 t2 = - IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y coeff acc) ys acc) t1 (t2,[]) - - let narrow get_value t1 t2 = - IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t1 (t2,[]) - - let join' widen t1 get_val_t1 t2 get_val_t2 = - let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in - let merge_x x ys1 ys2 = - match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) - | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) - | _, _ -> None - in IntMap.merge (merge_x) t1 t2 - - let join = join' false - let widen = join' true - - let widen a b c d = - let res = widen a b c d in - if M.tracing then M.trace "widen" "called for inequalities"; - res - - let interval_refinements get_value t = IntMap.fold (fun x ys acc -> - IntMap.fold (fun y cs acc -> - Coeffs.interval_refinements - (x, get_value x) - (y, get_value y) - cs acc - ) ys acc - ) t [] - - let set_constant var const t = IntMap.fold (fun x ys (t_acc, ref_acc) -> - if x = var then - t_acc, IntMap.fold (fun y cs ref_acc -> Coeffs.set_constant_lhs y const cs ref_acc) ys ref_acc - else - match IntMap.find_opt var ys with - | None -> IntMap.add x ys t_acc, ref_acc - | Some cs -> - let ys' = IntMap.remove var ys in - let ref_acc = Coeffs.set_constant_rhs x const cs ref_acc in - if IntMap.is_empty ys' then t_acc, ref_acc else (IntMap.add x ys' t_acc, ref_acc) - ) t (IntMap.empty,[]) - - let invariant t env = IntMap.fold (fun x ys acc -> IntMap.fold (Coeffs.invariant env x) ys acc) t [] - -end - -(* TODO Redo this - - - (*Equations of the type x < y*) - module NoCoeffs = struct - type t = unit [@@deriving eq, ord, hash ] - - let implies x y t1_opt _ = match t1_opt with - | Some _ -> true - | None -> match Value.maximal x, Value.minimal y with - | Some x, Some y -> TopIntOps.compare x y < 0 - | _, _ -> false - - let meet x y _ _ = () - - let narrow = meet - - let join x y get_val_t1 get_val_t2 t1 t2 = - let of_bool b = if b then Some () else None in - match t1 with - | Some t1 -> of_bool (implies (get_val_t2 x) (get_val_t2 y) t2 t1) - | None -> match t2 with - | Some t2 -> of_bool (implies (get_val_t1 x) (get_val_t1 y) t1 t2) - | None -> None - - let widen = join - - let show_formatted x y t = x ^ " < " ^ y - - let add_constraints x y x_val y_val acc = - let acc = match Value.maximal y_val with - | Some (Int v) -> (x, Value.ending @@ Z.sub v Z.one) :: acc - | _ -> acc - in match Value.minimal x_val with - | Some (Int v) -> (y, Value.starting @@ Z.add v Z.one) :: acc - | _ -> acc - - end - - (*Semantics: x -> y -> () => x < y*) - module SimpleInequalities : TwoVarInequalities = struct - module Coeffs = NoCoeffs - include CommonActions(Coeffs) - - let get_relations x y t = - let open Relation in - let check_inequality ((var_x,o_x,d_x), val_x) ((var_y,o_y,d_y), val_y) = - if M.tracing then M.trace "get_relations" "checking x: %s, y: %s" (Rhs.show (var_x,o_x,d_x)) (Rhs.show (var_y,o_y,d_y)); - match var_x, var_y with - | Some (c_x, x), Some (c_y, y) -> begin - match get_coeff x y t with - | None -> - if M.tracing then M.trace "get_relations" "no inequality for roots"; - [] (*No information*) - | Some _ -> (*we know x < y -> check if this translates to x' < y' or x' > y'*) - let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in - let d_o = Z.sub (Z.mul o_x d_y) (Z.mul o_y d_x) in - let x_d_c = Value.mul val_x (Value.of_bigint d_c) in - if Z.lt c_y Z.zero && Value.leq x_d_c (Value.ending d_o) (* c_y < 0, x * d_c <= d_o*) - then[ (Gt, Z.zero)] (*x' > y '*) - else if Z.gt c_y Z.zero && Value.leq x_d_c (Value.starting d_o) (* c_y > 0, x * d_c >= d_o*) - then [(Lt, Z.zero)] (*x' < y '*) - else - let d_c' = Z.neg d_c in - let d_o' = Z.neg d_o in - let y_d_c = Value.mul val_y (Value.of_bigint d_c') in - if Z.lt c_x Z.zero && Value.leq y_d_c (Value.starting d_o') (* c_x < 0, y * d_c >= d_o*) - then [(Gt, Z.zero) ](*x' > y '*) - else if Z.gt c_x Z.zero && Value.leq y_d_c (Value.ending d_o') (* c_x > 0, y * d_c <= d_o*) - then [Lt, Z.zero] (*x' < y '*) - else [] - end - | _, _ -> failwith "Inequalities.get_relations does not take constants directly" (*TODO should we take the coefficients directly to enforce this*) - in - let res = check_inequality x y in - if res = [] then List.map invert @@ check_inequality y x - else res - - let get_relations x y t = - let res = get_relations x y t in - if M.tracing then M.trace "get_relations" "result: %s" (BatList.fold (fun acc c -> acc ^ ", " ^ Relation.show "x'" c "y'") "" res); - res - - let meet_relation x' y' cond get_rhs get_value t = - let open Relation in - (*strict: if the inequality is strict *) - let meet_less_root x y strict t = - if M.tracing then M.tracel "meet_relation" "meet_less_root x: %d y: %d strict: %b " x y strict; - let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) - in let union' = if strict then IntMap.add y () union else union - in if IntMap.mem x union' then raise EConj.Contradiction - else if IntMap.is_empty union' then t, [] - else IntMap.add x union' t, IntMap.fold (fun z _ acc -> Coeffs.add_constraints x z (get_value x) (get_value z) acc) union' [] - in - let meet_less x' y' strict t = - if M.tracing then M.tracel "meet_relation" "meet_less x': %d y': %d strict: %b" x' y' strict; - let get_rhs' lhs = - match get_rhs lhs with - | (Some (c,v),o,d) -> c,v,o,d - | (None, o, d) -> Z.one, lhs, Z.zero, Z.one - in let (c_x, x, o_x, d_x) = get_rhs' x' - in let (c_y, y, o_y, d_y) = get_rhs' y' - in if M.tracing then M.tracel "meet_relation" "x' = %s, y' = %s " (Rhs.show (Some (c_x, x),o_x,d_x)) (Rhs.show (Some (c_y,y),o_y,d_y)); - let val_x = get_value x - in let val_y = get_value y in - let d_c = Z.sub (Z.mul d_x c_y) (Z.mul d_y c_x) in - let d_o = Z.sub (Z.mul o_x d_y) (Z.mul o_y d_x) in - let x_d_c = Value.mul val_x (Value.of_bigint d_c) in - if Value.leq x_d_c (Value.ending d_o) then (*x * d_c <= d_o*) - (*We are strict iff we have been strict before or this bound is strict*) - if Z.lt c_y Z.zero then meet_less_root y x (strict || Value.leq x_d_c (Value.ending (Z.sub d_o Z.one))) t - else meet_less_root x y (strict || Value.leq x_d_c (Value.ending (Z.sub d_o Z.one))) t - else - let d_c' = Z.neg d_c in - let d_o' = Z.neg d_o in - let y_d_c = Value.mul val_y (Value.of_bigint d_c') in - if Value.leq y_d_c (Value.starting d_o') then (*x * d_c >= d_o*) - (*We are strict iff we have been strict before or this bound is strict*) - if Z.gt c_y Z.zero then meet_less_root x y (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t - else meet_less_root y x (strict || Value.leq y_d_c (Value.ending (Z.add d_o' Z.one))) t - else t, [] - in - match cond with - | Gt, z when Z.geq z Z.zero -> meet_less y' x' true t - | Gt, z when Z.equal z Z.minus_one -> meet_less y' x' false t - | Eq, z when Z.equal z Z.zero -> - let rhs_x = get_rhs x' in - let rhs_y = get_rhs y' in - if M.tracing then M.tracel "meet_relation" "in equality: x' (var_%d) = %s, y' (var_%d)= %s " x' (Rhs.show rhs_x) y' (Rhs.show rhs_y); - if Rhs.equal rhs_x rhs_y then begin - if M.tracing then M.tracel "meet_relation" "equality with same rhs"; - let x,y = match rhs_x, rhs_y with - | (Some (_,x), _,_), (Some (_,y), _,_) -> (x,y) - | (None,_,_), (None, _,_) -> x',y' - | _,_ -> failwith "Should never happen" - in - let union = IntMap.union (fun _ _ _ -> Some ()) (IntMap.find_default IntMap.empty x t) (IntMap.find_default IntMap.empty y t) in - if IntMap.mem x union || IntMap.mem y union then raise EConj.Contradiction - else if IntMap.is_empty union then t, [] - else IntMap.add x union @@ IntMap.add y union t, [] (*TODO more is possible for refinement, but is it worth it?*) - end else - let (t', acc) = meet_less y' x' false t in - let (t'', acc2) = meet_less x' y' false t' in - t'', acc @ acc2 - | Eq, z when Z.gt z Z.zero -> meet_less y' x' true t - | Eq, z when Z.lt z Z.zero -> meet_less x' y' true t - | Lt, z when Z.equal z Z.one -> meet_less x' y' false t - | Lt, z when Z.leq z Z.zero-> meet_less x' y' true t - | _ -> t, [] (*TODO adapt the equations to take care of offsets!*) - - let meet_relation x y c r v t = - if M.tracing then M.tracel "meet_relation" "meeting %s with %s" (show t) (Relation.show ("var_"^Int.to_string x) c ("var_"^Int.to_string y)); - let res, refinements = meet_relation x y c r v t in - if M.tracing then M.tracel "meet_relation" "result: %s " (show res); - res, refinements - - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - let get_old_condition x y = - let get_information lhs = - let rhs = get_rhs_old lhs in - match rhs with - | (Some (_,var), _ ,_) -> (rhs, get_value_old var) - (*We need to know which root a constant is referring to, so we use the trivial equation to carry that information*) - | (_,o,_) -> (Rhs.var_zero lhs, Value.of_bigint o) - in - get_relations (get_information x) (get_information y) t_old - in let vars_to_check = - let root = match get_rhs_old x with - | (Some (_,var), _ ,_) -> var - | (_,o,_) -> x - (*we need to check all y with root -> y -> coeff or y -> root -> coeff*) - in BatEnum.append (IntMap.keys @@ IntMap.find_default IntMap.empty root t_old) (List.enum @@ IntMap.fold (fun k ys acc -> if IntMap.mem root ys then k :: acc else acc) t_old []) - in let keep_less = match cond with - | Relation.Eq | Lt -> true - | _ -> false - in let keep_greater = match cond with - | Eq | Gt -> true - | _ -> false - in let transfer_single_var t' y = - match get_old_condition x y with - |[ (Lt, o)] -> (*transfering the variables does not lead to new information -> drop the refinements*) - if keep_less then fst @@ meet_relation x_new y (Lt, o) get_rhs get_value t' else t' - | [(Gt, o)] -> - if keep_greater then fst @@ meet_relation x_new y (Gt, o) get_rhs get_value t' else t' - | _ -> t' - in BatEnum.fold (transfer_single_var) t vars_to_check - - (*TODO we currently just strip the offset, but could take advantage of the offset*) - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - match cond with - | Relation.Eq, o when Z.equal o Z.zero -> transfer x x_new Eq t_old get_rhs_old get_value_old t get_rhs get_value - | Relation.Lt, o when Z.leq o Z.zero -> transfer x x_new Lt t_old get_rhs_old get_value_old t get_rhs get_value - | Relation.Gt, o when Z.geq o Z.zero -> transfer x x_new Gt t_old get_rhs_old get_value_old t get_rhs get_value - | _ -> t - - let transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value = - let res = transfer x x_new cond t_old get_rhs_old get_value_old t get_rhs get_value in - if M.tracing then M.tracel "transfer" "transfering with %s from %s into %s -> %s" (Relation.show (Int.to_string x) cond (Int.to_string x_new) ) (show t_old) (show t) (show res); - res - - end - -*) - - let qhash q = Z.hash (Q.num q) + 13 * Z.hash (Q.den q) let round_up q = Z.cdiv (Q.num q) (Q.den q) let round_down q = Z.fdiv (Q.num q) (Q.den q) @@ -1099,10 +773,9 @@ let slopes_from_coeffs mapping (x,y) = let slopes_from_coeffs = Timing.wrap "slopes" slopes_from_coeffs - (*List of inequalities ax < by + c, mapping a and b to c*) (*We need to make sure that x has lower index than y to keep this representation unique! *) -module ArbitraryCoeffsSet = struct +module TwoVarInequalitySet = struct module Key = LinearInequality.OriginInequality module CoeffMap = Map.Make(Key) @@ -1123,18 +796,24 @@ module ArbitraryCoeffsSet = struct (*limit how many inequalities we are saving: only keep inequalities with slopes that correspond to variables. optionally, limit it further to the slopes that correspond to the most inequalities *) let limit slopes t = + let opt = GobConfig.get_string "ana.lin2vareq_p.inequalities" in + if opt = "unlimited" then Some t else let open LinearInequality.OriginInequality in let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (get_slope k) ) t in - if true then (*TODO add option to configure this*) - filtered - else - let keep = 10 in (*TODO add option to configure this. there are possibly 2 inequalities per slope, so should be adjusted accordingly*) - let comp (k1,_) (k2,_) = - let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in - let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in - v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) - in - CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered + let keep = + if opt = "coeffs_count" then + GobConfig.get_int "ana.lin2vareq_p.coeffs_count" + else + let f = GobConfig.get_int "ana.lin2vareq_p.coeffs_threshold" in + let total = BatHashtbl.fold (fun _ c acc -> c + acc) slopes 0 in + (total * f) / 100 + in + let comp (k1,_) (k2,_) = + let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in + let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in + v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) + in + ignore_empty @@ CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered (*get the next key in anti-clockwise order*) let get_previous k t = @@ -1308,7 +987,6 @@ module ArbitraryCoeffsSet = struct end | _ -> (*add the inequality, while making sure that we do not save redundant inequalities*) - (*TODO make this consider the intervals! -> adapt get_next and get_previous?*) let t' = match CoeffMap.find_opt k t with | Some c_old when LinearInequality.entails1 (k,c_old) (k,c) -> t (*saved inequality is already thighter than new one*) | _ -> add_inequality k c @@ CoeffMap.remove k t (*we replace the current value with a new one *) @@ -1446,12 +1124,135 @@ module ArbitraryCoeffsSet = struct let invariant env x y t acc = CoeffMap.fold (LinearInequality.invariant env x y) t acc + let to_set t = t + + let of_set _ _ t = Some t + end +module TVIS = TwoVarInequalitySet + +module type Coeffs = sig + type t -module LinearInequalities : TwoVarInequalities = struct - module Coeffs = ArbitraryCoeffsSet - include CommonActions(Coeffs) + val join : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option + val widen : int -> int -> (int -> Value.t) -> (int -> Value.t) -> t option -> t option -> t option + + val limit : (Q.t, int) Hashtbl.t -> t -> t option + + val hash : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val show_formatted : string -> string -> t -> string + + val to_set : t -> TwoVarInequalitySet.t + + val of_set : Value.t -> Value.t -> TwoVarInequalitySet.t -> t option + +end + + +module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct + + type t = Coeffs.t IntMap.t IntMap.t [@@deriving eq, ord ] + + let empty = IntMap.empty + let is_empty = IntMap.is_empty + let hash t = IntMap.fold (fun _ ys acc -> IntMap.fold (fun _ coeff acc -> Coeffs.hash coeff + 3*acc) ys (5*acc)) t 0 + + let ignore_empty ls = + if IntMap.is_empty ls then None + else Some ls + + let show_map formatter elem_formatter t = + if IntMap.is_empty t then "{}" else + let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (elem_formatter (formatter x) (formatter y) coeff) acc) ys acc) t "" + in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" + + let show_formatted formatter t = show_map formatter Coeffs.show_formatted t + + let show = show_formatted (Printf.sprintf "var_%d") + + let forget_variable t v = + IntMap.filter_map (fun _ ys -> let ys' = IntMap.remove v ys in if IntMap.is_empty ys' then None else Some ys') (IntMap.remove v t) + + let modify_variables_in_domain map indexes op = + let map_fun bump_var ys = IntMap.fold (fun y -> IntMap.add (bump_var y) ) ys IntMap.empty in + EConj.modify_variables_in_domain_general map map_fun indexes op + + let get_coeff x y t = BatOption.bind (IntMap.find_opt x t) (fun ys -> IntMap.find_opt y ys) + + let set_coeff x y coeff t = + IntMap.add x (IntMap.add y coeff @@ IntMap.find_default IntMap.empty x t ) t + + let remove_coeff x y t = + let new_map = IntMap.remove y @@ IntMap.find_default IntMap.empty x t in + if IntMap.is_empty new_map then t + else IntMap.add x new_map t + + let leq t1 get_value_t1 t2 = + let implies x y t2_coeff = + let t1_coeff = get_coeff x y t1 in + TVIS.implies (get_value_t1 x) (get_value_t1 y) (BatOption.map Coeffs.to_set t1_coeff) (Coeffs.to_set t2_coeff) + in + IntMap.for_all (fun x ys -> IntMap.for_all (implies x) ys) t2 + + let meet_one_coeff narrow get_value x y coeff (t,ref_acc) = + let coeff_t = get_coeff x y t in + let coeff_met, ref_acc' = match coeff_t with + | None -> coeff, ref_acc (*also fine for narrow if t is the one on the righthandside*) + | Some coeff_t -> (if narrow then TVIS.narrow else TVIS.meet) (x, get_value x) (y, get_value y) (Coeffs.to_set coeff_t) coeff ref_acc + in match (Coeffs.of_set (get_value x) (get_value y)) coeff_met with + | None -> remove_coeff x y t, ref_acc' + | Some coeff_met -> set_coeff x y coeff_met t, ref_acc' + + let meet get_value t1 t2 = + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y (Coeffs.to_set coeff) acc) ys acc) t1 (t2,[]) + + let narrow get_value t1 t2 = + IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y (Coeffs.to_set coeff) acc) ys acc) t1 (t2,[]) + + let join' widen t1 get_val_t1 t2 get_val_t2 = + let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in + let merge_x x ys1 ys2 = + match ys1, ys2 with + | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) + | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) + | _, _ -> None + in IntMap.merge (merge_x) t1 t2 + + let join = join' false + let widen = join' true + + let widen a b c d = + let res = widen a b c d in + if M.tracing then M.trace "widen" "called for inequalities"; + res + + let interval_refinements get_value t = IntMap.fold (fun x ys acc -> + IntMap.fold (fun y cs acc -> + TVIS.interval_refinements + (x, get_value x) + (y, get_value y) + (Coeffs.to_set cs) + acc + ) ys acc + ) t [] + + let set_constant var const t = IntMap.fold (fun x ys (t_acc, ref_acc) -> + if x = var then + t_acc, IntMap.fold (fun y cs ref_acc -> TVIS.set_constant_lhs y const (Coeffs.to_set cs) ref_acc) ys ref_acc + else + match IntMap.find_opt var ys with + | None -> IntMap.add x ys t_acc, ref_acc + | Some cs -> + let ys' = IntMap.remove var ys in + let ref_acc = TVIS.set_constant_rhs x const (Coeffs.to_set cs) ref_acc in + if IntMap.is_empty ys' then t_acc, ref_acc else (IntMap.add x ys' t_acc, ref_acc) + ) t (IntMap.empty,[]) + + let invariant t env = IntMap.fold (fun x ys acc -> IntMap.fold (fun y cs acc -> TVIS.invariant env x y (Coeffs.to_set cs) acc) ys acc) t [] let ignore_empty ls = if IntMap.is_empty ls then None @@ -1466,20 +1267,21 @@ module LinearInequalities : TwoVarInequalities = struct match get_coeff x y t with | None -> begin if M.tracing then M.trace "get_relations" "no inequality for roots"; [] end (*No information*) | Some coeff -> + let coeff = Coeffs.to_set coeff in let interval_ineqs = LinearInequality.from_values x_val y_val in - let coeff = List.fold (fun t (k,c) -> Coeffs.add_inequality k c t) coeff interval_ineqs in + let coeff = List.fold (fun t (k,c) -> TVIS.add_inequality k c t) coeff interval_ineqs in let (k,c_rhs) = LinearInequality.from_rhss (c_x,o_x,d_x) (c_y,o_y,d_y) None in let factor = (*we need to muliply c' with this factor because LinearInequalities scales them down*) let a = Q.make c_x d_x in let b = Q.make c_y d_y in if Q.equal b Q.zero then a else b in - let upper_bound = match Coeffs.get_best_offset k coeff with + let upper_bound = match TVIS.get_best_offset k coeff with | None -> [] | Some c_ineq -> let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) - in match Coeffs.get_best_offset (Coeffs.Key.negate k) coeff with (*lower bound*) + in match TVIS.get_best_offset (TVIS.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> let c' = Q.mul factor ( Q.add c_ineq c_rhs) in @@ -1499,7 +1301,7 @@ module LinearInequalities : TwoVarInequalities = struct else begin if M.tracing then M.tracel "meet_relation" "meet_relation_roots: %s" @@ LinearInequality.show ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string y) (k,c); if x = y then - let s = Coeffs.Key.get_slope k in + let s = TVIS.Key.get_slope k in if Q.equal Q.one s then (* x <= x + c (or >=) *) match k with | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else (t, []) (*trivially true*) @@ -1516,12 +1318,12 @@ module LinearInequalities : TwoVarInequalities = struct t, (x, Left (Value.starting @@ Z.fdiv (Q.num min) (Q.den min))) :: ref_acc else let coeffs = match get_coeff x y t with - | None -> Coeffs.empty - | Some c -> c - in let coeffs', ref_acc = Coeffs.meet_single_inequality (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in - if Coeffs.CoeffMap.is_empty coeffs' - then remove_coeff x y t , ref_acc - else set_coeff x y coeffs' t, ref_acc + | None -> TVIS.empty + | Some c -> Coeffs.to_set c + in let coeffs', ref_acc = TVIS.meet_single_inequality (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) + in match Coeffs.of_set (get_value x) (get_value y) coeffs' with + | None -> remove_coeff x y t , ref_acc + | Some c -> set_coeff x y c t, ref_acc end in let apply_transivity x y k c t = if x = y then begin @@ -1532,42 +1334,42 @@ module LinearInequalities : TwoVarInequalities = struct IntMap.fold (fun w zs acc -> if w = x then IntMap.fold (fun z cs acc -> - match Coeffs.combine_left (k,c) cs with + match TVIS.combine_left (k,c) @@ Coeffs.to_set cs with | None -> if M.tracing then M.tracel "transitivity" "case 1, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 1, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string y) ("var_" ^ Int.to_string z) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots y z k c acc) cs' acc + if M.tracing then M.tracel "transitivity" "case 1, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (TVIS.show_formatted ("var_" ^ Int.to_string y) ("var_" ^ Int.to_string z) cs'); + TVIS.CoeffMap.fold (fun k c acc -> meet_relation_roots y z k c acc) cs' acc ) zs acc else if w = y then IntMap.fold (fun z cs acc -> - match Coeffs.combine_left (LinearInequality.swap_sides (k,c)) cs with + match TVIS.combine_left (LinearInequality.swap_sides (k,c)) @@ Coeffs.to_set cs with | None -> if M.tracing then M.tracel "transitivity" "case 2, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 2, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string z) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots x z k c acc) cs' acc + if M.tracing then M.tracel "transitivity" "case 2, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (TVIS.show_formatted ("var_" ^ Int.to_string x) ("var_" ^ Int.to_string z) cs'); + TVIS.CoeffMap.fold (fun k c acc -> meet_relation_roots x z k c acc) cs' acc ) zs acc else IntMap.fold (fun z cs acc -> if z = x then - match Coeffs.combine_right (k,c) cs with + match TVIS.combine_right (k,c) @@ Coeffs.to_set cs with | None -> if M.tracing then M.tracel "transitivity" "case 3, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 3, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string y) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w y k c acc) cs' acc + if M.tracing then M.tracel "transitivity" "case 3, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (TVIS.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string y) cs'); + TVIS.CoeffMap.fold (fun k c acc -> meet_relation_roots w y k c acc) cs' acc else if z = y then - match Coeffs.combine_right (LinearInequality.swap_sides (k,c)) cs with + match TVIS.combine_right (LinearInequality.swap_sides (k,c)) @@ Coeffs.to_set cs with | None -> if M.tracing then M.tracel "transitivity" "case 4, combined with %s into Nothing " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs); acc | Some cs' -> - if M.tracing then M.tracel "transitivity" "case 4, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string x) cs'); - Coeffs.CoeffMap.fold (fun k c acc -> meet_relation_roots w x k c acc) cs' acc + if M.tracing then M.tracel "transitivity" "case 4, combined with %s into %s " (Coeffs.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string z) cs) (TVIS.show_formatted ("var_" ^ Int.to_string w) ("var_" ^ Int.to_string x) cs'); + TVIS.CoeffMap.fold (fun k c acc -> meet_relation_roots w x k c acc) cs' acc else acc ) zs acc @@ -1586,7 +1388,7 @@ module LinearInequalities : TwoVarInequalities = struct let t, ref_acc = apply_transivity x y k c' t in meet_relation_roots x y k c' (t, ref_acc) | Gt, o -> - let k = Coeffs.Key.negate k in + let k = TVIS.Key.negate k in let c' = (Q.add c @@ Q.div (Q.of_bigint o) factor) in let t, ref_acc = apply_transivity x y k c' t in meet_relation_roots x y k c' (t,ref_acc) @@ -1608,11 +1410,13 @@ module LinearInequalities : TwoVarInequalities = struct if M.tracing then M.tracel "meet_relation" "result: %s, refinements: %s " (show res) (Refinement.show refine_acc); res, refine_acc - let substitute t i (coeff, j, offs, divi) = + (*We want to be lazy and only convert to TVIS if necessary. To be able to reuse this function in transfer, + we also need to be able to work with an already converted Map -> add functions for conversion*) + let substitute' t i (coeff, j, offs, divi) to_set of_set = (*if both sides refer to the same variable: check for contradictions or refine the value*) let constraints_same_variable cs = let check_single k c value = - let s = Coeffs.Key.get_slope k in + let s = TVIS.Key.get_slope k in if Q.equal Q.one s then (* x <= x + c (or >=) *) match k with | LE _ -> if Q.lt c Q.zero then raise EConj.Contradiction else value (*trivially true*) @@ -1627,23 +1431,26 @@ module LinearInequalities : TwoVarInequalities = struct else let min = Q.div c' s' in Value.meet value @@ Value.starting @@ Z.fdiv (Q.num min) (Q.den min) - in Coeffs.CoeffMap.fold check_single cs Value.top + in TVIS.CoeffMap.fold check_single cs Value.top in (*add to bindings, meeting with existing if necessary*) let merge_single x y cs_new (t,ref_acc) = - let cs_curr = BatOption.default Coeffs.empty @@ get_coeff x y t in - let cs_combined, ref_acc = Coeffs.meet (x,Value.top) (y,Value.top) cs_new cs_curr ref_acc in - if Coeffs.CoeffMap.is_empty cs_combined then t,ref_acc else set_coeff x y cs_combined t, ref_acc + let cs_curr = BatOption.default TVIS.empty @@ BatOption.map to_set @@ get_coeff x y t in + let cs_combined, ref_acc = TVIS.meet (x,Value.top) (y,Value.top) cs_new cs_curr ref_acc in + match of_set x y cs_combined with + | None -> t,ref_acc + | Some cs_combined -> set_coeff x y cs_combined t, ref_acc in let merge_ys x ys acc = IntMap.fold (merge_single x) ys acc in let fold_x x ys acc = if x < i then match IntMap.find_opt i ys with - | None -> merge_ys x ys acc + | None -> merge_ys x (IntMap.map to_set ys) acc | Some cs -> + let cs = to_set cs in let ys' = IntMap.remove i ys in - let acc' = merge_ys x ys' acc in (*everything else is added unchanged*) - let cs' = Coeffs.substitute_right (coeff, offs, divi) cs in + let acc' = merge_ys x (IntMap.map to_set ys') acc in (*everything else is added unchanged*) + let cs' = TVIS.substitute_right (coeff, offs, divi) cs in if x = j then (*We now have inequalities with the same variable on both sides *) let t,ref_acc = acc' in let v = constraints_same_variable cs' in @@ -1651,11 +1458,11 @@ module LinearInequalities : TwoVarInequalities = struct else if x < j then merge_single x j cs' acc' else (*x > j -> swap sides*) - let cs'' = Coeffs.swap_sides cs' in + let cs'' = TVIS.swap_sides cs' in merge_single j x cs'' acc' else if x = i then let fold_y y cs acc = - let cs' = Coeffs.substitute_left (coeff, offs, divi) cs in + let cs' = TVIS.substitute_left (coeff, offs, divi) cs in if j < y then merge_single j y cs' acc else if j = y then begin @@ -1663,17 +1470,17 @@ module LinearInequalities : TwoVarInequalities = struct let v = constraints_same_variable cs' in t, Refinement.of_value x v :: ref_acc end else - let cs'' = Coeffs.swap_sides cs' in + let cs'' = TVIS.swap_sides cs' in merge_single y j cs'' acc in - IntMap.fold fold_y ys acc + IntMap.fold fold_y (IntMap.map to_set ys) acc else - merge_ys x ys acc + merge_ys x (IntMap.map to_set ys) acc in IntMap.fold fold_x t (IntMap.empty, []) - let substitute t i (c,j,o,d) = + let substitute get_value t i (c,j,o,d) = if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s" i (show t) (Rhs.show (Some (c,j), o, d)); - let t, ref_acc = substitute t i (c,j,o,d) in + let t, ref_acc = substitute' t i (c,j,o,d) Coeffs.to_set (fun x y s -> Coeffs.of_set (get_value x) (get_value y) s) in if M.tracing then M.trace "substitute" "resulting in %s, refinements: %s" (show t) (Refinement.show ref_acc); t, ref_acc @@ -1685,27 +1492,27 @@ module LinearInequalities : TwoVarInequalities = struct in let factor = Q.make coeff_old divi_old (*we need to divide o by this factor because LinearInequalities normalizes*) in let ineq_from_cond = match cond with | Relation.Lt, o -> k, (Q.add c @@ Q. div (Q.of_bigint o) factor) - | Gt, o -> (Coeffs.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) + | Gt, o -> (TVIS.Key.negate k), (Q.add c @@ Q. div (Q.of_bigint o) factor) in (*combine the inequality from cond with all inequalities*) (*throw out all inequalities that do not contain the representative of x*) let combine_1 v1 v2s = - if v1 = x_root_old then ignore_empty @@ IntMap.filter_map (fun _ c -> Coeffs.combine_left ineq_from_cond c) v2s + if v1 = x_root_old then ignore_empty @@ IntMap.filter_map (fun _ c -> TVIS.combine_left ineq_from_cond @@ Coeffs.to_set c) v2s else - let combine_2 v2 c = if v2 = x_root_old then Coeffs.combine_right ineq_from_cond c else None in + let combine_2 v2 c = if v2 = x_root_old then TVIS.combine_right ineq_from_cond @@ Coeffs.to_set c else None in ignore_empty @@ IntMap.filter_map combine_2 v2s in let filtered = IntMap.filter_map combine_1 t_old in - if M.tracing then M.tracel "transfer" "filtered + combined %s" (show filtered); + if M.tracing then M.tracel "transfer" "filtered + combined %s" (show_map (Printf.sprintf "var_%d") TVIS.show_formatted filtered); (*transform all inequalities to refer to new root of x*) (*invert old rhs, then substitute the new rhs for x*) let (m, o, d) = Rhs.subst rhs x @@ snd @@ EConj.inverse x (coeff_old,x_root_old, off_old, divi_old) in let c, v = BatOption.get m in - let transformed, ref_acc = substitute filtered x_root (c, v, o, d) in - if M.tracing then M.tracel "transfer" "transformed: %s, refinements: %s" (show transformed) (Refinement.show ref_acc); + let transformed, ref_acc = substitute' filtered x_root (c, v, o, d) identity (fun _ _ c -> TVIS.ignore_empty c) in + if M.tracing then M.tracel "transfer" "transformed: %s, refinements: %s" (show_map (Printf.sprintf "var_%d") TVIS.show_formatted transformed) (Refinement.show ref_acc); (*meet with this set of equations*) - let t', ref_acc_2 = meet get_value t transformed in - t', ref_acc @ ref_acc_2 + let meet' t1 t2 = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y coeff acc) ys acc) t1 (t2,ref_acc) in + meet' transformed t | _,_ -> t, [] (*ignore constants*) let transfer x cond t_old get_rhs_old get_value_old t get_rhs get_value = @@ -1719,11 +1526,11 @@ module LinearInequalities : TwoVarInequalities = struct let coeffs = coeffs_from_econj econj in let limit_single x y cs = Coeffs.limit ( slopes_from_coeffs coeffs (min x y, max x y)) cs - in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> Coeffs.ignore_empty @@ limit_single x y cs) ys) t + in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> limit_single x y cs) ys) t let limit e t = Timing.wrap "limit" (limit e) t - let copy_to_new_representants econj_old econj_new t = + let copy_to_new_representants econj_old econj_new get_value t = let coeffs = coeffs_from_econj econj_new in (*a var is representant if it does not show up in the sparse map*) let all_representants_in_new = @@ -1759,45 +1566,166 @@ module LinearInequalities : TwoVarInequalities = struct let ineq' = if old_rep < other_var then LinearInequality.swap_sides ineq else ineq in LinearInequality.substitute_right (ci,oi,di) ineq' (*relations between the old representant and the other variable*) - in let coeffs_old = BatOption.default Coeffs.empty @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in + in let coeffs_old = BatOption.default TVIS.empty @@ BatOption.map Coeffs.to_set @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in let add_single_slope c_acc s = let ineqs = [LinearInequality.OriginInequality.LE s, Q.zero; GE s, Q.zero;] in let copy_single_ineq c_acc ineq = let k_old = fst @@ convert_to_old ineq in (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) - match Coeffs.get_best_offset k_old coeffs_old with + match TVIS.get_best_offset k_old coeffs_old with | None -> c_acc | Some o -> let k_neq, o_new = convert_to_new (k_old, o) in - Coeffs.add_inequality k_neq o_new c_acc + TVIS.add_inequality k_neq o_new c_acc in List.fold copy_single_ineq c_acc ineqs - in let coeffs_new = Enum.fold add_single_slope Coeffs.empty allowed_slopes - in if Coeffs.CoeffMap.is_empty coeffs_new then t_acc else set_coeff (min v_new other_var) (max v_new other_var) coeffs_new t_acc + in let coeffs_new = Enum.fold add_single_slope TVIS.empty allowed_slopes + in let x, y = min v_new other_var , max v_new other_var + in match Coeffs.of_set (get_value x) (get_value y) coeffs_new with + | Some coeffs_new -> set_coeff x y coeffs_new t_acc + | _ -> t_acc in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new let copy_to_new_representants econj_old econj_new t = Timing.wrap "new_reps" (copy_to_new_representants econj_old econj_new) t end +module PentagonCoeffs : Coeffs = struct + (*true -> x < y *) + (*false -> x > y *) + type t = bool [@@deriving eq, hash, ord] + + let join x y get_val_t1 get_val_t2 t1 t2 = + match t1, t2 with + | None, None -> None + | Some d1, Some d2 -> if d1 = d2 then Some d1 else None + | Some true, None -> if Value.must_be_neg @@ Value.sub (get_val_t2 x) (get_val_t2 y) then Some true else None + | Some false, None -> if Value.must_be_pos @@ Value.sub (get_val_t2 x) (get_val_t2 y) then Some false else None + | None, Some true -> if Value.must_be_neg @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some true else None + | None, Some false -> if Value.must_be_neg @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some false else None + + let widen x y get_val_t1 get_val_t2 t1 t2 = t2 + + let limit _ t = Some t + + let show_formatted x y t = x ^ (if t then "<" else ">") ^ y + + let to_set t = + let open LinearInequality.OriginInequality in + let i = if t then LE Q.one else GE Q.one in + (*x < y <==> x <= y - 1*) + let o = if t then Q.minus_one else Q.one in + TVIS.CoeffMap.singleton i o + + let to_set = Timing.wrap "to_set" to_set + + let of_set x_val y_val s = + let open LinearInequality.OriginInequality in + let s' = List.fold (fun t (k,c) -> TVIS.add_inequality k c t) s @@ LinearInequality.from_values x_val y_val in + match TVIS.get_best_offset (LE Q.one) s' with + | Some c when Q.(<=) c Q.minus_one -> Some true + | _ -> match TVIS.get_best_offset (GE Q.one) s' with + | Some c when Q.(>=) c Q.one -> Some false + | _ -> None + + let of_set x_val y_val = Timing.wrap "of_set" (of_set x_val y_val) + +end + +module PentagonOffsetCoeffs : Coeffs = struct + (*x <= y + c, x >= y + c, None = Top *) + type t = Z.t option * Z.t option [@@deriving eq, hash, ord] + + let flatten (u,l) = if u = None && l = None then None else Some (u,l) + + let join x y get_val_t1 get_val_t2 t1 t2 = + let l_of_values get_values = + let diff = Value.sub (get_values x) (get_values y) in + match Value.maximal diff with + | Some (Int i) -> Some i + | _ -> None + in + let u_of_values get_values = + let diff = Value.sub (get_values x) (get_values y) in + match Value.minimal diff with + | Some (Int i) -> Some i + | _ -> None + in + let open BatOption in + let lift2 f a b = bind a (fun a -> bind b (fun b -> Some (f a b))) in + match t1, t2 with + | None, None -> None + | None, Some (u,l) -> + let u = lift2 max u @@ u_of_values get_val_t1 in + let l = lift2 min l @@ l_of_values get_val_t1 in + flatten (u,l) + | Some (u,l), None -> + let u = lift2 max u @@ u_of_values get_val_t2 in + let l = lift2 min l @@ l_of_values get_val_t2 in + flatten (u,l) + | Some (u1,l1), Some (u2,l2) -> + let u1 = lift2 max u1 @@ u_of_values get_val_t1 in + let l1 = lift2 min l2 @@ l_of_values get_val_t1 in + let u2 = lift2 max u2 @@ u_of_values get_val_t2 in + let l2 = lift2 min l2 @@ l_of_values get_val_t2 in + let u = lift2 max u1 u2 in + let l = lift2 min l1 l2 in + flatten (u,l) + + let widen x y get_val_t1 get_val_t2 t1 t2 = + match t1, t2 with + | None, None + | None, Some _ + | Some _, None -> None + | Some (u1,l1), Some (u2,l2) -> + let l = if l1 = l2 then l2 else None in + let u = if u1 = u2 then u2 else None in + flatten (u,l) + + let limit _ t = Some t + + let show_formatted x y (u,l) = + let u = match u with + | None -> "" + | Some u -> x ^ " <= " ^ y ^ " + " ^ Z.to_string u + in let l = match l with + | None -> "" + | Some l -> x ^ " >= " ^ y ^ " + " ^ Z.to_string l + in u ^ " , " ^ l + + let to_set (u,l) = + let open LinearInequality.OriginInequality in + let s = TVIS.empty in + let s = match u with + | None -> s + | Some u -> TVIS.add_inequality (LE Q.one) (Q.of_bigint u) s + in + match l with + | None -> s + | Some l -> TVIS.add_inequality (GE Q.one) (Q.of_bigint l) s + + let to_set = Timing.wrap "to_set" to_set + + let of_set x_val y_val s = + let open LinearInequality.OriginInequality in + let s' = List.fold (fun t (k,c) -> TVIS.add_inequality k c t) s @@ LinearInequality.from_values x_val y_val in + let u = BatOption.map round_down @@ TVIS.get_best_offset (LE Q.one) s' in + let l = BatOption.map round_up @@ TVIS.get_best_offset (GE Q.one) s' in + flatten (u,l) + + let of_set x_val y_val = Timing.wrap "of_set" (of_set x_val y_val) + +end + (*TODOs:*) (*!! options for limit function*) (*!! fix cohencu tests*) -(*++ redo simple equalities (take advantage of the offset!, affine transform)*) - -(*++ ArbitraryCoeaffsList meet_single: take intervals into account better - re-add them every time, remove them afterwards? -*) - -(*+ value refinement after every step?? *) (*+ look at complexities. I expect for all: (n² log n) not leq because of interval fixpoint!!!*) (*+ How to do a useful narrow?*) -(* domain inbetween these two: with offset between roots? -> should be trivial to implement*) - (* widening thresholds: from offsets of rhs?*) (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) @@ -1809,6 +1737,4 @@ end (*--memo_bumbvar created 3 times*) (*--eval_int: answer nonlinear*) -(*! general renaming*) -(*!!rebase to main branch*) -(*!!documentation (failing check!!) *) \ No newline at end of file +(*! general renaming*) \ No newline at end of file diff --git a/src/config/options.schema.json b/src/config/options.schema.json index d4193e3d46..ddbb0042aa 100644 --- a/src/config/options.schema.json +++ b/src/config/options.schema.json @@ -580,7 +580,13 @@ "termination", "tmpSpecialAnalysis" ] - } + }, + "extraTerminationDomain": { + "title": "ana.autotune.extraTerminationDomain", + "description": "Domain activated by the 'termination' autotuner. Specifying 'apron' also selects the polyhedra domain", + "type": "string", + "default": "apron" + } }, "additionalProperties": false }, @@ -1031,10 +1037,29 @@ }, "lin2vareq_p": { "title": "ana.lin2vareq_p", - "description": - "Use inequalities", - "type": "boolean", - "default": true + "type": "object", + "properties": { + "inequalities": { + "title": "ana.lin2vareq_p.inequalities", + "description": "Which domain to use to detect inequalities", + "type": "string", + "enum": ["none","pentagon", "pentagon_offset", "coeffs_count", "coeffs_threshold", "unlimited"], + "default": "coeffs_threshold" + }, + "coeffs_count": { + "title": "ana.lin2vareq_p.coeffs_count", + "description": "How many inequalities to keep for every representant pair when using coeffs_count. ", + "type": "integer", + "default": 14 + }, + "coeffs_threshold": { + "title": "ana.lin2vareq_p.coeffs_threshold", + "description": "Percentage of inequalities to keep for every representant pair when using coeffs_threshold. Larger connected groups are allowed more coefficients.", + "type": "integer", + "default": 100 + } + }, + "additionalProperties": false }, "context": { "title": "ana.context", From 567301b69f9ae68cb4b94818bc9cc128f8541eea Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 20 Jun 2025 00:27:17 +0200 Subject: [PATCH 73/86] forgot staging formatting --- .../apron/representantDomains.apron.ml | 62 +++++++++---------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 46c01904d1..3346d3c64c 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -798,22 +798,22 @@ module TwoVarInequalitySet = struct let limit slopes t = let opt = GobConfig.get_string "ana.lin2vareq_p.inequalities" in if opt = "unlimited" then Some t else - let open LinearInequality.OriginInequality in - let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (get_slope k) ) t in - let keep = - if opt = "coeffs_count" then - GobConfig.get_int "ana.lin2vareq_p.coeffs_count" - else - let f = GobConfig.get_int "ana.lin2vareq_p.coeffs_threshold" in - let total = BatHashtbl.fold (fun _ c acc -> c + acc) slopes 0 in - (total * f) / 100 - in - let comp (k1,_) (k2,_) = - let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in - let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in - v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) - in - ignore_empty @@ CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered + let open LinearInequality.OriginInequality in + let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (get_slope k) ) t in + let keep = + if opt = "coeffs_count" then + GobConfig.get_int "ana.lin2vareq_p.coeffs_count" + else + let f = GobConfig.get_int "ana.lin2vareq_p.coeffs_threshold" in + let total = BatHashtbl.fold (fun _ c acc -> c + acc) slopes 0 in + (total * f) / 100 + in + let comp (k1,_) (k2,_) = + let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in + let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in + v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) + in + ignore_empty @@ CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered (*get the next key in anti-clockwise order*) let get_previous k t = @@ -1166,8 +1166,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let show_map formatter elem_formatter t = if IntMap.is_empty t then "{}" else - let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (elem_formatter (formatter x) (formatter y) coeff) acc) ys acc) t "" - in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" + let str = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> Printf.sprintf "%s , %s" (elem_formatter (formatter x) (formatter y) coeff) acc) ys acc) t "" + in "{" ^ String.sub str 0 (String.length str - 3) ^ "}" let show_formatted formatter t = show_map formatter Coeffs.show_formatted t @@ -1203,8 +1203,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct | None -> coeff, ref_acc (*also fine for narrow if t is the one on the righthandside*) | Some coeff_t -> (if narrow then TVIS.narrow else TVIS.meet) (x, get_value x) (y, get_value y) (Coeffs.to_set coeff_t) coeff ref_acc in match (Coeffs.of_set (get_value x) (get_value y)) coeff_met with - | None -> remove_coeff x y t, ref_acc' - | Some coeff_met -> set_coeff x y coeff_met t, ref_acc' + | None -> remove_coeff x y t, ref_acc' + | Some coeff_met -> set_coeff x y coeff_met t, ref_acc' let meet get_value t1 t2 = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff false get_value x y (Coeffs.to_set coeff) acc) ys acc) t1 (t2,[]) @@ -1322,8 +1322,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct | Some c -> Coeffs.to_set c in let coeffs', ref_acc = TVIS.meet_single_inequality (x,get_value x) (y,get_value y) k c (coeffs,ref_acc) in match Coeffs.of_set (get_value x) (get_value y) coeffs' with - | None -> remove_coeff x y t , ref_acc - | Some c -> set_coeff x y c t, ref_acc + | None -> remove_coeff x y t , ref_acc + | Some c -> set_coeff x y c t, ref_acc end in let apply_transivity x y k c t = if x = y then begin @@ -1438,8 +1438,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let cs_curr = BatOption.default TVIS.empty @@ BatOption.map to_set @@ get_coeff x y t in let cs_combined, ref_acc = TVIS.meet (x,Value.top) (y,Value.top) cs_new cs_curr ref_acc in match of_set x y cs_combined with - | None -> t,ref_acc - | Some cs_combined -> set_coeff x y cs_combined t, ref_acc + | None -> t,ref_acc + | Some cs_combined -> set_coeff x y cs_combined t, ref_acc in let merge_ys x ys acc = IntMap.fold (merge_single x) ys acc in let fold_x x ys acc = @@ -1581,8 +1581,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct in let coeffs_new = Enum.fold add_single_slope TVIS.empty allowed_slopes in let x, y = min v_new other_var , max v_new other_var in match Coeffs.of_set (get_value x) (get_value y) coeffs_new with - | Some coeffs_new -> set_coeff x y coeffs_new t_acc - | _ -> t_acc + | Some coeffs_new -> set_coeff x y coeffs_new t_acc + | _ -> t_acc in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new let copy_to_new_representants econj_old econj_new t = Timing.wrap "new_reps" (copy_to_new_representants econj_old econj_new) t @@ -1604,7 +1604,7 @@ module PentagonCoeffs : Coeffs = struct | None, Some false -> if Value.must_be_neg @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some false else None let widen x y get_val_t1 get_val_t2 t1 t2 = t2 - + let limit _ t = Some t let show_formatted x y t = x ^ (if t then "<" else ">") ^ y @@ -1685,11 +1685,11 @@ module PentagonOffsetCoeffs : Coeffs = struct let show_formatted x y (u,l) = let u = match u with - | None -> "" - | Some u -> x ^ " <= " ^ y ^ " + " ^ Z.to_string u + | None -> "" + | Some u -> x ^ " <= " ^ y ^ " + " ^ Z.to_string u in let l = match l with - | None -> "" - | Some l -> x ^ " >= " ^ y ^ " + " ^ Z.to_string l + | None -> "" + | Some l -> x ^ " >= " ^ y ^ " + " ^ Z.to_string l in u ^ " , " ^ l let to_set (u,l) = From 287a6eb287a9d64060a5a87f65f52ffad707415d Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 23 Jun 2025 16:00:57 +0200 Subject: [PATCH 74/86] keep map properly sparse, small fixes --- conf/svcomp25_testing.json | 7 +- conf/svcomp25_testing2.json | 119 ------------------ .../apron/representantDomains.apron.ml | 23 ++-- 3 files changed, 16 insertions(+), 133 deletions(-) delete mode 100644 conf/svcomp25_testing2.json diff --git a/conf/svcomp25_testing.json b/conf/svcomp25_testing.json index 51402ffaf6..dd1f60db68 100644 --- a/conf/svcomp25_testing.json +++ b/conf/svcomp25_testing.json @@ -62,7 +62,7 @@ "autotune": { "enabled": false, "activated": [ - "singleThreaded", + "reduceAnalysess", "mallocWrappers", "noRecursiveIntervals", "enums", @@ -94,11 +94,6 @@ } }, "witness": { - "graphml": { - "enabled": true, - "id": "enumerate", - "unknown": false - }, "yaml": { "enabled": true, "format-version": "2.0", diff --git a/conf/svcomp25_testing2.json b/conf/svcomp25_testing2.json deleted file mode 100644 index d7d6cec70e..0000000000 --- a/conf/svcomp25_testing2.json +++ /dev/null @@ -1,119 +0,0 @@ -{ - "ana": { - "sv-comp": { - "enabled": true, - "functions": true - }, - "int": { - "def_exc": true, - "enums": false, - "interval": true - }, - "float": { - "interval": true, - "evaluate_math_functions": true - }, - "activated": [ - "base", - "threadid", - "threadflag", - "threadreturn", - "mallocWrapper", - "mutexEvents", - "mutex", - "access", - "race", - "escape", - "expRelation", - "mhp", - "assert", - "var_eq", - "symb_locks", - "region", - "thread", - "threadJoins", - "abortUnless", - "lin2vareq" - ], - "path_sens": [ - "mutex", - "malloc_null", - "uninit", - "expsplit", - "activeSetjmp", - "memLeak", - "threadflag" - ], - "context": { - "widen": false - }, - "base": { - "arrays": { - "domain": "partitioned" - } - }, - "race": { - "free": false, - "call": false - }, - "autotune": { - "enabled": false, - "activated": [ - "singleThreaded", - "mallocWrappers", - "noRecursiveIntervals", - "enums", - "congruence", - "octagon", - "wideningThresholds", - "loopUnrollHeuristic", - "memsafetySpecification", - "noOverflows", - "termination", - "tmpSpecialAnalysis" - ] - } - }, - "exp": { - "region-offsets": true - }, - "solver": "td3", - "sem": { - "unknown_function": { - "spawn": false - }, - "int": { - "signed_overflow": "assume_none" - }, - "null-pointer": { - "dereference": "assume_none" - } - }, - "witness": { - "graphml": { - "enabled": true, - "id": "enumerate", - "unknown": false - }, - "yaml": { - "enabled": true, - "format-version": "2.0", - "entry-types": [ - "invariant_set" - ], - "invariant-types": [ - "loop_invariant" - ] - }, - "invariant": { - "loop-head": true, - "after-lock": false, - "other": false, - "accessed": false, - "exact": true - } - }, - "pre": { - "enabled": false - } -} diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 3346d3c64c..8d512cad60 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -797,23 +797,27 @@ module TwoVarInequalitySet = struct optionally, limit it further to the slopes that correspond to the most inequalities *) let limit slopes t = let opt = GobConfig.get_string "ana.lin2vareq_p.inequalities" in - if opt = "unlimited" then Some t else + if opt = "unlimited" then ignore_empty t else let open LinearInequality.OriginInequality in let filtered = CoeffMap.filter (fun k c -> BatHashtbl.mem slopes (get_slope k) ) t in let keep = if opt = "coeffs_count" then - GobConfig.get_int "ana.lin2vareq_p.coeffs_count" + GobConfig.get_int "ana.lin2vareq_p.coeffs_count" (*TODO for a fixed number, we do not need to sort but could instead use an O(n algorithm!)*) else let f = GobConfig.get_int "ana.lin2vareq_p.coeffs_threshold" in let total = BatHashtbl.fold (fun _ c acc -> c + acc) slopes 0 in - (total * f) / 100 + max 4 @@ (total * f) / 100 (*allow a minimum of 4 inequality angles *) in let comp (k1,_) (k2,_) = let v1 = BatHashtbl.find_default slopes (get_slope k1) 0 in let v2 = BatHashtbl.find_default slopes (get_slope k2) 0 in v2 - v1 (*list sorts ascending, we need descending -> inverted comparison*) in - ignore_empty @@ CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered + (*skip sorting if we keep all inequalities*) + if keep >= CoeffMap.cardinal filtered then + ignore_empty filtered + else + ignore_empty @@ CoeffMap.of_list @@ List.take keep @@ List.sort comp @@ CoeffMap.bindings filtered (*get the next key in anti-clockwise order*) let get_previous k t = @@ -1126,7 +1130,7 @@ module TwoVarInequalitySet = struct let to_set t = t - let of_set _ _ t = Some t + let of_set _ _ t = ignore_empty t end @@ -1640,13 +1644,13 @@ module PentagonOffsetCoeffs : Coeffs = struct let join x y get_val_t1 get_val_t2 t1 t2 = let l_of_values get_values = let diff = Value.sub (get_values x) (get_values y) in - match Value.maximal diff with + match Value.minimal diff with | Some (Int i) -> Some i | _ -> None in let u_of_values get_values = let diff = Value.sub (get_values x) (get_values y) in - match Value.minimal diff with + match Value.maximal diff with | Some (Int i) -> Some i | _ -> None in @@ -1663,6 +1667,9 @@ module PentagonOffsetCoeffs : Coeffs = struct let l = lift2 min l @@ l_of_values get_val_t2 in flatten (u,l) | Some (u1,l1), Some (u2,l2) -> + (*TODO is this needed for monotonicity? + like this, we have a problem: we rely on value bounds + that might not hold in the joined case -> leq fails *) let u1 = lift2 max u1 @@ u_of_values get_val_t1 in let l1 = lift2 min l2 @@ l_of_values get_val_t1 in let u2 = lift2 max u2 @@ u_of_values get_val_t2 in @@ -1718,7 +1725,7 @@ end (*TODOs:*) -(*!! options for limit function*) +(*?? limit: use linear time algorithm for coeffs_count instead of sorting??*) (*!! fix cohencu tests*) From 7ee3c88e749d630fdc9751e5edaaf774db119b6d Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 23 Jun 2025 16:10:17 +0200 Subject: [PATCH 75/86] use succ / pred --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 26 +++++++++---------- .../apron/representantDomains.apron.ml | 8 +++--- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 385dae8cca..6935b3916d 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -384,8 +384,8 @@ struct let v = Value.sub (EConjI.get_value d dim_a) (EConjI.get_value d dim_b) in let relations = EConjI.get_relations d dim_a dim_b in let meet_relation v = function - | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.sub o Z.one - | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.add o Z.one + | Relation.Lt, o -> Value.meet v @@ Value.ending @@ Z.pred o + | Relation.Gt, o -> Value.meet v @@ Value.starting @@ Z.succ o in List.fold meet_relation v relations end | Binop (op, a, b, Int, _) -> (binop_function op) (eval a) (eval b) @@ -494,9 +494,9 @@ struct let v = eval_texpr t expr in (*TODO we evaluate some subexpressions twice when calling this in assign_texpr -> bad for performance??*) match Value.minimal v, Value.maximal v with | Some (Int min), Some (Int maxi) when min = maxi -> [] (*Should be caught by the lin2var domain -> do not repeat that information*) - | Some (Int min), Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one min), var; (Relation.Lt, Z.add Z.one maxi), var] - | Some (Int min), _ -> [(Relation.Gt, Z.add Z.minus_one min), var] - | _,Some (Int maxi) -> [(Relation.Lt, Z.add Z.one maxi), var] + | Some (Int min), Some (Int maxi) -> [(Relation.Gt, Z.pred min), var; (Relation.Lt, Z.succ maxi), var] + | Some (Int min), _ -> [(Relation.Gt, Z.pred min), var] + | _,Some (Int maxi) -> [(Relation.Lt, Z.succ maxi), var] | _,_ -> [] in let inequality_from_mul var expr = let v_expr = eval_texpr t expr in @@ -522,9 +522,9 @@ struct let v = eval_texpr t e in begin match Value.minimal v, Value.maximal v with | Some (Int min), Some (Int maxi) when min = maxi -> [] (*Should be caught by the lin2var domain -> do not repeat that information*) - | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y; (Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] - | Some (Int min), _ -> [(Relation.Lt, Z.add Z.one @@ Z.neg min), y] - | _,Some (Int maxi) -> [(Relation.Gt, Z.add Z.minus_one @@ Z.neg maxi), y] + | Some (Int min), Some (Int maxi) -> [(Relation.Lt, Z.succ @@ Z.neg min), y; (Relation.Gt, Z.pred @@ Z.neg maxi), y] + | Some (Int min), _ -> [(Relation.Lt, Z.succ @@ Z.neg min), y] + | _,Some (Int maxi) -> [(Relation.Gt, Z.pred @@ Z.neg maxi), y] | _,_ -> [] end | Binop (Div, Var y, e, _, _) -> begin @@ -686,9 +686,9 @@ struct match Value.to_int value with | Some (Int v) -> let old_value = (EConjI.get_value d dim) in if Value.minimal old_value = Some (Int v) then - EConjI.meet_with_one_value dim (Value.starting @@ Z.add v Z.one) d false + EConjI.meet_with_one_value dim (Value.starting @@ Z.succ v) d false else if Value.maximal old_value = Some (Int v) then - EConjI.meet_with_one_value dim (Value.ending @@ Z.sub v Z.one) d false + EConjI.meet_with_one_value dim (Value.ending @@ Z.pred v) d false else d | _-> d end else ( @@ -798,14 +798,14 @@ struct if M.tracing then M.tracel "meet_relation" "calling from refine with %s inside %s" (Tcons1.show tcons) (EConjI.show d); let ineq', value_refinements = match Value.minimal value, Value.maximal value, Tcons1.get_typ tcons with | _, Some (Int max), SUP -> Ineq.meet_relation dim_b dim_a (Relation.Lt, max) rhss vss ineq - | _, Some (Int max), SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq + | _, Some (Int max), SUPEQ -> Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.succ max) rhss vss ineq | Some min, Some max, EQ -> begin if TopIntOps.equal min max then ineq, [] else (*If this is a constant, we have a equality that the lin2vareq domain should handle*) let ineq, refine = match min with - | Int min -> Ineq.meet_relation dim_b dim_a (Relation.Gt, Z.sub min Z.one) rhss vss ineq + | Int min -> Ineq.meet_relation dim_b dim_a (Relation.Gt, Z.pred min) rhss vss ineq | _ -> ineq, [] in match max with - | Int max -> BatTuple.Tuple2.map2 ((@) refine) @@ Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.add Z.one max) rhss vss ineq + | Int max -> BatTuple.Tuple2.map2 ((@) refine) @@ Ineq.meet_relation dim_b dim_a (Relation.Lt, Z.succ max) rhss vss ineq | _ -> ineq, refine end | _, _,_ -> ineq, [] diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 8d512cad60..a0a8a4c36b 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -334,8 +334,8 @@ module Relation = struct (*Tries to combine two relations, with the variable on the rhs of the first condition being equal to the one at the lhs of the second*) let combine (c1, o1) (c2, o2) = match c1, c2 with - | Lt, Lt -> Some ( Lt, Z.add o1 @@ Z.add o2 Z.one ) - | Gt, Gt -> Some ( Gt, Z.add o1 @@ Z.add o2 Z.one ) + | Lt, Lt -> Some ( Lt, Z.add o1 @@ Z.succ o2 ) + | Gt, Gt -> Some ( Gt, Z.add o1 @@ Z.succ o2 ) | Lt, Gt | Gt, Lt -> None @@ -1284,12 +1284,12 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct | None -> [] | Some c_ineq -> let c' = Q.mul factor @@ Q.sub c_ineq c_rhs in - [Relation.Lt, Z.add Z.one @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) + [Relation.Lt, Z.succ @@ Z.fdiv (Q.num c') (Q.den c')] (*add one to make it a strict inequality*) in match TVIS.get_best_offset (TVIS.Key.negate k) coeff with (*lower bound*) | None -> upper_bound | Some c_ineq -> let c' = Q.mul factor ( Q.add c_ineq c_rhs) in - (Gt, Z.add Z.minus_one @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound + (Gt, Z.pred @@ Z.cdiv (Q.num c') (Q.den c')) :: upper_bound end let get_relations x y t = From 1cc06dcde23c4d1ce77f57c3d42c7ebd8a93dc45 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Mon, 23 Jun 2025 16:49:05 +0200 Subject: [PATCH 76/86] delete configuration for testing --- conf/svcomp25_testing.json | 118 ------------------------------------- 1 file changed, 118 deletions(-) delete mode 100644 conf/svcomp25_testing.json diff --git a/conf/svcomp25_testing.json b/conf/svcomp25_testing.json deleted file mode 100644 index dd1f60db68..0000000000 --- a/conf/svcomp25_testing.json +++ /dev/null @@ -1,118 +0,0 @@ -{ - "ana": { - "sv-comp": { - "enabled": true, - "functions": true - }, - "int": { - "def_exc": true, - "enums": false, - "interval": true - }, - "float": { - "interval": true, - "evaluate_math_functions": true - }, - "activated": [ - "base", - "threadid", - "threadflag", - "threadreturn", - "mallocWrapper", - "mutexEvents", - "mutex", - "access", - "race", - "escape", - "expRelation", - "mhp", - "assert", - "var_eq", - "symb_locks", - "region", - "thread", - "threadJoins", - "abortUnless", - "lin2vareq_p" - ], - "path_sens": [ - "mutex", - "malloc_null", - "uninit", - "expsplit", - "activeSetjmp", - "memLeak", - "threadflag" - ], - "context": { - "widen": false - }, - "base": { - "arrays": { - "domain": "partitioned" - } - }, - "race": { - "free": false, - "call": false - }, - "lin2vareq_p": { - "inequalities" : "coeffs_threshold" - }, - "autotune": { - "enabled": false, - "activated": [ - "reduceAnalysess", - "mallocWrappers", - "noRecursiveIntervals", - "enums", - "congruence", - "octagon", - "wideningThresholds", - "loopUnrollHeuristic", - "memsafetySpecification", - "noOverflows", - "termination", - "tmpSpecialAnalysis" - ], - "extraTerminationDomain": "lin2vareq_p" - } - }, - "exp": { - "region-offsets": true - }, - "solver": "td3", - "sem": { - "unknown_function": { - "spawn": false - }, - "int": { - "signed_overflow": "assume_none" - }, - "null-pointer": { - "dereference": "assume_none" - } - }, - "witness": { - "yaml": { - "enabled": true, - "format-version": "2.0", - "entry-types": [ - "invariant_set" - ], - "invariant-types": [ - "loop_invariant" - ] - }, - "invariant": { - "loop-head": true, - "after-lock": false, - "other": false, - "accessed": false, - "exact": true - } - }, - "pre": { - "enabled": false - } -} From 8ce2066380a4109174e1e219e8bebc12777dcd46 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 24 Jun 2025 17:33:22 +0200 Subject: [PATCH 77/86] small fixes, remove asserts for performance --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 4 +- .../apron/representantDomains.apron.ml | 112 ++++++++++-------- 2 files changed, 63 insertions(+), 53 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 6935b3916d..9da8f1da22 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -1022,8 +1022,8 @@ struct let join a b = let res = join a b in if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; - assert(leq a res); - assert(leq b res); + (*assert(leq a res); + assert(leq b res);*) res let widen = join' true diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index a0a8a4c36b..a0b37a53fb 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -472,6 +472,7 @@ module LinearInequality = struct (*We want the inequalities to be ordered by angle (with arbitrary start point and direction), which is tan(slope) (+ pi for other direction) *) + (*TODO: this is called very often -> performance optimisation?*) let compare t1 t2 = let classify t = let a,b = match t with @@ -1226,6 +1227,12 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct | _, _ -> None in IntMap.merge (merge_x) t1 t2 + let join' widen t1 get_val_t1 t2 get_val_t2 = + let res = join' widen t1 get_val_t1 t2 get_val_t2 in + if M.tracing then M.trace "join'" "a: %s b: %s -> %s" (show t1) (show t2) (show res); + res + + let join = join' false let widen = join' true @@ -1527,10 +1534,12 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct res, ref_acc let limit econj t = - let coeffs = coeffs_from_econj econj in - let limit_single x y cs = - Coeffs.limit ( slopes_from_coeffs coeffs (min x y, max x y)) cs - in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> limit_single x y cs) ys) t + let conf = GobConfig.get_string "ana.lin2vareq_p.inequalities" in + if conf <> "coeffs_count" && conf <> "coeffs_threshold" then t else + let coeffs = coeffs_from_econj econj in + let limit_single x y cs = + Coeffs.limit ( slopes_from_coeffs coeffs (min x y, max x y)) cs + in IntMap.filter_map (fun x ys -> ignore_empty @@ IntMap.filter_map (fun y cs -> limit_single x y cs) ys) t let limit e t = Timing.wrap "limit" (limit e) t @@ -1544,49 +1553,53 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct else aux (n :: acc) (n + 1) in aux [] 0 in let new_representants_in_new = List.filter (fun v -> IntMap.mem v (snd econj_old)) all_representants_in_new - in let add_new v_new t_acc other_var = - (*get the old rhs*) - match IntMap.find v_new (snd econj_old) with - | None,_,_ -> t_acc (*skip constants*) - | (Some (c,old_rep), o, d) -> - let allowed_slopes = Hashtbl.keys @@ slopes_from_coeffs coeffs (min v_new other_var, max v_new other_var) in - (*inverse rhs so that we can translate the inequalities of the old representant to slopes corresponding to the new representant*) - let (_, (mi,oi,di)) = EConj.inverse v_new (c,old_rep,o,d) in - let ci,_ = BatOption.get mi in - (*convert the slope from new representant to old*) - let convert_to_old ineq = - if v_new < other_var then - LinearInequality.substitute_left (c,o,d) ineq - else - let ineq' = LinearInequality.substitute_right (c,o,d) ineq in - if old_rep < other_var then - LinearInequality.swap_sides ineq' - else ineq' - (*convert back*) - in let convert_to_new ineq = - if v_new < other_var then - LinearInequality.substitute_left (ci,oi,di) ineq - else - let ineq' = if old_rep < other_var then LinearInequality.swap_sides ineq else ineq - in LinearInequality.substitute_right (ci,oi,di) ineq' - (*relations between the old representant and the other variable*) - in let coeffs_old = BatOption.default TVIS.empty @@ BatOption.map Coeffs.to_set @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in - let add_single_slope c_acc s = - let ineqs = [LinearInequality.OriginInequality.LE s, Q.zero; GE s, Q.zero;] - in let copy_single_ineq c_acc ineq = - let k_old = fst @@ convert_to_old ineq in - (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) - match TVIS.get_best_offset k_old coeffs_old with - | None -> c_acc - | Some o -> - let k_neq, o_new = convert_to_new (k_old, o) in - TVIS.add_inequality k_neq o_new c_acc - in List.fold copy_single_ineq c_acc ineqs - in let coeffs_new = Enum.fold add_single_slope TVIS.empty allowed_slopes - in let x, y = min v_new other_var , max v_new other_var - in match Coeffs.of_set (get_value x) (get_value y) coeffs_new with - | Some coeffs_new -> set_coeff x y coeffs_new t_acc - | _ -> t_acc + in if M.tracing then M.trace "new_reps" "all_in_new: %s, new_in_new: %s" (List.fold (fun a i -> Int.to_string i ^ ", " ^ a) "" all_representants_in_new) (List.fold (fun a i -> Int.to_string i ^ ", " ^ a) "" new_representants_in_new); + let add_new v_new t_acc other_var = + if v_new = other_var then t_acc else + (*get the old rhs*) + match IntMap.find v_new (snd econj_old) with + | None,_,_ -> t_acc (*skip constants*) + | (Some (c,old_rep), o, d) -> + let allowed_slopes = Hashtbl.keys @@ slopes_from_coeffs coeffs (min v_new other_var, max v_new other_var) in + (*inverse rhs so that we can translate the inequalities of the old representant to slopes corresponding to the new representant*) + let (_, (mi,oi,di)) = EConj.inverse v_new (c,old_rep,o,d) in + let ci,_ = BatOption.get mi in + (*convert the slope from new representant to old*) + let convert_to_old ineq = + if v_new < other_var then + LinearInequality.substitute_left (c,o,d) ineq + else + let ineq' = LinearInequality.substitute_right (c,o,d) ineq in + if old_rep < other_var then + LinearInequality.swap_sides ineq' + else ineq' + (*convert back*) + in let convert_to_new ineq = + if v_new < other_var then + LinearInequality.substitute_left (ci,oi,di) ineq + else + let ineq' = if old_rep < other_var then LinearInequality.swap_sides ineq else ineq + in LinearInequality.substitute_right (ci,oi,di) ineq' + (*relations between the old representant and the other variable*) + in let coeffs_old = BatOption.default TVIS.empty @@ BatOption.map Coeffs.to_set @@ get_coeff (min old_rep other_var) (max old_rep other_var) t in + if M.tracing then M.trace "new_reps" "coeffs_old for old %d other %d new %d: %s" old_rep other_var v_new (TVIS.show_formatted "min" "max" coeffs_old); + if TVIS.CoeffMap.is_empty coeffs_old then t_acc else (*skip the rest if there is no need *) + let add_single_slope c_acc s = + let ineqs = [LinearInequality.OriginInequality.LE s, Q.zero; GE s, Q.zero;] + in let copy_single_ineq c_acc ineq = + let k_old = fst @@ convert_to_old ineq in + (*TODO maybe this introduces too many new inequalities -> only take explicit stored ones?*) + match TVIS.get_best_offset k_old coeffs_old with + | None -> c_acc + | Some o -> + let k_neq, o_new = convert_to_new (k_old, o) in + TVIS.add_inequality k_neq o_new c_acc + in List.fold copy_single_ineq c_acc ineqs + in let coeffs_new = Enum.fold add_single_slope TVIS.empty allowed_slopes + in let x, y = min v_new other_var , max v_new other_var + in match Coeffs.of_set (get_value x) (get_value y) coeffs_new with + | Some coeffs_new -> set_coeff x y coeffs_new t_acc + | _ -> t_acc in List.fold (fun acc v_new -> List.fold (add_new v_new ) acc all_representants_in_new ) t new_representants_in_new let copy_to_new_representants econj_old econj_new t = Timing.wrap "new_reps" (copy_to_new_representants econj_old econj_new) t @@ -1605,7 +1618,7 @@ module PentagonCoeffs : Coeffs = struct | Some true, None -> if Value.must_be_neg @@ Value.sub (get_val_t2 x) (get_val_t2 y) then Some true else None | Some false, None -> if Value.must_be_pos @@ Value.sub (get_val_t2 x) (get_val_t2 y) then Some false else None | None, Some true -> if Value.must_be_neg @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some true else None - | None, Some false -> if Value.must_be_neg @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some false else None + | None, Some false -> if Value.must_be_pos @@ Value.sub (get_val_t1 x) (get_val_t1 y) then Some false else None let widen x y get_val_t1 get_val_t2 t1 t2 = t2 @@ -1667,9 +1680,6 @@ module PentagonOffsetCoeffs : Coeffs = struct let l = lift2 min l @@ l_of_values get_val_t2 in flatten (u,l) | Some (u1,l1), Some (u2,l2) -> - (*TODO is this needed for monotonicity? - like this, we have a problem: we rely on value bounds - that might not hold in the joined case -> leq fails *) let u1 = lift2 max u1 @@ u_of_values get_val_t1 in let l1 = lift2 min l2 @@ l_of_values get_val_t1 in let u2 = lift2 max u2 @@ u_of_values get_val_t2 in From d626bbd7f55d9840b044941140cf6a945497bb3c Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 24 Jun 2025 23:14:59 +0200 Subject: [PATCH 78/86] fixed bug in join --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 9da8f1da22..dd2877d7ac 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -985,6 +985,7 @@ struct None -> None | Some econj'' -> if M.tracing then M.tracel "join" "join_econj of %s, %s resulted in %s" (EConjI.show x) (EConjI.show y) (EConj.show @@ snd econj''); + let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq_x) in (*ineq_x doesn't matter*) (*transform the inequalities to represent only representants, and make the inequalities for new representants explicit*) let transform_non_representant get_value var rhs ineq_acc = match rhs with @@ -993,9 +994,9 @@ struct in let ineq_x_split = IntMap.fold (transform_non_representant (EConjI.get_value x)) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' (EConjI.get_value x) ineq_x in let ineq_y_split = IntMap.fold (transform_non_representant (EConjI.get_value y)) (snd econj'') @@ Ineq.copy_to_new_representants econ_y econj'' (EConjI.get_value y) ineq_y in - let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split (EConjI.get_value x) ineq_y_split (EConjI.get_value y) in - let (e,v,i) = collect_values x y econj'' ((Environment.size env)-1) (econj'', IntMap.empty, ineq') in - Some (e,v, Ineq.limit e i) + let get_value = (EConjI.get_value (e,v,i)) in + let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split get_value ineq_y_split get_value in + Some (e,v, Ineq.limit e ineq') in (*This is a different kind of bot that we need to catch*) if is_bot a then b else From ec41fb5034f0940194ab218901ae27de21e470cf Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sun, 29 Jun 2025 19:31:31 +0200 Subject: [PATCH 79/86] revert last commit and include actual fix --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 3 +- .../apron/representantDomains.apron.ml | 38 ++++++++++++------- 2 files changed, 26 insertions(+), 15 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index dd2877d7ac..a204affa73 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -994,8 +994,7 @@ struct in let ineq_x_split = IntMap.fold (transform_non_representant (EConjI.get_value x)) (snd econj'') @@ Ineq.copy_to_new_representants econ_x econj'' (EConjI.get_value x) ineq_x in let ineq_y_split = IntMap.fold (transform_non_representant (EConjI.get_value y)) (snd econj'') @@ Ineq.copy_to_new_representants econ_y econj'' (EConjI.get_value y) ineq_y in - let get_value = (EConjI.get_value (e,v,i)) in - let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split get_value ineq_y_split get_value in + let ineq' = (if widen then Ineq.widen else Ineq.join) ineq_x_split (EConjI.get_value x) ineq_y_split (EConjI.get_value y) in Some (e,v, Ineq.limit e ineq') in (*This is a different kind of bot that we need to catch*) diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index a0b37a53fb..e4374cd5f2 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -1680,14 +1680,35 @@ module PentagonOffsetCoeffs : Coeffs = struct let l = lift2 min l @@ l_of_values get_val_t2 in flatten (u,l) | Some (u1,l1), Some (u2,l2) -> - let u1 = lift2 max u1 @@ u_of_values get_val_t1 in - let l1 = lift2 min l2 @@ l_of_values get_val_t1 in - let u2 = lift2 max u2 @@ u_of_values get_val_t2 in - let l2 = lift2 min l2 @@ l_of_values get_val_t2 in + let u1 = lift2 min u1 @@ u_of_values get_val_t1 in + let u2 = lift2 min u2 @@ u_of_values get_val_t2 in let u = lift2 max u1 u2 in + let l1 = lift2 max l1 @@ l_of_values get_val_t1 in + let l2 = lift2 max l2 @@ l_of_values get_val_t2 in let l = lift2 min l1 l2 in flatten (u,l) + let show_formatted x y (u,l) = + let u = match u with + | None -> "" + | Some u -> x ^ " <= " ^ y ^ " + " ^ Z.to_string u + in let l = match l with + | None -> "" + | Some l -> x ^ " >= " ^ y ^ " + " ^ Z.to_string l + in u ^ " , " ^ l + + let join x y get_val_t1 get_val_t2 t1 t2 = + let res = join x y get_val_t1 get_val_t2 t1 t2 in + if M.tracing then M.trace "joinc" "\na: %s, x=%s,y=%s\nb: %s, x=%s,y=%s\n -> %s" + (BatOption.map_default (show_formatted "x" "y") "None" t1) + (Value.show @@ get_val_t1 x) + (Value.show @@ get_val_t1 y) + (BatOption.map_default (show_formatted "x" "y") "None" t2) + (Value.show @@ get_val_t2 x) + (Value.show @@ get_val_t2 y) + (BatOption.map_default (show_formatted "x" "y") "None" res); + res + let widen x y get_val_t1 get_val_t2 t1 t2 = match t1, t2 with | None, None @@ -1700,15 +1721,6 @@ module PentagonOffsetCoeffs : Coeffs = struct let limit _ t = Some t - let show_formatted x y (u,l) = - let u = match u with - | None -> "" - | Some u -> x ^ " <= " ^ y ^ " + " ^ Z.to_string u - in let l = match l with - | None -> "" - | Some l -> x ^ " >= " ^ y ^ " + " ^ Z.to_string l - in u ^ " , " ^ l - let to_set (u,l) = let open LinearInequality.OriginInequality in let s = TVIS.empty in From 67f4207081d7c02317165d63d2cc4ab857c1a825 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Wed, 2 Jul 2025 15:17:49 +0200 Subject: [PATCH 80/86] Fix wrong results and other bugs, remove unused top function --- src/analyses/apron/relationAnalysis.apron.ml | 16 ++++++------ .../value/cdomains/int/intervalDomain.ml | 1 - ...inearTwoVarEqualityDomainPentagon.apron.ml | 25 +++++++++++-------- 3 files changed, 24 insertions(+), 18 deletions(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index 1de345dff0..a524011129 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -468,11 +468,11 @@ struct let reachables (ask: Queries.ask) es = let reachable acc e = Option.bind acc (fun st -> - let ad = ask.f (Queries.ReachableFrom e) in - if Queries.AD.is_top ad then - None - else - Some (Queries.AD.join ad st)) + let ad = ask.f (Queries.ReachableFrom e) in + if Queries.AD.is_top ad then + None + else + Some (Queries.AD.join ad st)) in List.fold_left reachable (Some (Queries.AD.empty ())) es @@ -538,8 +538,8 @@ struct Priv.thread_join ~force:true ask man.global id st | Rand, _ -> Option.map_default (fun lv -> - let st = invalidate_one ask man st lv in - assert_fn {man with local = st} (BinOp (Ge, Lval lv, zero, intType)) true + let st = invalidate_one ask man st lv in + assert_fn {man with local = st} (BinOp (Ge, Lval lv, zero, intType)) true ) st r | _, _ -> let lvallist e = @@ -763,6 +763,8 @@ struct if M.tracing then M.traceu "apron" "unassume join"; M.info ~category:Witness "relation unassumed invariant: %a" d_exp e_orig; st + | Events.Longjmped {lval} -> + Option.map_default (invalidate_one ask man st) st lval | _ -> st diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml index aa0968d792..c3120dd537 100644 --- a/src/cdomain/value/cdomains/int/intervalDomain.ml +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -74,7 +74,6 @@ struct let norm = Ints_t.norm let bot_of = Ints_t.bot_of - let top () = failwith @@ "top () not implemented for " ^ (name ()) let bot () = None let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index a204affa73..b89c666d8a 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -572,7 +572,7 @@ struct let assign_const t var const divi = match t.d with | None -> t - | Some t_d -> {d = Some (EConjI.set_rhs t_d var (None, const, divi)); env = t.env} + | Some t_d -> {d = Some (EConjI.set_rhs t_d var @@ Rhs.canonicalize (None, const, divi)); env = t.env} end @@ -732,7 +732,8 @@ struct else if is_neg then Value.meet (Value.ending Z.zero) full else full in let d' = refine_values d (Value.add b_c rem) a in - refine_values d' (Value.div (Value.sub a_val rem) value) b + if Value.contains value Z.zero then d' else (*do not divide by zero for our refinements*) + refine_values d' (Value.div (Value.sub a_val rem) value) b | Mod -> (* a' = a/b*b + c and derived from it b' = (a-c)/(a/b) * The idea is to formulate a' as quotient * divisor + remainder. *) @@ -743,7 +744,8 @@ struct d end else let a' = Value.add (Value.mul (Value.div a_val b_val) b_val) value in - let b' = Value.div (Value.sub a_val value) (Value.div a_val value) in + let a_c = (Value.div a_val value) in + let b' = Value.div (Value.sub a_val value) a_c in (* However, for [2,4]%2 == 1 this only gives [3,4]. * If the upper bound of a is divisible by b, we can also meet with the result of a/b*b - c to get the precise [3,3]. * If b is negative we have to look at the lower bound. *) @@ -771,7 +773,7 @@ struct Value.meet a'' t | _, _ -> a'' in - let d' = refine_values d (b') b in + let d' = if Value.contains b' Z.zero || Value.contains a_c Z.zero then d else refine_values d (b') b in refine_values d' (a''') a | Pow -> failwith "refine_with tcons: pow unsupported" end @@ -1114,11 +1116,13 @@ struct -> Convert.texpr1_expr_of_cil_exp handles overflow *) let assign_exp ask (t: VarManagement.t) var exp (no_ov: bool Lazy.t) = let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in - (*evaluate in the same way as is used for simplification*) let t = match Convert.texpr1_expr_of_cil_exp ask t t.env exp no_ov with - | texp -> assign_texpr t var texp false - | exception Convert.Unsupported_CilExp _ -> forget_var t var - in match t.d with + | texp -> if M.tracing then M.trace "assign_exp" "conversion success"; assign_texpr t var texp false + | exception Convert.Unsupported_CilExp _ -> if M.tracing then M.trace "assign_exp" "conversion failed"; forget_var t var + in + (*evaluate in the same way as is used for simplification*) + if M.tracing then M.trace "assign_exp" "assign_exp after EConjI + ineqs: %s" (show t); + match t.d with | None -> t | Some d -> if exp = MyCFG.unknown_exp then @@ -1129,7 +1133,7 @@ struct (GobRef.wrap AnalysisState.executing_speculative_computations true ( fun () -> let ikind = Cilfacade.get_ikind_exp exp in match ask.f (EvalInt exp) with - | `Bot -> IntDomain.IntDomTuple.bot_of ikind + | `Bot (* This happens when called on a pointer type; -> we can safely return top *) | `Top -> IntDomain.IntDomTuple.top_of ikind | `Lifted x -> if M.tracing then M.trace "assign_exp" "Query for %a returned %s" d_exp exp (IntDomain.IntDomTuple.show x); @@ -1137,8 +1141,9 @@ struct )) with Invalid_argument _ -> Value.top (*get_ikind_exp failed*) in + if M.tracing then M.trace "assign_exp" "value for %a set to %s" Var.pretty var (Value.show value); (*TODO If the newly assigned value must be greater / lower than the old, we can restore some conditions?*) - let d' = if Value.is_bot value then None + let d' = if Value.is_bot value then Some ((EConjI.make_empty_with_size (Environment.size t.env))) else Some (EConjI.set_value d (Environment.dim_of_var t.env var) value) in {d= d'; env = t.env} From d00764aeca62ff61f55234e9d22118da65363b89 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 5 Jul 2025 19:41:41 +0200 Subject: [PATCH 81/86] fixes: do not report overflow in conversions to base, nontermination when narrowing in combination with base. performance: do not allocate completely new data structure in substitute, separate inequality join from widen for shortcut. Cleanup some tracing, enable asserts for testing --- ...inearTwoVarEqualityDomainPentagon.apron.ml | 37 ++++----------- .../apron/representantDomains.apron.ml | 45 ++++++++++--------- 2 files changed, 32 insertions(+), 50 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index b89c666d8a..9176243132 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -70,11 +70,6 @@ struct | _, _ -> [] (*One of the variables is a constant -> there are no inequalities*) - let get_value t lhs = - let res = get_value t lhs in - if M.tracing then M.tracel "get_value" "reading var_%d from %s -> %s" lhs (show t) (Value.show res); - res - let constrain_with_congruence_from_rhs econ lhs i =(**TODO do not recalculate this every time?*) (*calculate the congruence constraint for x from a single equation (cx + o) / d *) let congruence_of_rhs (c, o, d) = @@ -110,12 +105,9 @@ struct let refine_depth = 5 let rec set_value ((econ, is, ineq) as t:t) lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_value var_%d=%s, before: %s" lhs (Value.show i) (show t); if Value.is_bot i then raise EConj.Contradiction; let set_value_for_root lhs i = - if M.tracing then M.tracel "modify_pentagon" "set_value_for_root var_%d=%s, before: %s" lhs (Value.show i) (show t); let i = constrain_with_congruence_from_rhs econ lhs i in - if M.tracing then M.tracel "modify_pentagon" "set_value_for_root refined to %s" (Value.show i); if i = Value.top then (econ, IntMap.remove lhs is, ineq) (*stay sparse*) else if Value.is_bot i then raise EConj.Contradiction else match Value.to_int i with @@ -135,7 +127,6 @@ struct let i2 = Value.sub i1 (Value.of_bigint o) in let i3 = Value.div i2 (Value.of_bigint coeff) in let i_transformed = i3 in - if M.tracing then M.tracel "modify_pentagon" "transforming with %s i: %s i1: %s i2: %s i3: %s" (Rhs.show ((Some (coeff, v)),o,d)) (Value.show i) (Value.show i1) (Value.show i2) (Value.show i3); set_value_for_root v i_transformed and set_rhs (econ, is, ineq) lhs rhs = @@ -156,7 +147,8 @@ struct and meet_with_one_value var value t narrow = - let meet_function = if narrow then Value.narrow else Value.meet in + (*We do not want to do any narrowing ourselves, as this leads to strange behaiviour in combination with base*) + let meet_function = if narrow then (fun x y -> y) else Value.meet in let new_value = meet_function value (get_value t var) in if Value.is_bot new_value then raise EConj.Contradiction else let res = set_value t var new_value (*TODO because we meet with an already saved values, we already confirm to the congruence constraints -> skip calculating them again!*) @@ -252,12 +244,9 @@ struct end in if refine_depth > 0 then begin - if M.tracing then M.trace "refinements" "applying %s to %s, remaining depth: %d" (Refinement.show refs) (show t) refine_depth; let res = List.fold apply_single t refs in - if M.tracing then M.trace "refinements" "resulted in %s" (show res); res end else begin - if M.tracing then M.trace "refinements" "call with depth 0 ignored"; t end @@ -301,12 +290,6 @@ struct in set_value (econj'', vs'', ineq'') y @@ get_value d y | _ -> failwith "Should not happen" (*transformation can not be a constant*) - let forget_variable d var = - if M.tracing then M.tracel "forget" "forget var_%d in { %s } " var (show d); - let res = forget_variable d var in - if M.tracing then M.trace "forget" "-> { %s }" (show res); - res - let dim_remove (ch: Apron.Dim.change) (econj, v, ineq) = if Array.length ch.dim = 0 || is_empty (econj, v, ineq) then @@ -332,11 +315,6 @@ struct in apply_refinements refinements (EConj.affine_transform econ i rhs, vs, ineq') - let affine_transform econ i (c,v,o,d) = - let res = affine_transform econ i (c,v,o,d) in - if M.tracing then M.tracel "affine_transform" "affine_transform %s with var_%d'=%s -> %s " (show econ) i (Rhs.show (Some (c,v),o,d)) (show res); - res - end (** [VarManagement] defines the type t of the affine equality domain (a record that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by [RelationDomain.D2]) such as [add_vars], [remove_vars]. @@ -1024,8 +1002,8 @@ struct let join a b = let res = join a b in if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; - (*assert(leq a res); - assert(leq b res);*) + assert(leq a res); + assert(leq b res); res let widen = join' true @@ -1381,14 +1359,15 @@ struct match Convert.texpr1_of_cil_exp ask d (env d) e no_ov with | texpr1 -> let (i, c) = eval_texpr d (Texpr1.to_expr texpr1) in + let (min, max) = IntDomain.Size.range ik in let c = match c with | None -> ID.bot_of ik | Some c -> ID.of_congruence ik c in let i = match i with | None -> ID.bot_of ik - | Some (TopIntOps.Int l, TopIntOps.Int u) -> ID.of_interval ik (l,u) - | Some (TopIntOps.Int l, _) -> ID.starting ik l - | Some (_, TopIntOps.Int u) -> ID.ending ik u + | Some (TopIntOps.Int l, TopIntOps.Int u) -> ID.of_interval ~suppress_ovwarn:true ik ((Z.max l min),(Z.min u max)) + | Some (TopIntOps.Int l, _) -> ID.starting ~suppress_ovwarn:true ik (Z.max l min) + | Some (_, TopIntOps.Int u) -> ID.ending ~suppress_ovwarn:true ik (Z.min u max) | _ -> ID.top_of ik in ID.meet c i | exception Convert.Unsupported_CilExp _ -> ID.top_of ik diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index e4374cd5f2..726b3a7f16 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -1217,24 +1217,29 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let narrow get_value t1 t2 = IntMap.fold (fun x ys acc -> IntMap.fold (fun y coeff acc -> meet_one_coeff true get_value x y (Coeffs.to_set coeff) acc) ys acc) t1 (t2,[]) - let join' widen t1 get_val_t1 t2 get_val_t2 = - let merge_y x y = (if widen then Coeffs.widen else Coeffs.join) x y get_val_t1 get_val_t2 in + let join t1 get_val_t1 t2 get_val_t2 = + let merge_y x y = Coeffs.join x y get_val_t1 get_val_t2 in let merge_x x ys1 ys2 = match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) + | Some ys1, None -> None + | None, Some ys2 -> None | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) | _, _ -> None in IntMap.merge (merge_x) t1 t2 - let join' widen t1 get_val_t1 t2 get_val_t2 = - let res = join' widen t1 get_val_t1 t2 get_val_t2 in + let join t1 get_val_t1 t2 get_val_t2 = + let res = Timing.wrap "join_ineq" (join t1 get_val_t1 t2 ) get_val_t2 in if M.tracing then M.trace "join'" "a: %s b: %s -> %s" (show t1) (show t2) (show res); res - - let join = join' false - let widen = join' true + let widen t1 get_val_t1 t2 get_val_t2 = + let merge_x x ys1 ys2 = + match ys1, ys2 with + | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> Coeffs.widen x y get_val_t1 get_val_t2 (Some coeff1) None ) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> Coeffs.widen x y get_val_t1 get_val_t2 None (Some coeff2)) ys2) + | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (fun y cs1 cs2 -> Coeffs.widen x y get_val_t1 get_val_t2 cs1 cs2) ys1 ys2) + | _, _ -> None + in IntMap.merge (merge_x) t1 t2 let widen a b c d = let res = widen a b c d in @@ -1405,8 +1410,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct meet_relation_roots x y k c' (t,ref_acc) end (*Cases where one of the variables is a constant -> refine value*) - | (None, o_x, _), (Some (_,y),_,_) -> t, [Refinement.of_value y @@ Relation.value_with_const_left cond o_x] - | (Some (_,x),_,_), (None, o_y, _) -> t, [Refinement.of_value x @@ Relation.value_with_const_right cond o_y] + | (None, o_x, _), (Some _,_,_) -> t, [Refinement.of_value y' @@ Relation.value_with_const_left cond o_x] + | (Some _,_,_), (None, o_y, _) -> t, [Refinement.of_value x' @@ Relation.value_with_const_right cond o_y] | (None, o_x, _), (None, o_y, _) -> let v = Relation.value_with_const_right cond o_y in if Value.contains v o_x then @@ -1444,6 +1449,7 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct Value.meet value @@ Value.starting @@ Z.fdiv (Q.num min) (Q.den min) in TVIS.CoeffMap.fold check_single cs Value.top in + let without_i = forget_variable t i in (*add to bindings, meeting with existing if necessary*) let merge_single x y cs_new (t,ref_acc) = let cs_curr = BatOption.default TVIS.empty @@ BatOption.map to_set @@ get_coeff x y t in @@ -1452,25 +1458,22 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct | None -> t,ref_acc | Some cs_combined -> set_coeff x y cs_combined t, ref_acc in - let merge_ys x ys acc = IntMap.fold (merge_single x) ys acc in let fold_x x ys acc = if x < i then match IntMap.find_opt i ys with - | None -> merge_ys x (IntMap.map to_set ys) acc + | None -> acc | Some cs -> - let cs = to_set cs in - let ys' = IntMap.remove i ys in - let acc' = merge_ys x (IntMap.map to_set ys') acc in (*everything else is added unchanged*) + let cs = to_set cs in let cs' = TVIS.substitute_right (coeff, offs, divi) cs in if x = j then (*We now have inequalities with the same variable on both sides *) - let t,ref_acc = acc' in + let t,ref_acc = acc in let v = constraints_same_variable cs' in t, Refinement.of_value x v :: ref_acc else if x < j then - merge_single x j cs' acc' + merge_single x j cs' acc else (*x > j -> swap sides*) let cs'' = TVIS.swap_sides cs' in - merge_single j x cs'' acc' + merge_single j x cs'' acc else if x = i then let fold_y y cs acc = let cs' = TVIS.substitute_left (coeff, offs, divi) cs in @@ -1486,8 +1489,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct in IntMap.fold fold_y (IntMap.map to_set ys) acc else - merge_ys x (IntMap.map to_set ys) acc - in IntMap.fold fold_x t (IntMap.empty, []) + acc + in IntMap.fold fold_x t (without_i, []) let substitute get_value t i (c,j,o,d) = if M.tracing then M.trace "substitute" "substituting var_%d in %s with %s" i (show t) (Rhs.show (Some (c,j), o, d)); From 7bc66ac0f0186e8f1acd544a73e00e17da22f0c6 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sun, 6 Jul 2025 04:22:05 +0200 Subject: [PATCH 82/86] reenable interval narrowing after fixing underlying bug, disable assertions again --- .../apron/linearTwoVarEqualityDomainPentagon.apron.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 9176243132..781bf4ad47 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -147,9 +147,8 @@ struct and meet_with_one_value var value t narrow = - (*We do not want to do any narrowing ourselves, as this leads to strange behaiviour in combination with base*) - let meet_function = if narrow then (fun x y -> y) else Value.meet in - let new_value = meet_function value (get_value t var) + let meet_function = if narrow then Value.narrow else Value.meet in + let new_value = meet_function (get_value t var) value in if Value.is_bot new_value then raise EConj.Contradiction else let res = set_value t var new_value (*TODO because we meet with an already saved values, we already confirm to the congruence constraints -> skip calculating them again!*) in if M.tracing then M.tracel "meet_value" "meet var_%d: before: %s meeting: %s -> %s, total: %s-> %s" (var) (Value.show @@ get_value t var) (Value.show value) (Value.show new_value) (show t) (show res); @@ -1002,8 +1001,8 @@ struct let join a b = let res = join a b in if M.tracing then M.tracel "join" "join a: %s b: %s -> %s" (show a) (show b) (show res) ; - assert(leq a res); - assert(leq b res); + (*assert(leq a res); + assert(leq b res);*) res let widen = join' true From c093c14346325ef84732fee15fe59f0675c0eed0 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 8 Jul 2025 01:22:36 +0200 Subject: [PATCH 83/86] fix regression test: wrong optimisation of join. Cleanup TODOs --- .../apron/representantDomains.apron.ml | 46 +++++++------------ 1 file changed, 17 insertions(+), 29 deletions(-) diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 726b3a7f16..6a2d12fb59 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -1048,11 +1048,18 @@ module TwoVarInequalitySet = struct let t2 = match t2 with None -> CoeffMap.empty | Some t2 -> t2 in (*add interval inequalities to copies*) let t1_with_interval = - let ineqs = LinearInequality.from_values (get_val_t1 x) (get_val_t1 y) in - List.fold (fun t (k,c) -> add_inequality k c t) t1 ineqs + (*Do not do this work if we never need it*) + if CoeffMap.is_empty t2 then + CoeffMap.empty + else + let ineqs = LinearInequality.from_values (get_val_t1 x) (get_val_t1 y) in + List.fold (fun t (k,c) -> add_inequality k c t) t1 ineqs in let t2_with_interval = - let ineqs = LinearInequality.from_values (get_val_t2 x) (get_val_t2 y) in - List.fold (fun t (k,c) -> add_inequality k c t) t2 ineqs + if CoeffMap.is_empty t1 then + CoeffMap.empty + else + let ineqs = LinearInequality.from_values (get_val_t2 x) (get_val_t2 y) in + List.fold (fun t (k,c) -> add_inequality k c t) t2 ineqs in (*Keep slopes where the other element implies some inequality for the same slope *) let relax t k c = @@ -1221,8 +1228,8 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let merge_y x y = Coeffs.join x y get_val_t1 get_val_t2 in let merge_x x ys1 ys2 = match ys1, ys2 with - | Some ys1, None -> None - | None, Some ys2 -> None + | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> merge_y x y (Some coeff1) None) ys1) + | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> merge_y x y None (Some coeff2)) ys2) | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (merge_y x) ys1 ys2) | _, _ -> None in IntMap.merge (merge_x) t1 t2 @@ -1235,10 +1242,9 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let widen t1 get_val_t1 t2 get_val_t2 = let merge_x x ys1 ys2 = match ys1, ys2 with - | Some ys1, None -> ignore_empty (IntMap.filter_map (fun y coeff1 -> Coeffs.widen x y get_val_t1 get_val_t2 (Some coeff1) None ) ys1) - | None, Some ys2 -> ignore_empty (IntMap.filter_map (fun y coeff2 -> Coeffs.widen x y get_val_t1 get_val_t2 None (Some coeff2)) ys2) + | _, None + | None, _ -> None | Some ys1, Some ys2 -> ignore_empty (IntMap.merge (fun y cs1 cs2 -> Coeffs.widen x y get_val_t1 get_val_t2 cs1 cs2) ys1 ys2) - | _, _ -> None in IntMap.merge (merge_x) t1 t2 let widen a b c d = @@ -1748,25 +1754,7 @@ module PentagonOffsetCoeffs : Coeffs = struct end -(*TODOs:*) - -(*?? limit: use linear time algorithm for coeffs_count instead of sorting??*) - -(*!! fix cohencu tests*) - -(*+ look at complexities. I expect for all: (n² log n) - not leq because of interval fixpoint!!!*) -(*+ How to do a useful narrow?*) - +(* limit: use linear time algorithm for coeffs_count instead of sorting??*) (* widening thresholds: from offsets of rhs?*) (* store information about representants to avoid recalculating them: congruence information, group size/ coefficients ??*) - -(*- copy_to_new: introduces too many inequlities?*) -(*- ineq refine_with_tcons: normalisation*) -(*- better to_inequalities? with query?*) - -(*-- assign expr restore ineqs based on value *) -(*--memo_bumbvar created 3 times*) -(*--eval_int: answer nonlinear*) - -(*! general renaming*) \ No newline at end of file +(* rename Coeff projection?*) \ No newline at end of file From d6f829f8eab68cfbbb8c3757d12928f573fed34f Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Fri, 18 Jul 2025 16:30:07 +0200 Subject: [PATCH 84/86] move regression tests --- tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/01-loop.c | 0 .../regression/{86-lin2vareq_p => 88-lin2vareq_p}/02-iteration.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/03-loop_increment.c | 0 .../04-complicated_expression.c | 0 tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/05-overflow.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/06-join-non-constant.c | 0 .../regression/{86-lin2vareq_p => 88-lin2vareq_p}/07-coeff_vec.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/08-partitioning.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/09-loop_relational.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/10-linear_loop.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/11-overflow_ignored.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/12-bounds_guards_ov.c | 0 .../regression/{86-lin2vareq_p => 88-lin2vareq_p}/13-meet-tcons.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/14-function-call.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/15-join_all_cases.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/16-sum-of-two-vars.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/17-svcomp-signextension.c | 0 .../regression/{86-lin2vareq_p => 88-lin2vareq_p}/18-forget_var.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/19-cast-to-short.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/20-function_call2.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/21-global-variables.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/22-cast-to-short2.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/23-function-return-value.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/24-narrowing-on-steroids.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/25-different_types.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/26-termination-overflow.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/27-overflow-unknown.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/28-overflow-on-steroids.c | 0 .../29-meet-tcons-on-steroids.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/30-cast-non-int.c | 0 tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/31-careful.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/32-divbzero-in-overflow.c | 0 tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/33-dimarray.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/34-coefficient-features.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/36-relations-overflow.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/37-intervals_propagation.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/38-simple_congruence.c | 0 .../39-congruence_from_equation.c | 0 .../{86-lin2vareq_p => 88-lin2vareq_p}/40-join-splitting-group.c | 0 tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/dune | 0 40 files changed, 0 insertions(+), 0 deletions(-) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/01-loop.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/02-iteration.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/03-loop_increment.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/04-complicated_expression.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/05-overflow.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/06-join-non-constant.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/07-coeff_vec.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/08-partitioning.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/09-loop_relational.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/10-linear_loop.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/11-overflow_ignored.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/12-bounds_guards_ov.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/13-meet-tcons.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/14-function-call.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/15-join_all_cases.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/16-sum-of-two-vars.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/17-svcomp-signextension.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/18-forget_var.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/19-cast-to-short.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/20-function_call2.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/21-global-variables.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/22-cast-to-short2.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/23-function-return-value.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/24-narrowing-on-steroids.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/25-different_types.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/26-termination-overflow.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/27-overflow-unknown.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/28-overflow-on-steroids.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/29-meet-tcons-on-steroids.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/30-cast-non-int.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/31-careful.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/32-divbzero-in-overflow.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/33-dimarray.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/34-coefficient-features.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/36-relations-overflow.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/37-intervals_propagation.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/38-simple_congruence.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/39-congruence_from_equation.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/40-join-splitting-group.c (100%) rename tests/regression/{86-lin2vareq_p => 88-lin2vareq_p}/dune (100%) diff --git a/tests/regression/86-lin2vareq_p/01-loop.c b/tests/regression/88-lin2vareq_p/01-loop.c similarity index 100% rename from tests/regression/86-lin2vareq_p/01-loop.c rename to tests/regression/88-lin2vareq_p/01-loop.c diff --git a/tests/regression/86-lin2vareq_p/02-iteration.c b/tests/regression/88-lin2vareq_p/02-iteration.c similarity index 100% rename from tests/regression/86-lin2vareq_p/02-iteration.c rename to tests/regression/88-lin2vareq_p/02-iteration.c diff --git a/tests/regression/86-lin2vareq_p/03-loop_increment.c b/tests/regression/88-lin2vareq_p/03-loop_increment.c similarity index 100% rename from tests/regression/86-lin2vareq_p/03-loop_increment.c rename to tests/regression/88-lin2vareq_p/03-loop_increment.c diff --git a/tests/regression/86-lin2vareq_p/04-complicated_expression.c b/tests/regression/88-lin2vareq_p/04-complicated_expression.c similarity index 100% rename from tests/regression/86-lin2vareq_p/04-complicated_expression.c rename to tests/regression/88-lin2vareq_p/04-complicated_expression.c diff --git a/tests/regression/86-lin2vareq_p/05-overflow.c b/tests/regression/88-lin2vareq_p/05-overflow.c similarity index 100% rename from tests/regression/86-lin2vareq_p/05-overflow.c rename to tests/regression/88-lin2vareq_p/05-overflow.c diff --git a/tests/regression/86-lin2vareq_p/06-join-non-constant.c b/tests/regression/88-lin2vareq_p/06-join-non-constant.c similarity index 100% rename from tests/regression/86-lin2vareq_p/06-join-non-constant.c rename to tests/regression/88-lin2vareq_p/06-join-non-constant.c diff --git a/tests/regression/86-lin2vareq_p/07-coeff_vec.c b/tests/regression/88-lin2vareq_p/07-coeff_vec.c similarity index 100% rename from tests/regression/86-lin2vareq_p/07-coeff_vec.c rename to tests/regression/88-lin2vareq_p/07-coeff_vec.c diff --git a/tests/regression/86-lin2vareq_p/08-partitioning.c b/tests/regression/88-lin2vareq_p/08-partitioning.c similarity index 100% rename from tests/regression/86-lin2vareq_p/08-partitioning.c rename to tests/regression/88-lin2vareq_p/08-partitioning.c diff --git a/tests/regression/86-lin2vareq_p/09-loop_relational.c b/tests/regression/88-lin2vareq_p/09-loop_relational.c similarity index 100% rename from tests/regression/86-lin2vareq_p/09-loop_relational.c rename to tests/regression/88-lin2vareq_p/09-loop_relational.c diff --git a/tests/regression/86-lin2vareq_p/10-linear_loop.c b/tests/regression/88-lin2vareq_p/10-linear_loop.c similarity index 100% rename from tests/regression/86-lin2vareq_p/10-linear_loop.c rename to tests/regression/88-lin2vareq_p/10-linear_loop.c diff --git a/tests/regression/86-lin2vareq_p/11-overflow_ignored.c b/tests/regression/88-lin2vareq_p/11-overflow_ignored.c similarity index 100% rename from tests/regression/86-lin2vareq_p/11-overflow_ignored.c rename to tests/regression/88-lin2vareq_p/11-overflow_ignored.c diff --git a/tests/regression/86-lin2vareq_p/12-bounds_guards_ov.c b/tests/regression/88-lin2vareq_p/12-bounds_guards_ov.c similarity index 100% rename from tests/regression/86-lin2vareq_p/12-bounds_guards_ov.c rename to tests/regression/88-lin2vareq_p/12-bounds_guards_ov.c diff --git a/tests/regression/86-lin2vareq_p/13-meet-tcons.c b/tests/regression/88-lin2vareq_p/13-meet-tcons.c similarity index 100% rename from tests/regression/86-lin2vareq_p/13-meet-tcons.c rename to tests/regression/88-lin2vareq_p/13-meet-tcons.c diff --git a/tests/regression/86-lin2vareq_p/14-function-call.c b/tests/regression/88-lin2vareq_p/14-function-call.c similarity index 100% rename from tests/regression/86-lin2vareq_p/14-function-call.c rename to tests/regression/88-lin2vareq_p/14-function-call.c diff --git a/tests/regression/86-lin2vareq_p/15-join_all_cases.c b/tests/regression/88-lin2vareq_p/15-join_all_cases.c similarity index 100% rename from tests/regression/86-lin2vareq_p/15-join_all_cases.c rename to tests/regression/88-lin2vareq_p/15-join_all_cases.c diff --git a/tests/regression/86-lin2vareq_p/16-sum-of-two-vars.c b/tests/regression/88-lin2vareq_p/16-sum-of-two-vars.c similarity index 100% rename from tests/regression/86-lin2vareq_p/16-sum-of-two-vars.c rename to tests/regression/88-lin2vareq_p/16-sum-of-two-vars.c diff --git a/tests/regression/86-lin2vareq_p/17-svcomp-signextension.c b/tests/regression/88-lin2vareq_p/17-svcomp-signextension.c similarity index 100% rename from tests/regression/86-lin2vareq_p/17-svcomp-signextension.c rename to tests/regression/88-lin2vareq_p/17-svcomp-signextension.c diff --git a/tests/regression/86-lin2vareq_p/18-forget_var.c b/tests/regression/88-lin2vareq_p/18-forget_var.c similarity index 100% rename from tests/regression/86-lin2vareq_p/18-forget_var.c rename to tests/regression/88-lin2vareq_p/18-forget_var.c diff --git a/tests/regression/86-lin2vareq_p/19-cast-to-short.c b/tests/regression/88-lin2vareq_p/19-cast-to-short.c similarity index 100% rename from tests/regression/86-lin2vareq_p/19-cast-to-short.c rename to tests/regression/88-lin2vareq_p/19-cast-to-short.c diff --git a/tests/regression/86-lin2vareq_p/20-function_call2.c b/tests/regression/88-lin2vareq_p/20-function_call2.c similarity index 100% rename from tests/regression/86-lin2vareq_p/20-function_call2.c rename to tests/regression/88-lin2vareq_p/20-function_call2.c diff --git a/tests/regression/86-lin2vareq_p/21-global-variables.c b/tests/regression/88-lin2vareq_p/21-global-variables.c similarity index 100% rename from tests/regression/86-lin2vareq_p/21-global-variables.c rename to tests/regression/88-lin2vareq_p/21-global-variables.c diff --git a/tests/regression/86-lin2vareq_p/22-cast-to-short2.c b/tests/regression/88-lin2vareq_p/22-cast-to-short2.c similarity index 100% rename from tests/regression/86-lin2vareq_p/22-cast-to-short2.c rename to tests/regression/88-lin2vareq_p/22-cast-to-short2.c diff --git a/tests/regression/86-lin2vareq_p/23-function-return-value.c b/tests/regression/88-lin2vareq_p/23-function-return-value.c similarity index 100% rename from tests/regression/86-lin2vareq_p/23-function-return-value.c rename to tests/regression/88-lin2vareq_p/23-function-return-value.c diff --git a/tests/regression/86-lin2vareq_p/24-narrowing-on-steroids.c b/tests/regression/88-lin2vareq_p/24-narrowing-on-steroids.c similarity index 100% rename from tests/regression/86-lin2vareq_p/24-narrowing-on-steroids.c rename to tests/regression/88-lin2vareq_p/24-narrowing-on-steroids.c diff --git a/tests/regression/86-lin2vareq_p/25-different_types.c b/tests/regression/88-lin2vareq_p/25-different_types.c similarity index 100% rename from tests/regression/86-lin2vareq_p/25-different_types.c rename to tests/regression/88-lin2vareq_p/25-different_types.c diff --git a/tests/regression/86-lin2vareq_p/26-termination-overflow.c b/tests/regression/88-lin2vareq_p/26-termination-overflow.c similarity index 100% rename from tests/regression/86-lin2vareq_p/26-termination-overflow.c rename to tests/regression/88-lin2vareq_p/26-termination-overflow.c diff --git a/tests/regression/86-lin2vareq_p/27-overflow-unknown.c b/tests/regression/88-lin2vareq_p/27-overflow-unknown.c similarity index 100% rename from tests/regression/86-lin2vareq_p/27-overflow-unknown.c rename to tests/regression/88-lin2vareq_p/27-overflow-unknown.c diff --git a/tests/regression/86-lin2vareq_p/28-overflow-on-steroids.c b/tests/regression/88-lin2vareq_p/28-overflow-on-steroids.c similarity index 100% rename from tests/regression/86-lin2vareq_p/28-overflow-on-steroids.c rename to tests/regression/88-lin2vareq_p/28-overflow-on-steroids.c diff --git a/tests/regression/86-lin2vareq_p/29-meet-tcons-on-steroids.c b/tests/regression/88-lin2vareq_p/29-meet-tcons-on-steroids.c similarity index 100% rename from tests/regression/86-lin2vareq_p/29-meet-tcons-on-steroids.c rename to tests/regression/88-lin2vareq_p/29-meet-tcons-on-steroids.c diff --git a/tests/regression/86-lin2vareq_p/30-cast-non-int.c b/tests/regression/88-lin2vareq_p/30-cast-non-int.c similarity index 100% rename from tests/regression/86-lin2vareq_p/30-cast-non-int.c rename to tests/regression/88-lin2vareq_p/30-cast-non-int.c diff --git a/tests/regression/86-lin2vareq_p/31-careful.c b/tests/regression/88-lin2vareq_p/31-careful.c similarity index 100% rename from tests/regression/86-lin2vareq_p/31-careful.c rename to tests/regression/88-lin2vareq_p/31-careful.c diff --git a/tests/regression/86-lin2vareq_p/32-divbzero-in-overflow.c b/tests/regression/88-lin2vareq_p/32-divbzero-in-overflow.c similarity index 100% rename from tests/regression/86-lin2vareq_p/32-divbzero-in-overflow.c rename to tests/regression/88-lin2vareq_p/32-divbzero-in-overflow.c diff --git a/tests/regression/86-lin2vareq_p/33-dimarray.c b/tests/regression/88-lin2vareq_p/33-dimarray.c similarity index 100% rename from tests/regression/86-lin2vareq_p/33-dimarray.c rename to tests/regression/88-lin2vareq_p/33-dimarray.c diff --git a/tests/regression/86-lin2vareq_p/34-coefficient-features.c b/tests/regression/88-lin2vareq_p/34-coefficient-features.c similarity index 100% rename from tests/regression/86-lin2vareq_p/34-coefficient-features.c rename to tests/regression/88-lin2vareq_p/34-coefficient-features.c diff --git a/tests/regression/86-lin2vareq_p/36-relations-overflow.c b/tests/regression/88-lin2vareq_p/36-relations-overflow.c similarity index 100% rename from tests/regression/86-lin2vareq_p/36-relations-overflow.c rename to tests/regression/88-lin2vareq_p/36-relations-overflow.c diff --git a/tests/regression/86-lin2vareq_p/37-intervals_propagation.c b/tests/regression/88-lin2vareq_p/37-intervals_propagation.c similarity index 100% rename from tests/regression/86-lin2vareq_p/37-intervals_propagation.c rename to tests/regression/88-lin2vareq_p/37-intervals_propagation.c diff --git a/tests/regression/86-lin2vareq_p/38-simple_congruence.c b/tests/regression/88-lin2vareq_p/38-simple_congruence.c similarity index 100% rename from tests/regression/86-lin2vareq_p/38-simple_congruence.c rename to tests/regression/88-lin2vareq_p/38-simple_congruence.c diff --git a/tests/regression/86-lin2vareq_p/39-congruence_from_equation.c b/tests/regression/88-lin2vareq_p/39-congruence_from_equation.c similarity index 100% rename from tests/regression/86-lin2vareq_p/39-congruence_from_equation.c rename to tests/regression/88-lin2vareq_p/39-congruence_from_equation.c diff --git a/tests/regression/86-lin2vareq_p/40-join-splitting-group.c b/tests/regression/88-lin2vareq_p/40-join-splitting-group.c similarity index 100% rename from tests/regression/86-lin2vareq_p/40-join-splitting-group.c rename to tests/regression/88-lin2vareq_p/40-join-splitting-group.c diff --git a/tests/regression/86-lin2vareq_p/dune b/tests/regression/88-lin2vareq_p/dune similarity index 100% rename from tests/regression/86-lin2vareq_p/dune rename to tests/regression/88-lin2vareq_p/dune From 9ff7ece312ed2d03609046dd2c2d811c3a22aac7 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Tue, 22 Jul 2025 12:16:09 +0200 Subject: [PATCH 85/86] Ignore division by zero in speculative execution --- src/analyses/base.ml | 26 ++++++++++--------- src/analyses/baseInvariant.ml | 2 +- ...inearTwoVarEqualityDomainPentagon.apron.ml | 4 +-- src/common/framework/analysisState.ml | 2 +- 4 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 067fbeb1ac..f9fc48f96e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -202,21 +202,23 @@ struct | Mult -> ID.mul | Div -> fun x y -> - (match ID.equal_to Z.zero y with - | `Eq -> - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of division is zero" - | `Top -> - M.warn ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of division might be zero" - | `Neq -> ()); + if not !AnalysisState.executing_speculative_computations then + (match ID.equal_to Z.zero y with + | `Eq -> + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of division is zero" + | `Top -> + M.warn ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of division might be zero" + | `Neq -> ()); ID.div x y | Mod -> fun x y -> - (match ID.equal_to Z.zero y with - | `Eq -> - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of modulo is zero" - | `Top -> - M.warn ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of modulo might be zero" - | `Neq -> ()); + if not !AnalysisState.executing_speculative_computations then + (match ID.equal_to Z.zero y with + | `Eq -> + M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of modulo is zero" + | `Top -> + M.warn ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Second argument of modulo might be zero" + | `Neq -> ()); ID.rem x y | Lt -> ID.lt | Gt -> ID.gt diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 51bc436348..ad05aee7e5 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -286,7 +286,7 @@ struct let inv_bin_int (a, b) ikind c op = let warn_and_top_on_zero x = if GobOption.exists (Z.equal Z.zero) (ID.to_int x) then - (M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + (if not !AnalysisState.executing_speculative_computations then M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; ID.top_of ikind) else x diff --git a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml index 781bf4ad47..9803bda710 100644 --- a/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml +++ b/src/cdomains/apron/linearTwoVarEqualityDomainPentagon.apron.ml @@ -696,7 +696,7 @@ struct * If c*b = 0 or it can be positive or negative, we need the full range for the remainder. *) let b_val = eval d b in if Value.to_int b_val = Some (Int Z.zero) then begin - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; + if not !AnalysisState.executing_speculative_computations then M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; d end else let a_val = eval d a in @@ -717,7 +717,7 @@ struct let a_val = eval d a in let b_val = eval d b in if Value.to_int b_val = Some (Int Z.zero) then begin - M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; + if not !AnalysisState.executing_speculative_computations then M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0"; d end else let a' = Value.add (Value.mul (Value.div a_val b_val) b_val) value in diff --git a/src/common/framework/analysisState.ml b/src/common/framework/analysisState.ml index 4dd4744967..308e354186 100644 --- a/src/common/framework/analysisState.ml +++ b/src/common/framework/analysisState.ml @@ -4,7 +4,7 @@ This is set to true in control.ml before we verify the result (or already before solving if warn = 'early') *) let should_warn = ref false -(** If this is true, any overflows happening in IntDomains will not lead to warnings being produced or +(** If this is true, any overflows and potential division by zero happening in IntDomains will not lead to warnings being produced or {!svcomp_may_overflow} being set to true. This is useful when, e.g., {!BaseInvariant.Make.invariant} executes computations that are not in the actual program *) From de46b155a41b43ce95c2401afc96f1c74f5891a7 Mon Sep 17 00:00:00 2001 From: Manuel Pietsch Date: Sat, 26 Jul 2025 22:17:47 +0200 Subject: [PATCH 86/86] use Seq instead of Enum --- src/cdomains/apron/representantDomains.apron.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/representantDomains.apron.ml b/src/cdomains/apron/representantDomains.apron.ml index 6a2d12fb59..88c7b51a07 100644 --- a/src/cdomains/apron/representantDomains.apron.ml +++ b/src/cdomains/apron/representantDomains.apron.ml @@ -1569,7 +1569,7 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct match IntMap.find v_new (snd econj_old) with | None,_,_ -> t_acc (*skip constants*) | (Some (c,old_rep), o, d) -> - let allowed_slopes = Hashtbl.keys @@ slopes_from_coeffs coeffs (min v_new other_var, max v_new other_var) in + let allowed_slopes = Hashtbl.to_seq_keys @@ slopes_from_coeffs coeffs (min v_new other_var, max v_new other_var) in (*inverse rhs so that we can translate the inequalities of the old representant to slopes corresponding to the new representant*) let (_, (mi,oi,di)) = EConj.inverse v_new (c,old_rep,o,d) in let ci,_ = BatOption.get mi in @@ -1604,7 +1604,7 @@ module InequalityFunctor (Coeffs : Coeffs): TwoVarInequalities = struct let k_neq, o_new = convert_to_new (k_old, o) in TVIS.add_inequality k_neq o_new c_acc in List.fold copy_single_ineq c_acc ineqs - in let coeffs_new = Enum.fold add_single_slope TVIS.empty allowed_slopes + in let coeffs_new = Seq.fold_left add_single_slope TVIS.empty allowed_slopes in let x, y = min v_new other_var , max v_new other_var in match Coeffs.of_set (get_value x) (get_value y) coeffs_new with | Some coeffs_new -> set_coeff x y coeffs_new t_acc