From 2a53cbbd38c921cdde0c55aaabd4bdc2351821d3 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 23 May 2023 12:59:24 +0200 Subject: [PATCH 001/233] Very first (incomplete) draft for Must Null Byte Domain --- src/cdomains/arrayDomain.ml | 270 ++++++++++++++++++++++++++++++++++- src/cdomains/arrayDomain.mli | 39 ++++- src/util/options.schema.json | 2 +- 3 files changed, 305 insertions(+), 6 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 982cd94058..c685099e8d 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -8,7 +8,7 @@ module A = Array module BI = IntOps.BigIntOps module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | MustNullByteDomain (* determines the domain based on variable, type and flag *) let get_domain ~varAttr ~typAttr = @@ -16,6 +16,7 @@ let get_domain ~varAttr ~typAttr = | "partitioned" -> PartitionedDomain | "trivial" -> TrivialDomain | "unroll" -> UnrolledDomain + | "mustnullbyte" -> MustNullByteDomain | _ -> failwith "AttributeConfiguredArrayDomain: invalid option for domain" in (*TODO add options?*) @@ -60,6 +61,14 @@ sig val smart_widen: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_leq: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool val update_length: idx -> t -> t + + val to_string: t -> t + val to_n_string: t -> int -> bool -> t + val to_string_length: t -> idx + val string_concat: t -> t -> int option -> t + val substring_extraction: t -> t -> t option + val string_comparison: t -> t -> int option -> idx + val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t end @@ -99,6 +108,14 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq let update_length _ x = x + + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top () + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top () + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end @@ -187,6 +204,12 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq let update_length _ x = x + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end @@ -699,7 +722,202 @@ struct (* arrays can not be partitioned according to multiple expressions, arbitrary prefer the first one here *) x + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt + + let update_length _ x = x + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t +end + +module MustNullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t option and type idx = Idx.t = +struct + include SetDomain.Reverse (SetDomain.Make (Idx)) + let name () = "arrays containing null bytes" + type idx = Idx.t + type value = Val.t option (* None = null byte *) + + let domain_of_t _ = MustNullByteDomain + + let get ?(checkBounds=true) (ask: VDQ.t) index_set (_, i) = + let rec check_indexes i max = + if Z.gt i max then + true + else if exists (fun x -> match Idx.to_int x with Some num -> Z.equal i num | None -> false) index_set then + check_indexes (Z.add i Z.one) max + else + false in + let min_i = match Idx.minimal i with + | Some min -> min + | None -> Z.zero in (* assume worst case minimal index *) + let max_i = Idx.maximal i in + match max_i with + (* if there is no maximum number in interval, return top of value *) + | None -> Some (Val.top ()) + | Some max -> + (* else only return null if all numbers in interval are in index set *) + if check_indexes min_i max then + None + else + Some (Val.top ()) + + let set (ask: VDQ.t) index_set (_, i) v = + let min_i = match Idx.minimal i with + | Some min -> min + | None -> Z.zero in (* assume worst case minimal index *) + let max_i = Idx.maximal i in + match max_i, v with + (* if there is no maxinum number in interval and value = null, return index set unchanged *) + | None, None -> index_set + (* if there is no maximum number in interval and value != null, return top = empty set *) + | None, Some _ -> top () + | Some max, None -> + (* if i is an exact number and value = null, add i to index set *) + if Z.equal min_i max then + add (Idx.of_int !Cil.kindOfSizeOf min_i) index_set + (* if i is an interval and value = null, return index set unchanged *) + else + index_set + | Some max, Some _ -> + (* if i is an exact number and value != null, remove i from index set *) + if Z.equal min_i max then + remove (Idx.of_int !Cil.kindOfSizeOf min_i) index_set + (* if i is an interval and value != null, return top = empty set *) + else + top () + + let make ?(varAttr=[]) ?(typAttr=[]) i v = + (* TODO: for now naive addition of all indexes in interval one by one -- yup, that's very inefficient *) + let rec add_indexes index_set i max = + if Z.gt i max then + index_set + else + add_indexes (add (Idx.of_int !Cil.kindOfSizeOf i) index_set) (Z.add i Z.one) max in + match Idx.minimal i, Idx.maximal i, v with + (* if there is no minimal number in interval or value != null, return top *) + | None, _, _ + | Some _, _, Some _ -> top () + (* if value = null, return bot (i.e. set of all indexes from 0 to min) *) + | Some min, _, None -> add_indexes (empty ()) Z.zero min + + let length _ = None + + let move_if_affected ?(replace_with_const=false) _ index_set _ _ = index_set + + let get_vars_in_e _ = [] + + let map f index_set = + (* if f(null) = null, all values at indexes in set are still surely null *) + if f None = None then + index_set + (* else return top as checking the effect of f for every possible value is unfeasible *) + else + top () + + (* TODO: check if there is no smarter implementation of this (probably not) *) + let fold_left f a _ = f a (Some (Val.top ())) + + let smart_join _ _ = join + let smart_widen _ _ = widen + let smart_leq _ _ = leq + + (* string functions *) + let to_string index_set = + (* if index set is empty, the array doesn't surely contain a null byte and an overflow might happen *) + if is_empty index_set then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; + index_set) + (* else only keep the smallest index in the set *) + else + (* TODO: would min_elt work? (probably not) *) + let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in + singleton min_null + + let to_n_string index_set n no_null_warn = + (* TODO: for now naive addition of all indexes in interval one by one -- yup, that's very inefficient *) + let rec add_indexes index_set i max = + if Z.geq i max then + index_set + else + add_indexes (add (Idx.of_int !Cil.kindOfSizeOf i) index_set) (Z.add i Z.one) max in + (* if index set is empty, the array doesn't surely contain a null byte and an overflow might happen *) + if is_empty index_set then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; + index_set) + (* else if index set not empty *) + else + (* TODO: would min_elt work? (probably not) *) + let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in + match Idx.to_int min_null with + | Some i -> + (* ... keep smallest index in set if smaller than n and add as many null bytes as necessary to obtain n bytes string *) + if Z.lt i (Z.of_int n) then + add_indexes (singleton min_null) i (Z.of_int n) + (* ... or if smallest index >= n, return empty set and warn if no_null_warn = true *) + else if no_null_warn then + (M.warn "Resulting string may not contain a terminating null byte"; + empty ()) + else + empty () + | None -> singleton min_null (* should not happen, but if it does, can't compute additional must null bytes *) + + let to_string_length index_set = + (* if index set is empty, return top as array may contain null bytes we don't know of *) + (* TODO: warning not useful I believe? ((In theory, one could use strlen to determine if there is a null byte in array or not to + * know if bytes of the array are possibly overwriten in a malicious undertaking)) *) + if is_empty index_set then + Idx.top_of !Cil.kindOfSizeOf + else + (* TODO: would min_elt work? (probably not) *) + let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in + match Idx.to_int min_null with + (* else if we can determine the minimal index in set, we know 0 <= length <= minimal index *) + | Some i -> Idx.of_interval !Cil.kindOfSizeOf (Z.zero, i) + | None -> Idx.top_of !Cil.kindOfSizeOf + + let string_concat index_set1 index_set2 n = + let s1 = to_string index_set1 in + (* if s1 is empty, no statement possible for must null bytes of concatenation; warning generated by to_string above *) + if is_empty s1 then + empty () + else + begin match n with + (* concat at most n bytes of index_set2 to index_set1 = strncat *) + | Some num -> + let s1_i = choose s1 in + let s2 = to_n_string index_set2 num false in + (* if no must null byte among first n bytes of s2, no statement possible as no knowledge of may null bytes *) + if is_empty s2 then + empty() + (* else concatenation has null byte at strlen(s1) + first null byte found in s2 *) + else + (* TODO: would min_elt work? (probably not) *) + let min_null_s2 = fold (fun x acc -> Idx.lt x acc) s2 (Idx.bot_of !Cil.kindOfSizeOf) in + singleton (Idx.add s1_i min_null_s2) + (* concat bytes of index_set2 to index_set1 until a null byte is reached = strcat *) + | None -> + let s2 = to_string index_set2 in + (* if s2 is empty, no statement possible for must null bytes of concatenation; warning generated by to_string above *) + if is_empty s2 then + empty () + (* else concatenation has null byte at strlen(s1) + strlen(s2) *) + else + let s1_i = choose s1 in + let s2_i = choose s2 in + singleton (Idx.add s1_i s2_i) + end + + (* TODO -- can I even do something useful at all? Might as well leave out substring_extraction and string_comparison *) + let substring_extraction _ _ = Some (top ()) + + (* TODO *) + let string_comparison _ _ _ = Idx.top_of IInt + let update_length _ x = x + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end @@ -749,6 +967,26 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq + let to_string _ = top () + let to_n_string a n _ = + begin match length a with + | Some len -> + begin match Idx.maximal len with + | Some max -> + if Z.gt (Z.of_int n) max then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May produce a buffer overflow if the string doesn't contain a null byte in the first n bytes"; + top ()) + else + top () + | None -> top () + end + | None -> top () + end + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt + (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -801,6 +1039,13 @@ struct let l = Idx.join xl yl in Idx.leq xl yl && Base.smart_leq_with_length (Some l) x_eval_int y_eval_int x y + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt + (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -822,8 +1067,12 @@ struct module Base = Unroll (Val) (Idx) include Lattice.Prod (Base) (Idx) type idx = Idx.t - type value = Val.t - + type value = Val.t let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt let domain_of_t _ = UnrolledDomain let get ?(checkBounds=true) (ask : VDQ.t) (x, (l : idx)) (e, v) = @@ -842,6 +1091,13 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt + (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -960,6 +1216,14 @@ struct let set_i u (i,v) = U.set ask u (index_as_expression i) v in set_i (List.fold_left set_i u unrolledValues) (factor (), rest) + (* TODO! *) + let to_string _ = top () + let to_n_string _ _ _ = top () + let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf + let string_concat _ _ _ = top () + let substring_extraction _ _ = Some (top ()) + let string_comparison _ _ _ = Idx.top_of IInt + let project ?(varAttr=[]) ?(typAttr=[]) ask (t:t) = match get_domain ~varAttr ~typAttr, t with | PartitionedDomain, (Some x, None) -> to_t @@ (Some x, None, None) diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 8386deb541..0df132a8e2 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -2,7 +2,7 @@ open IntOps open GoblintCil module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | MustNullByteDomain val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain (** gets the underlying domain: chosen by the attributes in AttributeConfiguredArrayDomain *) @@ -56,6 +56,32 @@ sig val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool val update_length: idx -> t -> t + val to_string: t -> t + (** Returns an abstract value with at most one null byte marking the end of the string *) + + val to_n_string: t -> int -> bool -> t + (** [to_n_string index_set n no_null_warn] returns an abstract value with a potential null + * byte marking the end of the string and if needed followed by further null bytes to obtain + * an n bytes string. If the resulting value doesn't surely contain a terminating null_byte, + * issue a warning if [no_null_warn] is true. *) + + val to_string_length: t -> idx + (** Returns length of string represented by input abstract value *) + + val string_concat: t -> t -> int option -> t + (** [string_concat s1 s2 n] returns a new abstract value representing the string + * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of + * [s2] if present *) + + val substring_extraction: t -> t -> t option + (** [substring_extraction haystack needle] returns None if the string represented by the + * abstract value [needle] surely isn't a substring of [haystack], else Some (top) *) + + val string_comparison: t -> t -> int option -> idx + (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string + * represented by [s1] is less / greater than the one by [s2] or zero if they are equal; + * only compares the first [n] bytes if present *) + val project: ?varAttr:Cil.attributes -> ?typAttr:Cil.attributes -> VDQ.t -> t -> t end @@ -84,8 +110,17 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va * have a signature that allows for choosing an array representation at runtime. *) +module MustNullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +(** This functor creates an array representation by the indexes of all null bytes + * the array *surely* contains. This is useful to analyze strings, i.e. null- + * terminated char arrays, and particularly to determine if operations on strings + * could lead to a buffer overflow. Concrete values from Val are not interesting + * for this domain. +*) + module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Like partitioned but additionally manages the length of the array. *) module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t -(** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) +(** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. + * Always runs MustNullByte in parallel. *) diff --git a/src/util/options.schema.json b/src/util/options.schema.json index 2ff2e8bf58..7933b553ac 100644 --- a/src/util/options.schema.json +++ b/src/util/options.schema.json @@ -677,7 +677,7 @@ "description": "The domain that should be used for arrays. When employing the partition array domain, make sure to enable the expRelation analysis as well. When employing the unrolling array domain, make sure to set the ana.base.arrays.unrolling-factor >0.", "type": "string", - "enum": ["trivial", "partitioned", "unroll"], + "enum": ["trivial", "partitioned", "unroll", "mustnullbyte"], "default": "trivial" }, "unrolling-factor": { From 7798c0448c9204d17c131eef4f9c9691f45ec025 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 30 May 2023 19:50:04 +0200 Subject: [PATCH 002/233] Draft for complete Null Byte Domain TODO: strstr, strcmp and strncmp TODO: check and simplify code TODO: update string functions case in base analysis using new domain --- src/cdomains/arrayDomain.ml | 766 +++++++++++++++++++++++------------ src/cdomains/arrayDomain.mli | 48 ++- src/util/options.schema.json | 2 +- 3 files changed, 537 insertions(+), 279 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index c685099e8d..c2468e885f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -8,7 +8,7 @@ module A = Array module BI = IntOps.BigIntOps module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | MustNullByteDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | NullByteDomain (* determines the domain based on variable, type and flag *) let get_domain ~varAttr ~typAttr = @@ -16,7 +16,6 @@ let get_domain ~varAttr ~typAttr = | "partitioned" -> PartitionedDomain | "trivial" -> TrivialDomain | "unroll" -> UnrolledDomain - | "mustnullbyte" -> MustNullByteDomain | _ -> failwith "AttributeConfiguredArrayDomain: invalid option for domain" in (*TODO add options?*) @@ -62,14 +61,19 @@ sig val smart_leq: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool val update_length: idx -> t -> t + val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t +end + +module type Str = +sig + include S val to_string: t -> t - val to_n_string: t -> int -> bool -> t + val to_n_string: t -> int -> t val to_string_length: t -> idx + val string_copy: t -> t -> int option -> t val string_concat: t -> t -> int option -> t - val substring_extraction: t -> t -> t option + val substring_extraction: t -> t -> t val string_comparison: t -> t -> int option -> idx - - val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t end module type LatticeWithSmartOps = @@ -109,13 +113,6 @@ struct let smart_leq _ _ = leq let update_length _ x = x - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top () - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top () - let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end @@ -204,12 +201,6 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq let update_length _ x = x - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end @@ -722,205 +713,10 @@ struct (* arrays can not be partitioned according to multiple expressions, arbitrary prefer the first one here *) x - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt - let update_length _ x = x let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end -module MustNullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t option and type idx = Idx.t = -struct - include SetDomain.Reverse (SetDomain.Make (Idx)) - let name () = "arrays containing null bytes" - type idx = Idx.t - type value = Val.t option (* None = null byte *) - - let domain_of_t _ = MustNullByteDomain - - let get ?(checkBounds=true) (ask: VDQ.t) index_set (_, i) = - let rec check_indexes i max = - if Z.gt i max then - true - else if exists (fun x -> match Idx.to_int x with Some num -> Z.equal i num | None -> false) index_set then - check_indexes (Z.add i Z.one) max - else - false in - let min_i = match Idx.minimal i with - | Some min -> min - | None -> Z.zero in (* assume worst case minimal index *) - let max_i = Idx.maximal i in - match max_i with - (* if there is no maximum number in interval, return top of value *) - | None -> Some (Val.top ()) - | Some max -> - (* else only return null if all numbers in interval are in index set *) - if check_indexes min_i max then - None - else - Some (Val.top ()) - - let set (ask: VDQ.t) index_set (_, i) v = - let min_i = match Idx.minimal i with - | Some min -> min - | None -> Z.zero in (* assume worst case minimal index *) - let max_i = Idx.maximal i in - match max_i, v with - (* if there is no maxinum number in interval and value = null, return index set unchanged *) - | None, None -> index_set - (* if there is no maximum number in interval and value != null, return top = empty set *) - | None, Some _ -> top () - | Some max, None -> - (* if i is an exact number and value = null, add i to index set *) - if Z.equal min_i max then - add (Idx.of_int !Cil.kindOfSizeOf min_i) index_set - (* if i is an interval and value = null, return index set unchanged *) - else - index_set - | Some max, Some _ -> - (* if i is an exact number and value != null, remove i from index set *) - if Z.equal min_i max then - remove (Idx.of_int !Cil.kindOfSizeOf min_i) index_set - (* if i is an interval and value != null, return top = empty set *) - else - top () - - let make ?(varAttr=[]) ?(typAttr=[]) i v = - (* TODO: for now naive addition of all indexes in interval one by one -- yup, that's very inefficient *) - let rec add_indexes index_set i max = - if Z.gt i max then - index_set - else - add_indexes (add (Idx.of_int !Cil.kindOfSizeOf i) index_set) (Z.add i Z.one) max in - match Idx.minimal i, Idx.maximal i, v with - (* if there is no minimal number in interval or value != null, return top *) - | None, _, _ - | Some _, _, Some _ -> top () - (* if value = null, return bot (i.e. set of all indexes from 0 to min) *) - | Some min, _, None -> add_indexes (empty ()) Z.zero min - - let length _ = None - - let move_if_affected ?(replace_with_const=false) _ index_set _ _ = index_set - - let get_vars_in_e _ = [] - - let map f index_set = - (* if f(null) = null, all values at indexes in set are still surely null *) - if f None = None then - index_set - (* else return top as checking the effect of f for every possible value is unfeasible *) - else - top () - - (* TODO: check if there is no smarter implementation of this (probably not) *) - let fold_left f a _ = f a (Some (Val.top ())) - - let smart_join _ _ = join - let smart_widen _ _ = widen - let smart_leq _ _ = leq - - (* string functions *) - let to_string index_set = - (* if index set is empty, the array doesn't surely contain a null byte and an overflow might happen *) - if is_empty index_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; - index_set) - (* else only keep the smallest index in the set *) - else - (* TODO: would min_elt work? (probably not) *) - let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in - singleton min_null - - let to_n_string index_set n no_null_warn = - (* TODO: for now naive addition of all indexes in interval one by one -- yup, that's very inefficient *) - let rec add_indexes index_set i max = - if Z.geq i max then - index_set - else - add_indexes (add (Idx.of_int !Cil.kindOfSizeOf i) index_set) (Z.add i Z.one) max in - (* if index set is empty, the array doesn't surely contain a null byte and an overflow might happen *) - if is_empty index_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; - index_set) - (* else if index set not empty *) - else - (* TODO: would min_elt work? (probably not) *) - let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in - match Idx.to_int min_null with - | Some i -> - (* ... keep smallest index in set if smaller than n and add as many null bytes as necessary to obtain n bytes string *) - if Z.lt i (Z.of_int n) then - add_indexes (singleton min_null) i (Z.of_int n) - (* ... or if smallest index >= n, return empty set and warn if no_null_warn = true *) - else if no_null_warn then - (M.warn "Resulting string may not contain a terminating null byte"; - empty ()) - else - empty () - | None -> singleton min_null (* should not happen, but if it does, can't compute additional must null bytes *) - - let to_string_length index_set = - (* if index set is empty, return top as array may contain null bytes we don't know of *) - (* TODO: warning not useful I believe? ((In theory, one could use strlen to determine if there is a null byte in array or not to - * know if bytes of the array are possibly overwriten in a malicious undertaking)) *) - if is_empty index_set then - Idx.top_of !Cil.kindOfSizeOf - else - (* TODO: would min_elt work? (probably not) *) - let min_null = fold (fun x acc -> Idx.lt x acc) index_set (Idx.bot_of !Cil.kindOfSizeOf) in - match Idx.to_int min_null with - (* else if we can determine the minimal index in set, we know 0 <= length <= minimal index *) - | Some i -> Idx.of_interval !Cil.kindOfSizeOf (Z.zero, i) - | None -> Idx.top_of !Cil.kindOfSizeOf - - let string_concat index_set1 index_set2 n = - let s1 = to_string index_set1 in - (* if s1 is empty, no statement possible for must null bytes of concatenation; warning generated by to_string above *) - if is_empty s1 then - empty () - else - begin match n with - (* concat at most n bytes of index_set2 to index_set1 = strncat *) - | Some num -> - let s1_i = choose s1 in - let s2 = to_n_string index_set2 num false in - (* if no must null byte among first n bytes of s2, no statement possible as no knowledge of may null bytes *) - if is_empty s2 then - empty() - (* else concatenation has null byte at strlen(s1) + first null byte found in s2 *) - else - (* TODO: would min_elt work? (probably not) *) - let min_null_s2 = fold (fun x acc -> Idx.lt x acc) s2 (Idx.bot_of !Cil.kindOfSizeOf) in - singleton (Idx.add s1_i min_null_s2) - (* concat bytes of index_set2 to index_set1 until a null byte is reached = strcat *) - | None -> - let s2 = to_string index_set2 in - (* if s2 is empty, no statement possible for must null bytes of concatenation; warning generated by to_string above *) - if is_empty s2 then - empty () - (* else concatenation has null byte at strlen(s1) + strlen(s2) *) - else - let s1_i = choose s1 in - let s2_i = choose s2 in - singleton (Idx.add s1_i s2_i) - end - - (* TODO -- can I even do something useful at all? Might as well leave out substring_extraction and string_comparison *) - let substring_extraction _ _ = Some (top ()) - - (* TODO *) - let string_comparison _ _ _ = Idx.top_of IInt - - let update_length _ x = x - - let project ?(varAttr=[]) ?(typAttr=[]) _ t = t -end - (* This is the main array out of bounds check *) let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) (e, v) = if GobConfig.get_bool "ana.arrayoob" then (* The purpose of the following 2 lines is to give the user extra info about the array oob *) @@ -967,26 +763,6 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq - let to_string _ = top () - let to_n_string a n _ = - begin match length a with - | Some len -> - begin match Idx.maximal len with - | Some max -> - if Z.gt (Z.of_int n) max then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May produce a buffer overflow if the string doesn't contain a null byte in the first n bytes"; - top ()) - else - top () - | None -> top () - end - | None -> top () - end - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt - (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -1039,13 +815,6 @@ struct let l = Idx.join xl yl in Idx.leq xl yl && Base.smart_leq_with_length (Some l) x_eval_int y_eval_int x y - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt - (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -1067,12 +836,8 @@ struct module Base = Unroll (Val) (Idx) include Lattice.Prod (Base) (Idx) type idx = Idx.t - type value = Val.t let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt + type value = Val.t + let domain_of_t _ = UnrolledDomain let get ?(checkBounds=true) (ask : VDQ.t) (x, (l : idx)) (e, v) = @@ -1091,13 +856,6 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt - (* It is not necessary to do a least-upper bound between the old and the new length here. *) (* Any array can only be declared in one location. The value for newl that we get there is *) (* the one obtained by abstractly evaluating the size expression at this location for the *) @@ -1114,6 +872,498 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end +module type LatticeWithNull = +sig + include Lattice.S + val null: unit -> t + val not_null: unit -> t + val is_null: t -> bool +end + +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +struct + module MustNulls = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "No Nulls" end)) + module MayNulls = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) + (* (Must Null Set, May Null Set, Array Size) *) + include Lattice.Prod3 (MustNulls) (MayNulls) (Idx) + + let name () = "arrays containing null bytes" + type idx = Idx.t + type value = Val.t + + let domain_of_t _ = NullByteDomain + + let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, _, size) (e, i) = + let rec all_indexes_must_null i max = + if Z.gt i max then + true + else if MustNulls.exists (Z.equal i) must_nulls_set then + all_indexes_must_null (Z.add i Z.one) max + else + false in + let min_i = match Idx.minimal i with + | Some min -> + if Z.lt min Z.zero then + Z.zero (* assume worst case minimal index *) + else + min + | None -> Z.zero in (* assume worst case minimal index *) + let max_i = Idx.maximal i in + + (* warn if index is (potentially) out of bounds *) + if checkBounds then (array_oob_check (module Idx) (must_nulls_set, size) (e, i)); + match max_i, Idx.minimal size with + (* if there is no maximum number in interval, return top of value *) + | None, _ -> Val.top () + | Some max, Some min_size when Z.geq max Z.zero && Z.lt max min_size -> + (* else only return null if all numbers in interval are in must null index set *) + if all_indexes_must_null min_i max then + Val.null () + else + Val.top () + (* if maximum number in interval is invalid, i.e. negative, return top of value *) + | _ -> Val.top () + + let set (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) v = + let rec add_indexes i max may_nulls_set = + if Z.gt i max then + may_nulls_set + else + add_indexes (Z.add i Z.one) max (MayNulls.add i may_nulls_set) in + let rec remove_indexes i max must_nulls_set = + if Z.gt i max then + may_nulls_set + else + remove_indexes (Z.add i Z.one) max (MustNulls.remove i must_nulls_set) in + let min_of_natural_number num = + match Idx.minimal num with + | Some min -> + if Z.lt min Z.zero then + Z.zero (* assume worst case minimal index *) + else + min + | None -> Z.zero in (* assume worst case moptionimal index *) + let min_size = min_of_natural_number size in + let min_i = min_of_natural_number i in + let max_i = Idx.maximal i in + + (* warn if index is (potentially) out of bounds *) + array_oob_check (module Idx) (must_nulls_set, size) (e, i); + match max_i, Val.is_null v with + (* if no maximum number in interval and value = null, modify may_nulls_set to top = all possible indexes < size *) + | None, true -> (must_nulls_set, MayNulls.top (), size) + (* if no maximum number in interval and value != null, modify must_nulls_set to top = empty set *) + | None, false -> (MustNulls.top (), may_nulls_set, size) + (* if value = null *) + | Some max, true when Z.geq max Z.zero -> + begin match Idx.maximal size with + | Some max_size -> + (* ... and i is exact number < size, add i to must_nulls_set and may_nulls_set *) + if Z.equal min_i max && Z.lt min_i min_size then + (MustNulls.add min_i must_nulls_set, MayNulls.add min_i may_nulls_set, size) + (* ... and i is exact number in size interval, add i only to may_nulls_set *) + else if Z.equal min_i max && Z.lt min_i max_size then + (must_nulls_set, MayNulls.add min_i may_nulls_set, size) + (* ... and i is exact number >= size, warn and return tuple unmodified *) + else if Z.equal min_i max then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (must_nulls_set, may_nulls_set, size)) + (* ... and i is interval with lower bound = 0 and upper bound in size interval, modify may_nulls_set to top *) + else if Z.equal min_i Z.zero && Z.equal max (Z.sub max_size Z.one) then + (must_nulls_set, MayNulls.top (), size) + (* ... and i is interval with lower bound = 0 and upper bound >= size, warn and modify may_nulls_set to top *) + else if Z.equal min_i Z.zero && Z.geq max max_size then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (must_nulls_set, MayNulls.top (), size)) + (* ... and i is interval with lower bound > 0 and upper bound >= size, warn and add all indexes from interval lower bound to size to may_nulls_set *) + else if Z.geq max max_size then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (must_nulls_set, add_indexes min_i max_size may_nulls_set, size)) + (* ... and i is interval with upper bound < size, add all indexes of interval to may_nulls_set*) + else + (must_nulls_set, add_indexes min_i max may_nulls_set, size) + (* ..., size has no upper limit *) + | None -> + (* ... and i is exact number < minimal size, add i to must_nulls_set and may_nulls_set *) + if Z.equal min_i max && Z.lt min_i min_size then + (MustNulls.add min_i must_nulls_set, MayNulls.add min_i may_nulls_set, size) + (* ... and i is exact number >= minimal size, add i to may_nulls_set only *) + else if Z.equal min_i max then + (must_nulls_set, MayNulls.add min_i may_nulls_set, size) + (* ... and i is interval, add all indexes of interval to may_nulls_set *) + else + (must_nulls_set, add_indexes min_i max may_nulls_set, size) + end + (* if value != null *) + | Some max, false when Z.geq max Z.zero -> + begin match Idx.maximal size with + | Some max_size -> + (* ... and i is exact number < size, remove i from must_nulls_set and may_nulls_set *) + if Z.equal min_i max && Z.lt min_i min_size then + (MustNulls.remove min_i must_nulls_set, MayNulls.remove min_i may_nulls_set, size) + (* ... and i is exact number in size interval, remove i only from must_nulls_set *) + else if Z.equal min_i max && Z.lt min_i max_size then + (MustNulls.remove min_i must_nulls_set, may_nulls_set, size) + (* ... and i is exact number >= size, warn and return tuple unmodified *) + else if Z.equal min_i max then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (must_nulls_set, may_nulls_set, size)) + (* ... and i is interval with lower bound = 0 and upper bound = size, modify must_nulls_set to top *) + else if Z.equal min_i Z.zero && Z.equal max max_size then + (MustNulls.top (), may_nulls_set, size) + (* ... and i is interval with lower bound = 0 and upper bound >= size, warn and modify must_nulls_set to top *) + else if Z.equal min_i Z.zero && Z.geq max max_size then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (MustNulls.top (), may_nulls_set, size)) + (* ... and i is interval with lower bound > 0 and upper bound >= size, warn and remove all indexes from interval lower bound to size from must_nulls_set *) + else if Z.geq max max_size then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; + (remove_indexes min_i max_size must_nulls_set, may_nulls_set, size)) + (* ... and i is interval with upper bound < size, remove all indexes of interval from must_nulls_set *) + else + (remove_indexes min_i max must_nulls_set, may_nulls_set, size) + (* ..., size is unlimited *) + | None -> + (* ... and i is exact number < minimal size, remove i from must_nulls_set and may_nulls_set *) + if Z.equal min_i max && Z.lt min_i min_size then + (MustNulls.remove min_i must_nulls_set, MayNulls.remove min_i may_nulls_set, size) + (* ... and i is exact number >= minimal size, remove i from must_nulls_set only *) + else if Z.equal min_i max then + (MustNulls.remove min_i must_nulls_set, may_nulls_set, size) + (* ... and i is interval, remove all indexes from interval of must_nulls_set *) + else + (remove_indexes min_i max must_nulls_set, may_nulls_set, size) + end + (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) + | _ -> (must_nulls_set, may_nulls_set, size) + + let make ?(varAttr=[]) ?(typAttr=[]) i v = + let min_i, max_i = match Idx.minimal i, Idx.maximal i with + | Some min, Some max -> + if Z.lt min Z.zero && Z.lt max Z.zero then + (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; + Z.zero, Some Z.zero) + else if Z.lt min Z.zero then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; + Z.zero, Some max) + else + min, Some max + | None, Some max -> + if Z.lt max Z.zero then + (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; + Z.zero, Some Z.zero) + else + Z.zero, Some max + | Some min, None -> + if Z.lt min Z.zero then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; + Z.zero, None) + else + min, None + | None, None -> Z.zero, None in + match max_i, Val.is_null v with + (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) + | Some max, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max)) + | None, true -> (MustNulls.bot (), MayNulls.top (), Idx.starting !Cil.kindOfSizeOf min_i) + (* if value != null, return (top = no indexes, bot = no indexes, size) *) + | Some max, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max)) + | None, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting !Cil.kindOfSizeOf min_i) + + let length (_, _, size) = Some size + + let move_if_affected ?(replace_with_const=false) _ sets_and_size _ _ = sets_and_size + + let get_vars_in_e _ = [] + + let map f (must_nulls_set, may_nulls_set, size) = + (* if f(null) = null, all values in must_nulls_set still are surely null; + * assume top for may_nulls_set as checking effect of for every possible value is unfeasbile*) + if Val.is_null (f (Val.null ())) then + (must_nulls_set, MayNulls.top (), size) + (* else also return top for must_nulls_set *) + else + (MustNulls.top (), MayNulls.top (), size) + + (* TODO: check there is no smarter implementation -- problem is domain doesn't work on values but Z.t / idx for size *) + let fold_left f acc _ = f acc (Val.top ()) + + let smart_join _ _ = join + let smart_widen _ _ = widen + let smart_leq _ _ = leq + + (* string functions *) + let to_string (must_nulls_set, may_nulls_set, size) = + (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) + if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; + (must_nulls_set, may_nulls_set, size)) + (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) + else if MustNulls.is_empty must_nulls_set then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; + must_nulls_set, may_nulls_set, size) + else + let min_must_null = MustNulls.min_elt must_nulls_set in + (* if smallest index in sets coincides, only this null byte is kept in both sets *) + if Z.equal min_must_null (MayNulls.min_elt may_nulls_set) then + (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int !Cil.kindOfSizeOf (Z.add min_must_null Z.one)) + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + else + (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.add min_must_null Z.one)) + + let to_n_string (must_nulls_set, may_nulls_set, size) n = + let rec add_indexes i max may_nulls_set = + if Z.geq i max then + may_nulls_set + else + add_indexes (Z.add i Z.one) max (MayNulls.add i may_nulls_set) in + let update_must_indexes min_must_null must_nulls_set = + if Z.equal min_must_null Z.zero then + MustNulls.bot () + else + (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) + add_indexes min_must_null (Z.of_int n) (MustNulls.filter (Z.gt (Z.of_int n)) must_nulls_set) in + let update_may_indexes min_may_null may_nulls_set = + if Z.equal min_may_null Z.zero then + MayNulls.top () + else + (* if strlen < n, every byte starting from may_must_null may be transformed to null *) + add_indexes min_may_null (Z.of_int n) (MayNulls.filter (Z.gt (Z.of_int n)) may_nulls_set) in + let warn_no_null min_null = + if Z.geq min_null (Z.of_int n) then + M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" in + + if n < 0 then + (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + else + let check_n = match Idx.minimal size, Idx.maximal size with + | Some min, Some max -> + if Z.gt (Z.of_int n) max then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + else if Z.gt (Z.of_int n) min then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | Some min, None -> + if Z.gt (Z.of_int n) min then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | None, Some max -> + if Z.gt (Z.of_int n) max then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + | None, None -> () in + check_n; + (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) + if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + match Idx.minimal size with + (* ... there *may* be null bytes from minimal size to n - 1 if minimal size < n *) + | Some min when Z.geq min Z.zero -> (must_nulls_set, add_indexes min (Z.of_int n) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + | _ -> (must_nulls_set, may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + (* if only must_nulls_set empty, remove indexes >= n and add all indexes from min_may_null to n - 1 to may_nulls_set; + * warn if resulting array may not contain null byte *) + else if MustNulls.is_empty must_nulls_set then + let min_may_null = MayNulls.min_elt may_nulls_set in + warn_no_null min_may_null; + (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + else + let min_must_null = MustNulls.min_elt must_nulls_set in + let min_may_null = MayNulls.min_elt may_nulls_set in + warn_no_null min_may_null; + (* if smallest index in sets coincides, remove indexes >= n and add all indexes from min_null to n - 1 to both sets; + * warn if resulting array may not contain null byte *) + if Z.equal min_must_null min_may_null then + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + (* else return empty must_nulls_set, remove indexes >= n and add all indexes from min_may_null to n - 1 to may_nulls_set; + * warn if resulting array may not contain null byte *) + else + (MustNulls.empty (), update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + + let to_string_length (must_nulls_set, may_nulls_set, size) = + (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) *) + if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + match Idx.minimal size with + | Some min -> Idx.starting !Cil.kindOfSizeOf min + | None -> Idx.starting !Cil.kindOfSizeOf Z.zero + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) *) + else if MustNulls.is_empty must_nulls_set then + Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set) + (* else return interval [minimal may null, minimal must null] *) + else + Idx.of_interval !Cil.kindOfSizeOf (MustNulls.min_elt must_nulls_set, MayNulls.min_elt may_nulls_set) + + (* TODO: copy and resize + * filter out any index before size of string src, then union and keep size of dest *) + let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 = function + (* strcpy *) + | None -> + let must_nulls_set2, may_nulls_set2, size2 = to_string ar2 in + let strlen2 = to_string_length ar2 in + (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) + begin match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen2, Idx.maximal strlen2 with + | Some min1, Some max1, Some min2, Some max2 -> + let warn = + if Z.leq max1 min2 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.leq min1 max2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq max2) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min1, None, Some min2, Some max2 -> + let warn = + if Z.leq min1 max2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq max2) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) may_nulls_set2 in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min1, Some max1, Some min2, None -> + let warn = + if Z.leq max1 min2 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.leq min1 min2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.filter (Z.leq min1) must_nulls_set2 in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min1, None, Some min2, None -> + let warn = + if Z.leq min1 min2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.filter (Z.leq min1) must_nulls_set2 in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) may_nulls_set2 in + (must_nulls_set_result, may_nulls_set_result, size1) + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (MustNulls.top (), MayNulls.top (), size1) + end + (* strncpy => strlen(src) is precise number *) + | Some n -> + let must_nulls_set2, may_nulls_set2, _ = to_n_string ar2 n in + (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) + begin match Idx.minimal size1, Idx.maximal size1 with + | Some min1, Some max1 -> + let warn = + if Z.lt max1 (Z.of_int n) then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.lt min1 (Z.of_int n) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq (Z.of_int n)) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min1, None -> + let warn = + if Z.lt min1 (Z.of_int n) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in + warn; + let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq (Z.of_int n)) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in + let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set1) may_nulls_set2 in + (must_nulls_set_result, may_nulls_set_result, size1) + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (MustNulls.top (), MayNulls.top (), size1) + end + + let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let update_sets min1 max1 max1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = + (* track any potential buffer overflow and issue warning if needed *) + let warn = + if max1_exists && ((maxlen1_exists && maxlen2_exists && Z.leq max1 (Z.add maxlen1 maxlen2)) + || (maxlen1_exists && Z.leq max1 (Z.add maxlen1 minlen2)) || (maxlen2_exists && Z.leq max1 (Z.add minlen1 maxlen2)) + || Z.leq max1 (Z.add minlen1 minlen2)) then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" + else if (maxlen1_exists && maxlen2_exists && Z.leq min1 (Z.add maxlen1 maxlen2)) || (maxlen1_exists && Z.leq min1 (Z.add maxlen1 minlen2)) + || (maxlen2_exists && Z.leq min1 (Z.add minlen1 maxlen2)) || Z.leq min1 (Z.add minlen1 minlen2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest" in + warn; + (* if any must_nulls_set empty, result must_nulls_set also empty; + * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set + * and keep indexes > strlen(dest) + strlen(src) of may_nulls_set *) + if MustNulls.is_empty must_nulls_set1 || MustNulls.is_empty must_nulls_set2' then + let may_nulls_set_result = + MayNulls.filter (Z.geq (Z.add minlen1 minlen2)) may_nulls_set1 + |> MayNulls.elements + |> BatList.cartesian_product (MayNulls.elements may_nulls_set2') + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list + |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + (MustNulls.top (), may_nulls_set_result, size1) + (* if minimal must null = minimal may null in ar1 and ar2, add them and keep indexes > strlen(dest) + strlen(src) of ar1 *) + else if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) then + let min_i1 = MustNulls.min_elt must_nulls_set1 in + let min_i2 = MustNulls.min_elt must_nulls_set2' in + let min_i = Z.add min_i1 min_i2 in + let must_nulls_set_result = + MustNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 + |> MustNulls.add min_i + |> MustNulls.filter (Z.gt min1) in + let may_nulls_set_result = + MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 + |> MayNulls.add min_i + |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + (must_nulls_set_result, may_nulls_set_result, size1) + (* else only add all may nulls <= strlen(dest) + strlen(src) *) + else + let min_i2 = MustNulls.min_elt must_nulls_set2' in + let must_nulls_set_result = MustNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 in + let may_nulls_set_result = + MayNulls.filter (Z.geq (Z.add minlen1 minlen2)) may_nulls_set1 + |> MayNulls.map (Z.add min_i2) + |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + (must_nulls_set_result, may_nulls_set_result, size1) in + let compute_concat must_nulls_set2' may_nulls_set2' = + let strlen1 = to_string_length (must_nulls_set1, may_nulls_set1, size1) in + let strlen2 = to_string_length (must_nulls_set2', may_nulls_set2', size2) in + begin match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen1, Idx.maximal strlen1, Idx.minimal strlen2, Idx.maximal strlen2 with + | Some min1, Some max1, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> + update_sets min1 max1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for length of concatenation *) + | Some min1, Some max1, Some minlen1, None, Some minlen2, Some _ + | Some min1, Some max1, Some minlen1, Some _, Some minlen2, None + + | Some min1, Some max1, Some minlen1, None, Some minlen2, None -> + update_sets min1 max1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest *) + | Some min1, None, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> + update_sets min1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest and length of concatenation *) + | Some min1, None, Some minlen1, None, Some minlen2, Some _ + | Some min1, None, Some minlen1, Some _, Some minlen2, None + | Some min1, None, Some minlen1, None, Some minlen2, None -> + update_sets min1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (MustNulls.top (), MayNulls.top (), size1) + end in + + match n with + (* strcat *) + | None -> + let must_nulls_set2', may_nulls_set2', _ = to_string (must_nulls_set2, may_nulls_set2, size2) in + compute_concat must_nulls_set2' may_nulls_set2' + (* strncat *) + | Some num -> + (* take at most n bytes from src; if no null byte among them, add null byte at index n *) + let must_nulls_set2', may_nulls_set2' = + let must_nulls_set2, may_nulls_set2, _ = to_string (must_nulls_set2, may_nulls_set2, size2) in + if not (MayNulls.exists (Z.gt (Z.of_int num)) may_nulls_set2) then + (MustNulls.singleton (Z.of_int num), MayNulls.singleton (Z.of_int num)) + else if not (MustNulls.exists (Z.gt (Z.of_int num)) must_nulls_set2) then + (MustNulls.empty (), MayNulls.add (Z.of_int num) (MayNulls.filter (Z.leq (Z.of_int num)) may_nulls_set2)) + else + (MustNulls.filter (Z.leq (Z.of_int num)) must_nulls_set2, MayNulls.filter (Z.leq (Z.of_int num)) may_nulls_set2) in + compute_concat must_nulls_set2' may_nulls_set2' + + (* TODO -- can I even do something useful at all? Might as well leave out substring_extraction and string_comparison *) + let substring_extraction _ _ = Some (top ()) + + (* TODO *) + let string_comparison _ _ _ = Idx.top_of IInt + + let update_length _ x = x + + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t +end + module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = struct module P = PartitionedWithLength(Val)(Idx) @@ -1216,14 +1466,6 @@ struct let set_i u (i,v) = U.set ask u (index_as_expression i) v in set_i (List.fold_left set_i u unrolledValues) (factor (), rest) - (* TODO! *) - let to_string _ = top () - let to_n_string _ _ _ = top () - let to_string_length _ = Idx.top_of !Cil.kindOfSizeOf - let string_concat _ _ _ = top () - let substring_extraction _ _ = Some (top ()) - let string_comparison _ _ _ = Idx.top_of IInt - let project ?(varAttr=[]) ?(typAttr=[]) ask (t:t) = match get_domain ~varAttr ~typAttr, t with | PartitionedDomain, (Some x, None) -> to_t @@ (Some x, None, None) diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 0df132a8e2..5df3679cfa 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -2,7 +2,7 @@ open IntOps open GoblintCil module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | MustNullByteDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | NullByteDomain val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain (** gets the underlying domain: chosen by the attributes in AttributeConfiguredArrayDomain *) @@ -55,34 +55,42 @@ sig val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool val update_length: idx -> t -> t + val project: ?varAttr:Cil.attributes -> ?typAttr:Cil.attributes -> VDQ.t -> t -> t +end + +(** Abstract domains representing strings a.k.a. null-terminated char arrays. *) +module type Str = +sig + include S val to_string: t -> t (** Returns an abstract value with at most one null byte marking the end of the string *) - val to_n_string: t -> int -> bool -> t + val to_n_string: t -> int -> t (** [to_n_string index_set n no_null_warn] returns an abstract value with a potential null * byte marking the end of the string and if needed followed by further null bytes to obtain - * an n bytes string. If the resulting value doesn't surely contain a terminating null_byte, - * issue a warning if [no_null_warn] is true. *) + * an n bytes string. *) val to_string_length: t -> idx (** Returns length of string represented by input abstract value *) + val string_copy: t -> t -> int option -> t + (** [string_copy dest src n] returns an abstract value representing the copy of string [src] + * into array [dest], taking at most [n] bytes of [src] if present *) + val string_concat: t -> t -> int option -> t (** [string_concat s1 s2 n] returns a new abstract value representing the string * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of * [s2] if present *) - val substring_extraction: t -> t -> t option - (** [substring_extraction haystack needle] returns None if the string represented by the - * abstract value [needle] surely isn't a substring of [haystack], else Some (top) *) + val substring_extraction: t -> t -> t + (** [substring_extraction haystack needle] returns null if the string represented by the + * abstract value [needle] surely isn't a substring of [haystack], else top *) val string_comparison: t -> t -> int option -> idx (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string * represented by [s1] is less / greater than the one by [s2] or zero if they are equal; * only compares the first [n] bytes if present *) - - val project: ?varAttr:Cil.attributes -> ?typAttr:Cil.attributes -> VDQ.t -> t -> t end module type LatticeWithSmartOps = @@ -93,6 +101,14 @@ sig val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool end +module type LatticeWithNull = +sig + include Lattice.S + val null: unit -> t + val not_null: unit -> t + val is_null: t -> bool +end + module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is taken as a parameter to satisfy the type system, it is not @@ -110,17 +126,17 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va * have a signature that allows for choosing an array representation at runtime. *) -module MustNullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t +(** Like partitioned but additionally manages the length of the array. *) + +module NullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** This functor creates an array representation by the indexes of all null bytes - * the array *surely* contains. This is useful to analyze strings, i.e. null- + * the array must and may contain. This is useful to analyze strings, i.e. null- * terminated char arrays, and particularly to determine if operations on strings * could lead to a buffer overflow. Concrete values from Val are not interesting - * for this domain. + * for this domain. It additionally tracks the array size. *) -module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t -(** Like partitioned but additionally manages the length of the array. *) - module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t (** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. - * Always runs MustNullByte in parallel. *) + * Always runs NullByte in parallel. *) diff --git a/src/util/options.schema.json b/src/util/options.schema.json index 7933b553ac..2ff2e8bf58 100644 --- a/src/util/options.schema.json +++ b/src/util/options.schema.json @@ -677,7 +677,7 @@ "description": "The domain that should be used for arrays. When employing the partition array domain, make sure to enable the expRelation analysis as well. When employing the unrolling array domain, make sure to set the ana.base.arrays.unrolling-factor >0.", "type": "string", - "enum": ["trivial", "partitioned", "unroll", "mustnullbyte"], + "enum": ["trivial", "partitioned", "unroll"], "default": "trivial" }, "unrolling-factor": { From d59b45e6f863204171d02308d549e539c3af9fc6 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 30 May 2023 22:58:15 +0200 Subject: [PATCH 003/233] Added functions for strstr and str(n)cmp to Null Byte Domain --- src/cdomains/arrayDomain.ml | 61 ++++++++++++++++++++++++++++++++++--- 1 file changed, 57 insertions(+), 4 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index c2468e885f..c4d81dfc69 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1353,11 +1353,64 @@ struct (MustNulls.filter (Z.leq (Z.of_int num)) must_nulls_set2, MayNulls.filter (Z.leq (Z.of_int num)) may_nulls_set2) in compute_concat must_nulls_set2' may_nulls_set2' - (* TODO -- can I even do something useful at all? Might as well leave out substring_extraction and string_comparison *) - let substring_extraction _ _ = Some (top ()) + let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = + (* if needle is empty string, i.e. certain null byte at index 0, return haystack as string *) + if MustNulls.mem Z.zero must_nulls_set_needle then + to_string haystack + else + let haystack_len = to_string_length haystack in + let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in + match Idx.maximal haystack_len, Idx.minimal needle_len with + | Some haystack_max, Some needle_min -> + (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return null pointer -- TODO: how to do that? *) + if Z.lt haystack_max needle_min then + (MustNulls.top (), MayNulls.top (), Idx.of_int !Cil.kindOfSizeOf Z.zero) + else + (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + | _ -> (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) - (* TODO *) - let string_comparison _ _ _ = Idx.top_of IInt + let string_comparison (must_nulls_set1, may_nulls_set1, _) (must_nulls_set2, may_nulls_set2, _) = function + (* strcmp *) + | None -> + (* if s1 = s2 = empty string, i.e. certain null byte at index 0, return 0 *) + if MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2) then + Idx.of_int IInt Z.zero + (* if only s1 = empty string, return negative integer *) + else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then + Idx.ending IInt Z.minus_one + (* if only s2 = empty string, return positive integer *) + else if MustNulls.mem Z.zero must_nulls_set2 then + Idx.starting IInt Z.one + else + (* if first null bytes are certain and have different indexes, return integer <> 0 *) + (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) + && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) + && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then + Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) + else + Idx.top_of IInt + with Not_found -> Idx.top_of IInt) + (* strncmp *) + | Some num -> + (* if s1 = empty and s2 = empty string or n = 0, return 0 *) + if MustNulls.mem Z.zero must_nulls_set1 && ((MustNulls.mem Z.zero must_nulls_set2) || Z.equal Z.zero (Z.of_int num)) then + Idx.of_int IInt Z.zero + (* if only s1 = empty string, return negative integer *) + else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then + Idx.ending IInt Z.minus_one + (* if only s2 = empty string, return positive integer *) + else if MustNulls.mem Z.zero must_nulls_set2 then + Idx.starting IInt Z.one + else + (* if first null bytes are certain, have different indexes and are before index n for s2, return integer <> 0 *) + (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) + && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) + && Z.lt (MustNulls.min_elt must_nulls_set2) (Z.of_int num) + && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then + Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) + else + Idx.top_of IInt + with Not_found -> Idx.top_of IInt) let update_length _ x = x From 7a41dc40445df6d29bfc4445a2877b987828b491 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 31 May 2023 11:51:49 +0200 Subject: [PATCH 004/233] First adaptations to AttributeConfiguredArrayDomain --- src/cdomains/arrayDomain.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index c4d81dfc69..3e13080ab0 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -874,7 +874,7 @@ end module type LatticeWithNull = sig - include Lattice.S + include LatticeWithSmartOps val null: unit -> t val not_null: unit -> t val is_null: t -> bool @@ -1186,9 +1186,7 @@ struct (* else return interval [minimal may null, minimal must null] *) else Idx.of_interval !Cil.kindOfSizeOf (MustNulls.min_elt must_nulls_set, MayNulls.min_elt may_nulls_set) - - (* TODO: copy and resize - * filter out any index before size of string src, then union and keep size of dest *) + let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 = function (* strcpy *) | None -> @@ -1417,11 +1415,12 @@ struct let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end -module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = +module AttributeConfiguredArrayDomain(Val: LatticeWithNull) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = struct module P = PartitionedWithLength(Val)(Idx) module T = TrivialWithLength(Val)(Idx) module U = UnrollWithLength(Val)(Idx) + module N = NullByte(Val)(Idx) type idx = Idx.t type value = Val.t @@ -1439,6 +1438,7 @@ struct module I = struct include LatticeFlagHelper (T) (U) (K) let name () = "" end include LatticeFlagHelper (P) (I) (K) + (* include Lattice.Prod (LatticeFlagHelper (P) (I) (K)) (N) *) let domain_of_t = function | (Some p, None) -> PartitionedDomain From f940d01dae2b821937e839016c9cd68bc1e4c61e Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 6 Jun 2023 11:48:54 +0200 Subject: [PATCH 005/233] Finished draft of Null Byte Array Domain --- src/analyses/base.ml | 114 +++--- src/cdomains/arrayDomain.ml | 762 +++++++++++++++++++---------------- src/cdomains/arrayDomain.mli | 43 +- src/cdomains/valueDomain.ml | 30 +- 4 files changed, 544 insertions(+), 405 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 84ff44480d..8d89283e14 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -540,6 +540,8 @@ struct | `Thread _ -> empty (* thread IDs are abstract and nothing known can be reached from them *) | `JmpBuf _ -> empty (* Jump buffers are abstract and nothing known can be reached from them *) | `Mutex -> empty (* mutexes are abstract and nothing known can be reached from them *) + | `NullByte -> empty (* TODO: is this correct? *) + | `NotNullByte -> empty (* TODO: is this correct? *) (* Get the list of addresses accessable immediately from a given address, thus * all pointers within a structure should be considered, but we don't follow @@ -682,6 +684,8 @@ struct | `Thread _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | `JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | `Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) + | `NullByte -> (empty, TS.bot (), false) (* TODO: is this right? *) + | `NotNullByte -> (empty, TS.bot (), false) (* TODO: is this right? *) in reachable_from_value (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) in @@ -2059,19 +2063,6 @@ struct let st: store = ctx.local in let gs = ctx.global in let desc = LF.find f in - let memory_copying dst src = - let dest_a, dest_typ = addr_type_of_exp dst in - let src_lval = mkMem ~addr:(Cil.stripCasts src) ~off:NoOffset in - let src_typ = eval_lv (Analyses.ask_of_ctx ctx) gs st src_lval - |> AD.get_type in - (* when src and destination type coincide, take value from the source, otherwise use top *) - let value = if typeSig dest_typ = typeSig src_typ then - let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) - else - VD.top_value (unrollType dest_typ) - in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value in (* for string functions *) let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) @@ -2087,24 +2078,41 @@ struct (* do nothing if all characters are needed *) | _ -> None in - let string_manipulation s1 s2 lv all op = + let string_manipulation s1 s2 lv all op_addr op_array = let s1_a, s1_typ = addr_type_of_exp s1 in let s2_a, s2_typ = addr_type_of_exp s2 in - match lv, op with - | Some lv_val, Some f -> - (* when whished types coincide, compute result of operation op, otherwise use top *) - let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in - let lv_typ = Cilfacade.typeOfLval lv_val in - if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) - else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) - else - lv_a, lv_typ, (VD.top_value (unrollType lv_typ)) - | _ -> - (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) - let _ = AD.string_writing_defined s1_a in - s1_a, s1_typ, VD.top_value (unrollType s1_typ) + (* compute value in string literals domain if s1 and s2 are both string literals *) + if AD.get_type s1_a = charPtrType && AD.get_type s2_a = charPtrType then + begin match lv, op_addr with + | Some lv_val, Some f -> + (* when whished types coincide, compute result of operation op_addr, otherwise use top *) + let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_typ = Cilfacade.typeOfLval lv_val in + if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) + lv_a, lv_typ, (f s1_a s2_a) + else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) + lv_a, lv_typ, (f s1_a s2_a) + else + lv_a, lv_typ, (VD.top_value (unrollType lv_typ)) + | _ -> + (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) + let _ = AD.string_writing_defined s1_a in + s1_a, s1_typ, VD.top_value (unrollType s1_typ) + end + (* else compute value in array domain *) + else + let eval_dst = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in + let eval_src = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in + match eval_dst, eval_src with + | `Array array_dst, `Array array_src -> + begin match lv with + | Some lv_val -> + let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_typ = Cilfacade.typeOfLval lv_val in + lv_a, lv_typ, op_array array_dst array_src + | None -> s1_a, s1_typ, op_array array_dst array_src + end + | _ -> s1_a, s1_typ, VD.top_value (unrollType s1_typ) in let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> @@ -2126,26 +2134,23 @@ struct let value = VD.zero_init_value dest_typ in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Memcpy { dest = dst; src }, _ -> - memory_copying dst src - (* strcpy(dest, src); *) - | Strcpy { dest = dst; src; n = None }, _ -> let dest_a, dest_typ = addr_type_of_exp dst in - (* when dest surely isn't a string literal, try copying src to dest *) - if AD.string_writing_defined dest_a then - memory_copying dst src - else - (* else return top (after a warning was issued) *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (VD.top_value (unrollType dest_typ)) - (* strncpy(dest, src, n); *) + let src_lval = mkMem ~addr:(Cil.stripCasts src) ~off:NoOffset in + let src_typ = eval_lv (Analyses.ask_of_ctx ctx) gs st src_lval + |> AD.get_type in + (* when src and destination type coincide, take value from the source, otherwise use top *) + let value = if typeSig dest_typ = typeSig src_typ then + let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in + eval_rv (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) + else + VD.top_value (unrollType dest_typ) + in + set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strcpy { dest = dst; src; n }, _ -> - begin match eval_n n with - | Some num -> - let dest_a, dest_typ, value = string_manipulation dst src None false None in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - | None -> failwith "already handled in case above" - end + let dest_a, dest_typ, value = string_manipulation dst src None false None (fun ar1 ar2 -> `Array(CArrays.string_copy ar1 ar2 (eval_n n))) in + set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strcat { dest = dst; src; n }, _ -> - let dest_a, dest_typ, value = string_manipulation dst src None false None in + let dest_a, dest_typ, value = string_manipulation dst src None false None (fun ar1 ar2 -> `Array(CArrays.string_concat ar1 ar2 (eval_n n))) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strlen s, _ -> begin match lv with @@ -2154,7 +2159,16 @@ struct let dest_typ = Cilfacade.typeOfLval lv_val in let lval = mkMem ~addr:(Cil.stripCasts s) ~off:NoOffset in let address = eval_lv (Analyses.ask_of_ctx ctx) gs st lval in - let value = `Int(AD.to_string_length address) in + let value = + (* if s string literal, compute strlen in string literals domain *) + if AD.get_type address = charPtrType then + `Int(AD.to_string_length address) + (* else compute strlen in array domain *) + else + begin match eval_rv (Analyses.ask_of_ctx ctx) gs st s with + | `Array array_s -> `Int(CArrays.to_string_length array_s) + | _ -> VD.top_value (unrollType dest_typ) + end in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end @@ -2164,7 +2178,8 @@ struct (* when haystack, needle and dest type coincide, check if needle is a substring of haystack: if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, else use top *) - let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> `Address(AD.substring_extraction h_a n_a))) in + let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> `Address(AD.substring_extraction h_a n_a))) + (fun h_ar n_ar -> `Array(CArrays.substring_extraction h_ar n_ar)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end @@ -2172,7 +2187,8 @@ struct begin match lv with | Some _ -> (* when s1 and s2 type coincide, compare both both strings completely or their first n characters, otherwise use top *) - let dest_a, dest_typ, value = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> `Int(AD.string_comparison s1_a s2_a (eval_n n)))) in + let dest_a, dest_typ, value = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> `Int(AD.string_comparison s1_a s2_a (eval_n n)))) + (fun s1_ar s2_ar -> `Int(CArrays.string_comparison s1_ar s2_ar (eval_n n))) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 3e13080ab0..287fb90e45 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -8,7 +8,7 @@ module A = Array module BI = IntOps.BigIntOps module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | NullByteDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain (* determines the domain based on variable, type and flag *) let get_domain ~varAttr ~typAttr = @@ -39,14 +39,12 @@ let get_domain ~varAttr ~typAttr = let can_recover_from_top x = x <> TrivialDomain -module type S = +module type SMinusDomain = sig include Lattice.S type idx type value - val domain_of_t: t -> domain - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value val set: VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t val make: ?varAttr:attributes -> ?typAttr:attributes -> idx -> value -> t @@ -64,9 +62,17 @@ sig val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t end +module type S = +sig + include SMinusDomain + + val domain_of_t: t -> domain +end + module type Str = sig - include S + include SMinusDomain + val to_string: t -> t val to_n_string: t -> int -> t val to_string_length: t -> idx @@ -76,6 +82,13 @@ sig val string_comparison: t -> t -> int option -> idx end +module type StrWithDomain = +sig + include Str + + val domain_of_t: t -> domain +end + module type LatticeWithSmartOps = sig include Lattice.S @@ -84,6 +97,13 @@ sig val smart_leq: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> bool end +module type LatticeWithNull = +sig + include LatticeWithSmartOps + val null: unit -> t + val not_null: unit -> t + val is_null: t -> bool +end module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = struct @@ -872,17 +892,9 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end -module type LatticeWithNull = -sig - include LatticeWithSmartOps - val null: unit -> t - val not_null: unit -> t - val is_null: t -> bool -end - -module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = struct - module MustNulls = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "No Nulls" end)) + module MustNulls = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) module MayNulls = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod3 (MustNulls) (MayNulls) (Idx) @@ -891,34 +903,54 @@ struct type idx = Idx.t type value = Val.t - let domain_of_t _ = NullByteDomain - - let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, _, size) (e, i) = + let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = let rec all_indexes_must_null i max = if Z.gt i max then true - else if MustNulls.exists (Z.equal i) must_nulls_set then + else if MustNulls.mem i must_nulls_set then all_indexes_must_null (Z.add i Z.one) max else false in - let min_i = match Idx.minimal i with - | Some min -> - if Z.lt min Z.zero then - Z.zero (* assume worst case minimal index *) + let min interval = match Idx.minimal interval with + | Some min_num -> + if Z.lt min_num Z.zero then + Z.zero (* assume worst case minimal natural number *) else - min - | None -> Z.zero in (* assume worst case minimal index *) + min_num + | None -> Z.zero in (* assume worst case minimal natural number *) + + let min_i = min i in let max_i = Idx.maximal i in + let min_size = min size in (* warn if index is (potentially) out of bounds *) if checkBounds then (array_oob_check (module Idx) (must_nulls_set, size) (e, i)); - match max_i, Idx.minimal size with - (* if there is no maximum number in interval, return top of value *) - | None, _ -> Val.top () - | Some max, Some min_size when Z.geq max Z.zero && Z.lt max min_size -> - (* else only return null if all numbers in interval are in must null index set *) - if all_indexes_must_null min_i max then + match max_i, Idx.maximal size with + (* if there is no maximum value in index interval *) + | None, _ -> + (* ... return not_null if no i >= min_i in may_nulls_set *) + if not (MayNulls.exists (Z.leq min_i) may_nulls_set) then + Val.not_null () + (* ... else return top of value *) + else + Val.top () + (* if there is no maximum size *) + | Some max_i, None when Z.geq max_i Z.zero -> + (* ... and maximum value in index interval < minimal size, return null if all numbers in index interval are in must_nulls_set *) + if Z.lt max_i min_size && all_indexes_must_null min_i max_i then Val.null () + (* ... return not_null if no number in index interval is in may_nulls_set *) + else if not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + Val.not_null () + else + Val.top () + | Some max_i, Some max_size when Z.geq max_i Z.zero -> + (* if maximum value in index interval < minimal size, return null if all numbers in index interval are in must_nulls_set *) + if Z.lt max_i min_size && all_indexes_must_null min_i max_i then + Val.null () + (* if maximum value in index interval < maximal size, return not_null if no number in index interval is in may_nulls_set *) + else if Z.lt max_i max_size && not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + Val.not_null () else Val.top () (* if maximum number in interval is invalid, i.e. negative, return top of value *) @@ -930,112 +962,101 @@ struct may_nulls_set else add_indexes (Z.add i Z.one) max (MayNulls.add i may_nulls_set) in - let rec remove_indexes i max must_nulls_set = - if Z.gt i max then - may_nulls_set - else - remove_indexes (Z.add i Z.one) max (MustNulls.remove i must_nulls_set) in - let min_of_natural_number num = - match Idx.minimal num with - | Some min -> - if Z.lt min Z.zero then - Z.zero (* assume worst case minimal index *) + let min interval = match Idx.minimal interval with + | Some min_num -> + if Z.lt min_num Z.zero then + Z.zero (* assume worst case minimal natural number *) else - min - | None -> Z.zero in (* assume worst case moptionimal index *) - let min_size = min_of_natural_number size in - let min_i = min_of_natural_number i in + min_num + | None -> Z.zero in (* assume worst case minimal natural number *) + + let min_size = min size in + let min_i = min i in let max_i = Idx.maximal i in - (* warn if index is (potentially) out of bounds *) - array_oob_check (module Idx) (must_nulls_set, size) (e, i); - match max_i, Val.is_null v with - (* if no maximum number in interval and value = null, modify may_nulls_set to top = all possible indexes < size *) - | None, true -> (must_nulls_set, MayNulls.top (), size) - (* if no maximum number in interval and value != null, modify must_nulls_set to top = empty set *) - | None, false -> (MustNulls.top (), may_nulls_set, size) - (* if value = null *) - | Some max, true when Z.geq max Z.zero -> - begin match Idx.maximal size with - | Some max_size -> - (* ... and i is exact number < size, add i to must_nulls_set and may_nulls_set *) - if Z.equal min_i max && Z.lt min_i min_size then - (MustNulls.add min_i must_nulls_set, MayNulls.add min_i may_nulls_set, size) - (* ... and i is exact number in size interval, add i only to may_nulls_set *) - else if Z.equal min_i max && Z.lt min_i max_size then - (must_nulls_set, MayNulls.add min_i may_nulls_set, size) - (* ... and i is exact number >= size, warn and return tuple unmodified *) - else if Z.equal min_i max then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (must_nulls_set, may_nulls_set, size)) - (* ... and i is interval with lower bound = 0 and upper bound in size interval, modify may_nulls_set to top *) - else if Z.equal min_i Z.zero && Z.equal max (Z.sub max_size Z.one) then - (must_nulls_set, MayNulls.top (), size) - (* ... and i is interval with lower bound = 0 and upper bound >= size, warn and modify may_nulls_set to top *) - else if Z.equal min_i Z.zero && Z.geq max max_size then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (must_nulls_set, MayNulls.top (), size)) - (* ... and i is interval with lower bound > 0 and upper bound >= size, warn and add all indexes from interval lower bound to size to may_nulls_set *) - else if Z.geq max max_size then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (must_nulls_set, add_indexes min_i max_size may_nulls_set, size)) - (* ... and i is interval with upper bound < size, add all indexes of interval to may_nulls_set*) - else - (must_nulls_set, add_indexes min_i max may_nulls_set, size) - (* ..., size has no upper limit *) - | None -> - (* ... and i is exact number < minimal size, add i to must_nulls_set and may_nulls_set *) - if Z.equal min_i max && Z.lt min_i min_size then - (MustNulls.add min_i must_nulls_set, MayNulls.add min_i may_nulls_set, size) - (* ... and i is exact number >= minimal size, add i to may_nulls_set only *) - else if Z.equal min_i max then - (must_nulls_set, MayNulls.add min_i may_nulls_set, size) - (* ... and i is interval, add all indexes of interval to may_nulls_set *) - else - (must_nulls_set, add_indexes min_i max may_nulls_set, size) - end - (* if value != null *) - | Some max, false when Z.geq max Z.zero -> - begin match Idx.maximal size with + let set_exact i = + match Idx.maximal size with + (* if size has no upper limit *) + | None -> + (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + if Z.lt i min_size && Val.is_null v then + (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (* ..., i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) + else if Z.lt i min_size then + (MustNulls.remove i must_nulls_set, MayNulls.remove i may_nulls_set, size) + (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) + else if Val.is_null v then + (must_nulls_set, MayNulls.add i may_nulls_set, size) + (* ..., i >= minimal size and value <> null, remove i only from must_nulls_set *) + else + (MustNulls.remove i must_nulls_set, may_nulls_set, size) + | Some max_size -> + (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + if Z.lt i min_size && Val.is_null v then + (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (* if i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) + else if Z.lt i min_size then + (MustNulls.remove i must_nulls_set, MayNulls.remove i may_nulls_set, size) + (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) + else if Z.lt i max_size && Val.is_null v then + (must_nulls_set, MayNulls.add i may_nulls_set, size) + (* if minimal size <= i < maximal size and value <> null, remove i only from must_nulls_set *) + else if Z.lt i max_size then + (MustNulls.remove i must_nulls_set, may_nulls_set, size) + (* if i >= maximal size, return tuple unmodified *) + else + (must_nulls_set, may_nulls_set, size) in + + let set_interval_must min_i max_i = + (* if value = null, return must_nulls_set unmodified as not clear which index is set to null *) + if Val.is_null v then + must_nulls_set + (* if value <> null, only keep indexes must_i < minimal index and must_i > maximal index *) + else if Z.equal min_i Z.zero && Z.geq max_i min_size then + MustNulls.top () + else + MustNulls.filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set in + + let set_interval_may min_i max_i = + (* if value <> null, return may_nulls_set unmodified as not clear which index is set to value *) + if not (Val.is_null v) then + may_nulls_set + (* if value = null *) + else + match Idx.maximal size with + (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) + | None -> add_indexes min_i max_i may_nulls_set | Some max_size -> - (* ... and i is exact number < size, remove i from must_nulls_set and may_nulls_set *) - if Z.equal min_i max && Z.lt min_i min_size then - (MustNulls.remove min_i must_nulls_set, MayNulls.remove min_i may_nulls_set, size) - (* ... and i is exact number in size interval, remove i only from must_nulls_set *) - else if Z.equal min_i max && Z.lt min_i max_size then - (MustNulls.remove min_i must_nulls_set, may_nulls_set, size) - (* ... and i is exact number >= size, warn and return tuple unmodified *) - else if Z.equal min_i max then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (must_nulls_set, may_nulls_set, size)) - (* ... and i is interval with lower bound = 0 and upper bound = size, modify must_nulls_set to top *) - else if Z.equal min_i Z.zero && Z.equal max max_size then - (MustNulls.top (), may_nulls_set, size) - (* ... and i is interval with lower bound = 0 and upper bound >= size, warn and modify must_nulls_set to top *) - else if Z.equal min_i Z.zero && Z.geq max max_size then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (MustNulls.top (), may_nulls_set, size)) - (* ... and i is interval with lower bound > 0 and upper bound >= size, warn and remove all indexes from interval lower bound to size from must_nulls_set *) - else if Z.geq max max_size then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Write operation outside of array bounds"; - (remove_indexes min_i max_size must_nulls_set, may_nulls_set, size)) - (* ... and i is interval with upper bound < size, remove all indexes of interval from must_nulls_set *) - else - (remove_indexes min_i max must_nulls_set, may_nulls_set, size) - (* ..., size is unlimited *) - | None -> - (* ... and i is exact number < minimal size, remove i from must_nulls_set and may_nulls_set *) - if Z.equal min_i max && Z.lt min_i min_size then - (MustNulls.remove min_i must_nulls_set, MayNulls.remove min_i may_nulls_set, size) - (* ... and i is exact number >= minimal size, remove i from must_nulls_set only *) - else if Z.equal min_i max then - (MustNulls.remove min_i must_nulls_set, may_nulls_set, size) - (* ... and i is interval, remove all indexes from interval of must_nulls_set *) + (* ... add all indexes < maximal size to may_nulls_set *) + if Z.equal min_i Z.zero && Z.geq max_i max_size then + MayNulls.top () + else if Z.geq max_i max_size then + add_indexes min_i (Z.sub max_size Z.one) may_nulls_set else - (remove_indexes min_i max must_nulls_set, may_nulls_set, size) - end + add_indexes min_i max_i may_nulls_set in + + (* warn if index is (potentially) out of bounds *) + array_oob_check (module Idx) (must_nulls_set, size) (e, i); + match max_i with + (* if no maximum number in index interval *) + | None -> + (* ..., value = null*) + if Val.is_null v && Idx.maximal size = None then + match Idx.maximal size with + (* ... and there is no maximal size, modify may_nulls_set to top *) + | None -> (must_nulls_set, MayNulls.top (), size) + (* ..., add all i from minimal index to maximal size to may_nulls_set *) + | Some max_size -> (must_nulls_set, add_indexes min_i (Z.sub max_size Z.one) may_nulls_set, size) + (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) + else + (MustNulls.filter (Z.gt min_i) must_nulls_set, may_nulls_set, size) + | Some max_i when Z.geq max_i Z.zero -> + if Z.equal min_i max_i then + set_exact min_i + else + (set_interval_must min_i max_i, set_interval_may min_i max_i, size) (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) - | _ -> (must_nulls_set, may_nulls_set, size) + | _ -> (must_nulls_set, may_nulls_set, size) let make ?(varAttr=[]) ?(typAttr=[]) i v = let min_i, max_i = match Idx.minimal i, Idx.maximal i with @@ -1063,10 +1084,10 @@ struct | None, None -> Z.zero, None in match max_i, Val.is_null v with (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) - | Some max, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max)) + | Some max_i, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max_i)) | None, true -> (MustNulls.bot (), MayNulls.top (), Idx.starting !Cil.kindOfSizeOf min_i) - (* if value != null, return (top = no indexes, bot = no indexes, size) *) - | Some max, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max)) + (* if value <> null, return (top = no indexes, bot = no indexes, size) *) + | Some max_i, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max_i)) | None, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting !Cil.kindOfSizeOf min_i) let length (_, _, size) = Some size @@ -1077,14 +1098,13 @@ struct let map f (must_nulls_set, may_nulls_set, size) = (* if f(null) = null, all values in must_nulls_set still are surely null; - * assume top for may_nulls_set as checking effect of for every possible value is unfeasbile*) + * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) if Val.is_null (f (Val.null ())) then (must_nulls_set, MayNulls.top (), size) (* else also return top for must_nulls_set *) else (MustNulls.top (), MayNulls.top (), size) - (* TODO: check there is no smarter implementation -- problem is domain doesn't work on values but Z.t / idx for size *) let fold_left f acc _ = f acc (Val.top ()) let smart_join _ _ = join @@ -1095,12 +1115,12 @@ struct let to_string (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; + (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; (must_nulls_set, may_nulls_set, size)) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; - must_nulls_set, may_nulls_set, size) + (must_nulls_set, may_nulls_set, size)) else let min_must_null = MustNulls.min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) @@ -1111,227 +1131,226 @@ struct (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.add min_must_null Z.one)) let to_n_string (must_nulls_set, may_nulls_set, size) n = - let rec add_indexes i max may_nulls_set = + let rec add_indexes i max set = if Z.geq i max then - may_nulls_set + set else - add_indexes (Z.add i Z.one) max (MayNulls.add i may_nulls_set) in + add_indexes (Z.add i Z.one) max (MayNulls.add i set) in let update_must_indexes min_must_null must_nulls_set = if Z.equal min_must_null Z.zero then MustNulls.bot () else (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) - add_indexes min_must_null (Z.of_int n) (MustNulls.filter (Z.gt (Z.of_int n)) must_nulls_set) in + add_indexes min_must_null (Z.of_int n) must_nulls_set + |> MustNulls.filter (Z.gt (Z.of_int n)) in let update_may_indexes min_may_null may_nulls_set = if Z.equal min_may_null Z.zero then MayNulls.top () else - (* if strlen < n, every byte starting from may_must_null may be transformed to null *) - add_indexes min_may_null (Z.of_int n) (MayNulls.filter (Z.gt (Z.of_int n)) may_nulls_set) in - let warn_no_null min_null = - if Z.geq min_null (Z.of_int n) then - M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" in + (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) + add_indexes min_may_null (Z.of_int n) may_nulls_set + |> MayNulls.filter (Z.gt (Z.of_int n)) in + let warn_no_null min_must_null exists_min_must_null min_may_null = + if Z.geq min_may_null (Z.of_int n) then + M.error "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" + else if (exists_min_must_null && Z.geq min_must_null (Z.of_int n)) || not exists_min_must_null then + M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in if n < 0 then (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) else - let check_n = match Idx.minimal size, Idx.maximal size with - | Some min, Some max -> - if Z.gt (Z.of_int n) max then + ((match Idx.minimal size, Idx.maximal size with + | Some min_size, Some max_size -> + if Z.gt (Z.of_int n) max_size then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - else if Z.gt (Z.of_int n) min then + else if Z.gt (Z.of_int n) min_size then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | Some min, None -> - if Z.gt (Z.of_int n) min then + | Some min_size, None -> + if Z.gt (Z.of_int n) min_size then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | None, Some max -> - if Z.gt (Z.of_int n) max then + | None, Some max_size -> + if Z.gt (Z.of_int n) max_size then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - | None, None -> () in - check_n; + | None, None -> ()); + (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then - match Idx.minimal size with - (* ... there *may* be null bytes from minimal size to n - 1 if minimal size < n *) - | Some min when Z.geq min Z.zero -> (must_nulls_set, add_indexes min (Z.of_int n) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - | _ -> (must_nulls_set, may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - (* if only must_nulls_set empty, remove indexes >= n and add all indexes from min_may_null to n - 1 to may_nulls_set; - * warn if resulting array may not contain null byte *) + (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "Resulting string might not be null-terminated because src doesn't contain a null byte"; + match Idx.maximal size with + (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) + | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + | _ -> (must_nulls_set, may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n))) + (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; + * warn as in any case, resulting array not guaranteed to contain null byte *) else if MustNulls.is_empty must_nulls_set then let min_may_null = MayNulls.min_elt may_nulls_set in - warn_no_null min_may_null; + warn_no_null Z.zero false min_may_null; (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) else let min_must_null = MustNulls.min_elt must_nulls_set in let min_may_null = MayNulls.min_elt may_nulls_set in - warn_no_null min_may_null; - (* if smallest index in sets coincides, remove indexes >= n and add all indexes from min_null to n - 1 to both sets; - * warn if resulting array may not contain null byte *) - if Z.equal min_must_null min_may_null then - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - (* else return empty must_nulls_set, remove indexes >= n and add all indexes from min_may_null to n - 1 to may_nulls_set; - * warn if resulting array may not contain null byte *) - else - (MustNulls.empty (), update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + (* warn if resulting array may not contain null byte *) + warn_no_null min_must_null true min_may_null; + (* remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = - (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) *) + (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with - | Some min -> Idx.starting !Cil.kindOfSizeOf min - | None -> Idx.starting !Cil.kindOfSizeOf Z.zero - (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) *) + | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size + | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustNulls.is_empty must_nulls_set then - Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set) + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; + Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (MustNulls.min_elt must_nulls_set, MayNulls.min_elt may_nulls_set) + Idx.of_interval !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) - let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 = function + let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = + (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) + let update_sets must_nulls_set2 may_nulls_set2 min_len1 min_len2 = + match Idx.minimal size1, Idx.maximal size1, min_len1, min_len2 with + | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> + (if Z.lt max_size1 min_len2 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.lt min_size1 max_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + let must_nulls_set_result = + (* get must nulls from src string < minimal size of dest *) + MustNulls.filter (Z.lt min_size1) must_nulls_set2 + (* and keep indexes of dest >= maximal strlen of src *) + |> MustNulls.union (MustNulls.filter (Z.geq max_len2) must_nulls_set1) in + let may_nulls_set_result = + (* get may nulls from src string < maximal size of dest *) + MayNulls.filter (Z.lt max_size1) may_nulls_set2 + (* and keep indexes of dest >= minimal strlen of src *) + |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min_size1, None, Some min_len2, Some max_len2 -> + (if Z.lt min_size1 max_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + let must_nulls_set_result = + MustNulls.filter (Z.lt min_size1) must_nulls_set2 + |> MustNulls.union (MustNulls.filter (Z.geq max_len2) must_nulls_set1) in + let may_nulls_set_result = + (* get all may nulls from src string as no maximal size of dest *) + may_nulls_set2 + |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min_size1, Some max_size1, Some min_len2, None -> + (if Z.lt max_size1 min_len2 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.lt min_size1 min_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + (* do not keep any index of dest as no maximal strlen of src *) + let must_nulls_set_result = MustNulls.filter (Z.lt min_size1) must_nulls_set2 in + let may_nulls_set_result = + MayNulls.filter (Z.lt max_size1) may_nulls_set2 + |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + (must_nulls_set_result, may_nulls_set_result, size1) + | Some min_size1, None, Some min_len2, None -> + (if Z.lt min_size1 min_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + (* do not keep any index of dest as no maximal strlen of src *) + let must_nulls_set_result = MustNulls.filter (Z.lt min_size1) must_nulls_set2 in + let may_nulls_set_result = + (* get all may nulls from src string as no maximal size of dest *) + may_nulls_set2 + |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + (must_nulls_set_result, may_nulls_set_result, size1) + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (MustNulls.top (), MayNulls.top (), size1) in + + match n with (* strcpy *) | None -> - let must_nulls_set2, may_nulls_set2, size2 = to_string ar2 in + let must_nulls_set2, may_nulls_set2, _ = to_string ar2 in let strlen2 = to_string_length ar2 in - (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) - begin match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen2, Idx.maximal strlen2 with - | Some min1, Some max1, Some min2, Some max2 -> - let warn = - if Z.leq max1 min2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" - else if Z.leq min1 max2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq max2) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in - (must_nulls_set_result, may_nulls_set_result, size1) - | Some min1, None, Some min2, Some max2 -> - let warn = - if Z.leq min1 max2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq max2) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) may_nulls_set2 in - (must_nulls_set_result, may_nulls_set_result, size1) - | Some min1, Some max1, Some min2, None -> - let warn = - if Z.leq max1 min2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" - else if Z.leq min1 min2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.filter (Z.leq min1) must_nulls_set2 in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in - (must_nulls_set_result, may_nulls_set_result, size1) - | Some min1, None, Some min2, None -> - let warn = - if Z.leq min1 min2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.filter (Z.leq min1) must_nulls_set2 in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.gt min2) may_nulls_set1) may_nulls_set2 in - (must_nulls_set_result, may_nulls_set_result, size1) - (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustNulls.top (), MayNulls.top (), size1) - end - (* strncpy => strlen(src) is precise number *) + update_sets must_nulls_set2 may_nulls_set2 (Idx.minimal strlen2) (Idx.maximal strlen2) + (* strncpy = exactly n bytes from src are copied to dest *) | Some n -> let must_nulls_set2, may_nulls_set2, _ = to_n_string ar2 n in - (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) - begin match Idx.minimal size1, Idx.maximal size1 with - | Some min1, Some max1 -> - let warn = - if Z.lt max1 (Z.of_int n) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" - else if Z.lt min1 (Z.of_int n) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq (Z.of_int n)) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set1) (MayNulls.filter (Z.leq max1) may_nulls_set2) in - (must_nulls_set_result, may_nulls_set_result, size1) - | Some min1, None -> - let warn = - if Z.lt min1 (Z.of_int n) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest" in - warn; - let must_nulls_set_result = MustNulls.union (MustNulls.filter (Z.geq (Z.of_int n)) must_nulls_set1) (MustNulls.filter (Z.leq min1) must_nulls_set2) in - let may_nulls_set_result = MayNulls.union (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set1) may_nulls_set2 in - (must_nulls_set_result, may_nulls_set_result, size1) - (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustNulls.top (), MayNulls.top (), size1) - end + update_sets must_nulls_set2 may_nulls_set2 (Some (Z.of_int n)) (Some (Z.of_int n)) let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = - let update_sets min1 max1 max1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = + let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) - let warn = - if max1_exists && ((maxlen1_exists && maxlen2_exists && Z.leq max1 (Z.add maxlen1 maxlen2)) - || (maxlen1_exists && Z.leq max1 (Z.add maxlen1 minlen2)) || (maxlen2_exists && Z.leq max1 (Z.add minlen1 maxlen2)) - || Z.leq max1 (Z.add minlen1 minlen2)) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (maxlen1_exists && maxlen2_exists && Z.leq min1 (Z.add maxlen1 maxlen2)) || (maxlen1_exists && Z.leq min1 (Z.add maxlen1 minlen2)) - || (maxlen2_exists && Z.leq min1 (Z.add minlen1 maxlen2)) || Z.leq min1 (Z.add minlen1 minlen2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest" in - warn; + (if max_size1_exists && Z.lt max_size1 (Z.add minlen1 minlen2) then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" + else if (maxlen1_exists && maxlen2_exists && Z.lt min_size1 (Z.add maxlen1 maxlen2)) + || (maxlen1_exists && Z.lt min_size1 (Z.add maxlen1 minlen2)) + || (maxlen2_exists && Z.lt min_size1 (Z.add minlen1 maxlen2)) + || Z.lt min_size1 (Z.add minlen1 minlen2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set - * and keep indexes > strlen(dest) + strlen(src) of may_nulls_set *) + * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) if MustNulls.is_empty must_nulls_set1 || MustNulls.is_empty must_nulls_set2' then let may_nulls_set_result = - MayNulls.filter (Z.geq (Z.add minlen1 minlen2)) may_nulls_set1 + MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 |> MayNulls.elements |> BatList.cartesian_product (MayNulls.elements may_nulls_set2') |> List.map (fun (i1, i2) -> Z.add i1 i2) |> MayNulls.of_list |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) - |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in (MustNulls.top (), may_nulls_set_result, size1) - (* if minimal must null = minimal may null in ar1 and ar2, add them and keep indexes > strlen(dest) + strlen(src) of ar1 *) - else if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) then + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) + else if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && Z.equal (MustNulls.min_elt must_nulls_set2') (MayNulls.min_elt may_nulls_set2') then let min_i1 = MustNulls.min_elt must_nulls_set1 in let min_i2 = MustNulls.min_elt must_nulls_set2' in let min_i = Z.add min_i1 min_i2 in let must_nulls_set_result = - MustNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 + MustNulls.filter (Z.lt min_i) must_nulls_set1 |> MustNulls.add min_i - |> MustNulls.filter (Z.gt min1) in + |> MustNulls.filter (Z.gt min_size1) in let may_nulls_set_result = - MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 + MayNulls.filter (Z.lt min_i) may_nulls_set1 |> MayNulls.add min_i - |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in (must_nulls_set_result, may_nulls_set_result, size1) - (* else only add all may nulls <= strlen(dest) + strlen(src) *) + (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else let min_i2 = MustNulls.min_elt must_nulls_set2' in + let may_nulls_set2'_until_min_i2 = MayNulls.filter (Z.geq min_i2) may_nulls_set2' in let must_nulls_set_result = MustNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 in let may_nulls_set_result = - MayNulls.filter (Z.geq (Z.add minlen1 minlen2)) may_nulls_set1 - |> MayNulls.map (Z.add min_i2) + MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + |> MayNulls.elements + |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) - |> MayNulls.filter (fun x -> if max1_exists then Z.gt max1 x else true) in + |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in (must_nulls_set_result, may_nulls_set_result, size1) in + let compute_concat must_nulls_set2' may_nulls_set2' = let strlen1 = to_string_length (must_nulls_set1, may_nulls_set1, size1) in let strlen2 = to_string_length (must_nulls_set2', may_nulls_set2', size2) in - begin match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen1, Idx.maximal strlen1, Idx.minimal strlen2, Idx.maximal strlen2 with - | Some min1, Some max1, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> - update_sets min1 max1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' - (* no upper bound for length of concatenation *) - | Some min1, Some max1, Some minlen1, None, Some minlen2, Some _ - | Some min1, Some max1, Some minlen1, Some _, Some minlen2, None - - | Some min1, Some max1, Some minlen1, None, Some minlen2, None -> - update_sets min1 max1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' - (* no upper bound for size of dest *) - | Some min1, None, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> - update_sets min1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' - (* no upper bound for size of dest and length of concatenation *) - | Some min1, None, Some minlen1, None, Some minlen2, Some _ - | Some min1, None, Some minlen1, Some _, Some minlen2, None - | Some min1, None, Some minlen1, None, Some minlen2, None -> - update_sets min1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' - (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustNulls.top (), MayNulls.top (), size1) - end in + match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen1, Idx.maximal strlen1, Idx.minimal strlen2, Idx.maximal strlen2 with + | Some min_size1, Some max_size1, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> + update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for length of concatenation *) + | Some min_size1, Some max_size1, Some minlen1, None, Some minlen2, Some _ + | Some min_size1, Some max_size1, Some minlen1, Some _, Some minlen2, None + | Some min_size1, Some max_size1, Some minlen1, None, Some minlen2, None -> + update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest *) + | Some min_size1, None, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> + update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest and length of concatenation *) + | Some min_size1, None, Some minlen1, None, Some minlen2, Some _ + | Some min_size1, None, Some minlen1, Some _, Some minlen2, None + | Some min_size1, None, Some minlen1, None, Some minlen2, None -> + update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (MustNulls.top (), MayNulls.top (), size1) in match n with (* strcat *) @@ -1339,16 +1358,16 @@ struct let must_nulls_set2', may_nulls_set2', _ = to_string (must_nulls_set2, may_nulls_set2, size2) in compute_concat must_nulls_set2' may_nulls_set2' (* strncat *) - | Some num -> + | Some n -> (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let must_nulls_set2', may_nulls_set2' = let must_nulls_set2, may_nulls_set2, _ = to_string (must_nulls_set2, may_nulls_set2, size2) in - if not (MayNulls.exists (Z.gt (Z.of_int num)) may_nulls_set2) then - (MustNulls.singleton (Z.of_int num), MayNulls.singleton (Z.of_int num)) - else if not (MustNulls.exists (Z.gt (Z.of_int num)) must_nulls_set2) then - (MustNulls.empty (), MayNulls.add (Z.of_int num) (MayNulls.filter (Z.leq (Z.of_int num)) may_nulls_set2)) + if not (MayNulls.exists (Z.gt (Z.of_int n)) may_nulls_set2) then + (MustNulls.singleton (Z.of_int n), MayNulls.singleton (Z.of_int n)) + else if not (MustNulls.exists (Z.gt (Z.of_int n)) must_nulls_set2) then + (MustNulls.empty (), MayNulls.add (Z.of_int n) (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set2)) else - (MustNulls.filter (Z.leq (Z.of_int num)) must_nulls_set2, MayNulls.filter (Z.leq (Z.of_int num)) may_nulls_set2) in + (MustNulls.filter (Z.gt (Z.of_int n)) must_nulls_set2, MayNulls.filter (Z.gt (Z.of_int n)) may_nulls_set2) in compute_concat must_nulls_set2' may_nulls_set2' let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = @@ -1360,67 +1379,93 @@ struct let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in match Idx.maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> - (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return null pointer -- TODO: how to do that? *) + (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return null pointer *) + (* TODO: how to do that? Maybe pass on something I can identify as standing for null_ptr in base, where I plugin null_ptr *) if Z.lt haystack_max needle_min then (MustNulls.top (), MayNulls.top (), Idx.of_int !Cil.kindOfSizeOf Z.zero) else (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) | _ -> (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) - let string_comparison (must_nulls_set1, may_nulls_set1, _) (must_nulls_set2, may_nulls_set2, _) = function + let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let compare n n_exists = + (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) + if (MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2)) + || (n_exists && Z.equal Z.zero n) then + Idx.of_int IInt Z.zero + (* if only s1 = empty string, return negative integer *) + else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then + Idx.ending IInt Z.minus_one + (* if only s2 = empty string, return positive integer *) + else if MustNulls.mem Z.zero must_nulls_set2 then + Idx.starting IInt Z.one + else + (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) + (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set1) n) + && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set2) n) + && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then + Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) + else + Idx.top_of IInt + with Not_found -> Idx.top_of IInt) in + + match n with (* strcmp *) | None -> - (* if s1 = s2 = empty string, i.e. certain null byte at index 0, return 0 *) - if MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2) then - Idx.of_int IInt Z.zero - (* if only s1 = empty string, return negative integer *) - else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then - Idx.ending IInt Z.minus_one - (* if only s2 = empty string, return positive integer *) - else if MustNulls.mem Z.zero must_nulls_set2 then - Idx.starting IInt Z.one - else - (* if first null bytes are certain and have different indexes, return integer <> 0 *) - (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) - && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) - && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then - Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) - else - Idx.top_of IInt - with Not_found -> Idx.top_of IInt) + (* track any potential buffer overflow and issue warning if needed *) + (if MustNulls.is_empty must_nulls_set1 && MayNulls.is_empty may_nulls_set1 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" + else if MustNulls.is_empty must_nulls_set1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); + (if MustNulls.is_empty must_nulls_set2 && MayNulls.is_empty may_nulls_set2 then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" + else if MustNulls.is_empty must_nulls_set2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); + (* compute abstract value for result of strcmp *) + compare Z.zero false (* strncmp *) - | Some num -> - (* if s1 = empty and s2 = empty string or n = 0, return 0 *) - if MustNulls.mem Z.zero must_nulls_set1 && ((MustNulls.mem Z.zero must_nulls_set2) || Z.equal Z.zero (Z.of_int num)) then - Idx.of_int IInt Z.zero - (* if only s1 = empty string, return negative integer *) - else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then - Idx.ending IInt Z.minus_one - (* if only s2 = empty string, return positive integer *) - else if MustNulls.mem Z.zero must_nulls_set2 then - Idx.starting IInt Z.one - else - (* if first null bytes are certain, have different indexes and are before index n for s2, return integer <> 0 *) - (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) - && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) - && Z.lt (MustNulls.min_elt must_nulls_set2) (Z.of_int num) - && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then - Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) - else - Idx.top_of IInt - with Not_found -> Idx.top_of IInt) + | Some n -> + if n < 0 then + Idx.top_of IInt + else + let min_size1 = match Idx.minimal size1 with + | Some min_size1 -> min_size1 + | None -> Z.zero in + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in + (* issue a warning if n is (potentially) smaller than array sizes *) + (match Idx.maximal size1 with + | Some max_size1 -> + if Z.gt (Z.of_int n) max_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 is smaller than n bytes" + else if Z.gt (Z.of_int n) min_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes" + | None -> + if Z.gt (Z.of_int n) min_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes"); + (match Idx.maximal size2 with + | Some max_size2 -> + if Z.gt (Z.of_int n) max_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 is smaller than n bytes" + else if Z.gt (Z.of_int n) min_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes" + | None -> + if Z.gt (Z.of_int n) min_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes"); + (* compute abstract value for result of strncmp *) + compare (Z.of_int n) true - let update_length _ x = x + let update_length new_size (must_nulls_set, may_nulls_set, size) = (must_nulls_set, may_nulls_set, new_size) let project ?(varAttr=[]) ?(typAttr=[]) _ t = t end -module AttributeConfiguredArrayDomain(Val: LatticeWithNull) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = +module FlagHelperAttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = struct module P = PartitionedWithLength(Val)(Idx) module T = TrivialWithLength(Val)(Idx) module U = UnrollWithLength(Val)(Idx) - module N = NullByte(Val)(Idx) type idx = Idx.t type value = Val.t @@ -1438,7 +1483,6 @@ struct module I = struct include LatticeFlagHelper (T) (U) (K) let name () = "" end include LatticeFlagHelper (P) (I) (K) - (* include Lattice.Prod (LatticeFlagHelper (P) (I) (K)) (N) *) let domain_of_t = function | (Some p, None) -> PartitionedDomain @@ -1470,7 +1514,7 @@ struct let smart_widen f g = binop_to_t' (P.smart_widen f g) (T.smart_widen f g) (U.smart_widen f g) let smart_leq f g = binop' (P.smart_leq f g) (T.smart_leq f g) (U.smart_leq f g) let update_length newl x = unop_to_t' (P.update_length newl) (T.update_length newl) (U.update_length newl) x - let name () = "AttributeConfiguredArrayDomain" + let name () = "FlagHelperAttributeConfiguredArrayDomain" let bot () = to_t @@ match get_domain ~varAttr:[] ~typAttr:[] with | PartitionedDomain -> (Some (P.bot ()), None, None) @@ -1532,3 +1576,41 @@ struct | UnrolledDomain, (None, Some (None, Some x)) -> to_t @@ (None, None, Some x) | _ -> failwith "AttributeConfiguredArrayDomain received a value where not exactly one component is set" end + +module AttributeConfiguredArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t = +struct + module F = FlagHelperAttributeConfiguredArrayDomain (Val) (Idx) + module N = NullByte (Val) (Idx) + + include Lattice.Prod (F) (N) + + let name () = "AttributeConfiguredArrayDomain" + type idx = Idx.t + type value = Val.t + + let domain_of_t (t_f, _) = F.domain_of_t t_f + + let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = Val.meet (F.get ask t_f i) (N.get ask t_n i) + let set (ask:VDQ.t) (t_f, t_n) i v = (F.set ask t_f i v, N.set ask t_n i v) + let make ?(varAttr=[]) ?(typAttr=[]) i v = (F.make i v, N.make i v) + let length (_, t_n) = N.length t_n + let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (F.move_if_affected ask t_f v f, N.move_if_affected ask t_n v f) + let get_vars_in_e (t_f, _) = F.get_vars_in_e t_f + let map f (t_f, t_n) = (F.map f t_f, N.map f t_n) + let fold_left f acc (t_f, t_n) = F.fold_left f acc t_f + + let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) + let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) + let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 + + let to_string (_, t_n) = (F.top (), N.to_string t_n) + let to_n_string (_, t_n) n = (F.top (), N.to_n_string t_n n) + let to_string_length (_, t_n) = N.to_string_length t_n + let string_copy (_, t_n1) (_, t_n2) n = (F.top (), N.string_copy t_n1 t_n2 n) + let string_concat (_, t_n1) (_, t_n2) n = (F.top (), N.string_concat t_n1 t_n2 n) + let substring_extraction (_, t_n1) (_, t_n2) = (F.top (), N.substring_extraction t_n1 t_n2) + let string_comparison (_, t_n1) (_, t_n2) n = N.string_comparison t_n1 t_n2 n + + let update_length newl (t_f, t_n) = (F.update_length newl t_f, N.update_length newl t_n) + let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ask t_f, N.project ask t_n) +end diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 5df3679cfa..cd22a6a68b 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -2,7 +2,7 @@ open IntOps open GoblintCil module VDQ = ValueDomainQueries -type domain = TrivialDomain | PartitionedDomain | UnrolledDomain | NullByteDomain +type domain = TrivialDomain | PartitionedDomain | UnrolledDomain val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain (** gets the underlying domain: chosen by the attributes in AttributeConfiguredArrayDomain *) @@ -10,8 +10,7 @@ val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain val can_recover_from_top: domain -> bool (** Some domains such as Trivial cannot recover from their value ever being top. {!ValueDomain} handles intialization differently for these *) -(** Abstract domains representing arrays. *) -module type S = +module type SMinusDomain = sig include Lattice.S type idx @@ -20,9 +19,6 @@ sig type value (** The abstract domain of values stored in the array. *) - val domain_of_t: t -> domain - (* Returns the domain used for the array*) - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value (** Returns the element residing at the given index. *) @@ -58,17 +54,26 @@ sig val project: ?varAttr:Cil.attributes -> ?typAttr:Cil.attributes -> VDQ.t -> t -> t end +(** Abstract domains representing arrays. *) +module type S = +sig + include SMinusDomain + + val domain_of_t: t -> domain + (* Returns the domain used for the array*) +end + (** Abstract domains representing strings a.k.a. null-terminated char arrays. *) module type Str = sig - include S + include SMinusDomain val to_string: t -> t (** Returns an abstract value with at most one null byte marking the end of the string *) val to_n_string: t -> int -> t - (** [to_n_string index_set n no_null_warn] returns an abstract value with a potential null - * byte marking the end of the string and if needed followed by further null bytes to obtain + (** [to_n_string index_set n] returns an abstract value with a potential null byte + * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) val to_string_length: t -> idx @@ -93,6 +98,14 @@ sig * only compares the first [n] bytes if present *) end +module type StrWithDomain = +sig + include Str + + val domain_of_t: t -> domain + (* Returns the domain used for the array*) +end + module type LatticeWithSmartOps = sig include Lattice.S @@ -103,7 +116,7 @@ end module type LatticeWithNull = sig - include Lattice.S + include LatticeWithSmartOps val null: unit -> t val not_null: unit -> t val is_null: t -> bool @@ -129,7 +142,7 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Like partitioned but additionally manages the length of the array. *) -module NullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): SMinusDomain with type value = Val.t and type idx = Idx.t (** This functor creates an array representation by the indexes of all null bytes * the array must and may contain. This is useful to analyze strings, i.e. null- * terminated char arrays, and particularly to determine if operations on strings @@ -137,6 +150,8 @@ module NullByte (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t a * for this domain. It additionally tracks the array size. *) -module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t -(** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. - * Always runs NullByte in parallel. *) +module FlagHelperAttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +(** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) + +module AttributeConfiguredArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t +(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte in parallel. *) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 882b66859e..1826602b29 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -35,6 +35,10 @@ sig val is_top_value: t -> typ -> bool val zero_init_value: ?varAttr:attributes -> typ -> t + val null: unit -> t + val not_null: unit -> t + val is_null: t -> bool + val project: VDQ.t -> int_precision option-> ( attributes * attributes ) option -> t -> t val mark_jmpbufs_as_copied: t -> t end @@ -85,6 +89,8 @@ module rec Compound: S with type t = [ | `Thread of Threads.t | `JmpBuf of JmpBufs.t | `Mutex + | `NullByte + | `NotNullByte | `Bot ] and type offs = (fieldinfo,IndexDomain.t) Lval.offs = struct @@ -100,6 +106,8 @@ struct | `Thread of Threads.t | `JmpBuf of JmpBufs.t | `Mutex + | `NullByte + | `NotNullByte | `Bot ] [@@deriving eq, ord, hash] @@ -153,6 +161,8 @@ struct | `Thread x -> Threads.is_bot x | `JmpBuf x -> JmpBufs.is_bot x | `Mutex -> true + | `NullByte -> true (* TODO: is this correct? *) + | `NotNullByte -> true (* TODO: is this correct? *) | `Bot -> true | `Top -> false @@ -203,6 +213,8 @@ struct | `Thread x -> Threads.is_top x | `JmpBuf x -> JmpBufs.is_top x | `Mutex -> true + | `NullByte -> true + | `NotNullByte -> true | `Top -> true | `Bot -> false @@ -233,7 +245,7 @@ struct | _ -> `Top let tag_name : t -> string = function - | `Top -> "Top" | `Int _ -> "Int" | `Float _ -> "Float" | `Address _ -> "Address" | `Struct _ -> "Struct" | `Union _ -> "Union" | `Array _ -> "Array" | `Blob _ -> "Blob" | `Thread _ -> "Thread" | `Mutex -> "Mutex" | `JmpBuf _ -> "JmpBuf" | `Bot -> "Bot" + | `Top -> "Top" | `Int _ -> "Int" | `Float _ -> "Float" | `Address _ -> "Address" | `Struct _ -> "Struct" | `Union _ -> "Union" | `Array _ -> "Array" | `Blob _ -> "Blob" | `Thread _ -> "Thread" | `Mutex -> "Mutex" | `NullByte -> "NullByte" | `NotNullByte -> "NotNullByte" | `JmpBuf _ -> "JmpBuf" | `Bot -> "Bot" include Printable.Std let name () = "compound" @@ -248,6 +260,10 @@ struct let is_top x = x = `Top let top_name = "Unknown" + let null () = `NullByte + let not_null () = `NotNullByte + let is_null x = x = `NullByte + let pretty () state = match state with | `Int n -> ID.pretty () n @@ -260,6 +276,8 @@ struct | `Thread n -> Threads.pretty () n | `JmpBuf n -> JmpBufs.pretty () n | `Mutex -> text "mutex" + | `NullByte -> text "null-byte" + | `NotNullByte -> text "not-null-byte" | `Bot -> text bot_name | `Top -> text top_name @@ -275,6 +293,8 @@ struct | `Thread n -> Threads.show n | `JmpBuf n -> JmpBufs.show n | `Mutex -> "mutex" + | `NullByte -> "null-byte" + | `NotNullByte -> "not-null-byte" | `Bot -> bot_name | `Top -> top_name @@ -1131,6 +1151,8 @@ struct | `Thread n -> Threads.printXml f n | `JmpBuf n -> JmpBufs.printXml f n | `Mutex -> BatPrintf.fprintf f "\n\nmutex\n\n\n" + | `NullByte -> BatPrintf.fprintf f "\n\nnull-byte\n\n\n" + | `NotNullByte -> BatPrintf.fprintf f "\n\nnot-null-byte\n\n\n" | `Bot -> BatPrintf.fprintf f "\n\nbottom\n\n\n" | `Top -> BatPrintf.fprintf f "\n\ntop\n\n\n" @@ -1145,6 +1167,8 @@ struct | `Thread n -> Threads.to_yojson n | `JmpBuf n -> JmpBufs.to_yojson n | `Mutex -> `String "mutex" + | `NullByte -> `String "null-byte" + | `NotNullByte -> `String "not-null-byte" | `Bot -> `String "⊥" | `Top -> `String "⊤" @@ -1198,6 +1222,8 @@ struct | `Thread n -> `Thread (Threads.relift n) | `JmpBuf n -> `JmpBuf (JmpBufs.relift n) | `Mutex -> `Mutex + | `NullByte -> `NullByte + | `NotNullByte -> `NotNullByte | `Bot -> `Bot | `Top -> `Top end @@ -1208,7 +1234,7 @@ and Structs: StructDomain.S with type field = fieldinfo and type value = Compoun and Unions: UnionDomain.S with type t = UnionDomain.Field.t * Compound.t and type value = Compound.t = UnionDomain.Simple (Compound) -and CArrays: ArrayDomain.S with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredArrayDomain(Compound)(ArrIdxDomain) +and CArrays: ArrayDomain.StrWithDomain with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredArrayDomain(Compound)(ArrIdxDomain) and Blobs: Blob with type size = ID.t and type value = Compound.t and type origin = ZeroInit.t = Blob (Compound) (ID) From a912463b2780fe4256cd82efb421cdf96f0a526d Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 6 Jun 2023 16:25:32 +0200 Subject: [PATCH 006/233] Addressed github-code-scanning suggestions --- src/cdomains/arrayDomain.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 98a981f63b..3f6dcdce7f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -991,7 +991,7 @@ struct if Z.gt i max then true else if MustNulls.mem i must_nulls_set then - all_indexes_must_null (Z.add i Z.one) max + all_indexes_must_null (Z.succ i) max else false in let min interval = match Idx.minimal interval with @@ -1044,7 +1044,7 @@ struct if Z.gt i max then may_nulls_set else - add_indexes (Z.add i Z.one) max (MayNulls.add i may_nulls_set) in + add_indexes (Z.succ i) max (MayNulls.add i may_nulls_set) in let min interval = match Idx.minimal interval with | Some min_num -> if Z.lt min_num Z.zero then @@ -1114,7 +1114,7 @@ struct if Z.equal min_i Z.zero && Z.geq max_i max_size then MayNulls.top () else if Z.geq max_i max_size then - add_indexes min_i (Z.sub max_size Z.one) may_nulls_set + add_indexes min_i (Z.pred max_size) may_nulls_set else add_indexes min_i max_i may_nulls_set in @@ -1129,7 +1129,7 @@ struct (* ... and there is no maximal size, modify may_nulls_set to top *) | None -> (must_nulls_set, MayNulls.top (), size) (* ..., add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> (must_nulls_set, add_indexes min_i (Z.sub max_size Z.one) may_nulls_set, size) + | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else (MustNulls.filter (Z.gt min_i) must_nulls_set, may_nulls_set, size) @@ -1208,17 +1208,17 @@ struct let min_must_null = MustNulls.min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) if Z.equal min_must_null (MayNulls.min_elt may_nulls_set) then - (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int !Cil.kindOfSizeOf (Z.add min_must_null Z.one)) + (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int !Cil.kindOfSizeOf (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else - (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.add min_must_null Z.one)) + (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.succ min_must_null)) let to_n_string (must_nulls_set, may_nulls_set, size) n = let rec add_indexes i max set = if Z.geq i max then set else - add_indexes (Z.add i Z.one) max (MayNulls.add i set) in + add_indexes (Z.succ i) max (MayNulls.add i set) in let update_must_indexes min_must_null must_nulls_set = if Z.equal min_must_null Z.zero then MustNulls.bot () From fb65c1cb2c0fb6a4075e71dc9a965ec49339f955 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 8 Jun 2023 12:38:15 +0200 Subject: [PATCH 007/233] Fixed integration of domain for base analysis - Updated null recognition in Compound of valueDomain - strstr analysis can now detect NULL ptr - fixed get of AttributeConfiguredArrayDomain --- src/analyses/base.ml | 8 ++- src/cdomains/arrayDomain.ml | 96 ++++++++++++++++++++++-------------- src/cdomains/arrayDomain.mli | 38 +++++++------- src/cdomains/valueDomain.ml | 38 ++++++-------- 4 files changed, 98 insertions(+), 82 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0ce42d48ae..9c5ea89f34 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -532,8 +532,6 @@ struct | Thread _ -> empty (* thread IDs are abstract and nothing known can be reached from them *) | JmpBuf _ -> empty (* Jump buffers are abstract and nothing known can be reached from them *) | Mutex -> empty (* mutexes are abstract and nothing known can be reached from them *) - | NullByte -> empty (* TODO: is this correct? *) - | NotNullByte -> empty (* TODO: is this correct? *) (* Get the list of addresses accessable immediately from a given address, thus * all pointers within a structure should be considered, but we don't follow @@ -664,8 +662,6 @@ struct | Thread _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) - | NullByte -> (empty, TS.bot (), false) (* TODO: is this right? *) - | NotNullByte -> (empty, TS.bot (), false) (* TODO: is this right? *) in reachable_from_value (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) in @@ -2135,7 +2131,9 @@ struct if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, else use top *) let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) - (fun h_ar n_ar -> Array(CArrays.substring_extraction h_ar n_ar)) in + (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with + | Some ar -> Array(ar) + | None -> Address(AD.null_ptr)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 3f6dcdce7f..64b4808aa0 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -39,13 +39,12 @@ let get_domain ~varAttr ~typAttr = let can_recover_from_top x = x <> TrivialDomain -module type SMinusDomain = +module type SMinusDomainAndRet = sig include Lattice.S type idx type value - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value val set: VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t val make: ?varAttr:attributes -> ?typAttr:attributes -> idx -> value -> t val length: t -> idx option @@ -65,21 +64,24 @@ end module type S = sig - include SMinusDomain + include SMinusDomainAndRet val domain_of_t: t -> domain + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end module type Str = sig - include SMinusDomain + include SMinusDomainAndRet + + type ret = Null | NotNull | Top + + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret - val to_string: t -> t - val to_n_string: t -> int -> t val to_string_length: t -> idx val string_copy: t -> t -> int option -> t val string_concat: t -> t -> int option -> t - val substring_extraction: t -> t -> t + val substring_extraction: t -> t -> t option val string_comparison: t -> t -> int option -> idx end @@ -88,6 +90,7 @@ sig include Str val domain_of_t: t -> domain + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end module type LatticeWithSmartOps = @@ -101,9 +104,14 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps + val null: unit -> t val not_null: unit -> t val is_null: t -> bool + + val is_int_ikind: t -> Cil.ikind option + val zero_of_ikind: Cil.ikind -> t + val not_zero_of_ikind: Cil.ikind -> t end module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = @@ -986,6 +994,8 @@ struct type idx = Idx.t type value = Val.t + type ret = Null | NotNull | Top + let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = let rec all_indexes_must_null i max = if Z.gt i max then @@ -1011,33 +1021,33 @@ struct match max_i, Idx.maximal size with (* if there is no maximum value in index interval *) | None, _ -> - (* ... return not_null if no i >= min_i in may_nulls_set *) + (* ... return NotNull if no i >= min_i in may_nulls_set *) if not (MayNulls.exists (Z.leq min_i) may_nulls_set) then - Val.not_null () - (* ... else return top of value *) + NotNull + (* ... else return Top *) else - Val.top () + Top (* if there is no maximum size *) | Some max_i, None when Z.geq max_i Z.zero -> - (* ... and maximum value in index interval < minimal size, return null if all numbers in index interval are in must_nulls_set *) + (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) if Z.lt max_i min_size && all_indexes_must_null min_i max_i then - Val.null () - (* ... return not_null if no number in index interval is in may_nulls_set *) + Null + (* ... return NotNull if no number in index interval is in may_nulls_set *) else if not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then - Val.not_null () + NotNull else - Val.top () + Top | Some max_i, Some max_size when Z.geq max_i Z.zero -> - (* if maximum value in index interval < minimal size, return null if all numbers in index interval are in must_nulls_set *) + (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) if Z.lt max_i min_size && all_indexes_must_null min_i max_i then - Val.null () - (* if maximum value in index interval < maximal size, return not_null if no number in index interval is in may_nulls_set *) + Null + (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) else if Z.lt max_i max_size && not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then - Val.not_null () + NotNull else - Val.top () - (* if maximum number in interval is invalid, i.e. negative, return top of value *) - | _ -> Val.top () + Top + (* if maximum number in interval is invalid, i.e. negative, return Top of value *) + | _ -> Top let set (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) v = let rec add_indexes i max may_nulls_set = @@ -1195,6 +1205,8 @@ struct let smart_leq _ _ = leq (* string functions *) + + (** Returns an abstract value with at most one null byte marking the end of the string *) let to_string (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then @@ -1213,6 +1225,9 @@ struct else (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.succ min_must_null)) + (** [to_n_string index_set n] returns an abstract value with a potential null byte + * marking the end of the string and if needed followed by further null bytes to obtain + * an n bytes string. *) let to_n_string (must_nulls_set, may_nulls_set, size) n = let rec add_indexes i max set = if Z.geq i max then @@ -1456,19 +1471,18 @@ struct let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = (* if needle is empty string, i.e. certain null byte at index 0, return haystack as string *) if MustNulls.mem Z.zero must_nulls_set_needle then - to_string haystack + Some (to_string haystack) else let haystack_len = to_string_length haystack in let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in match Idx.maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> - (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return null pointer *) - (* TODO: how to do that? Maybe pass on something I can identify as standing for null_ptr in base, where I plugin null_ptr *) + (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) if Z.lt haystack_max needle_min then - (MustNulls.top (), MayNulls.top (), Idx.of_int !Cil.kindOfSizeOf Z.zero) + None else - (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) - | _ -> (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + Some (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + | _ -> Some (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let compare n n_exists = @@ -1487,7 +1501,7 @@ struct (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set1) n) && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set2) n) && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then - Idx.join (Idx.ending IInt Z.minus_one) (Idx.starting IInt Z.one) + Idx.of_excl_list IInt [Z.zero] else Idx.top_of IInt with Not_found -> Idx.top_of IInt) in @@ -1543,8 +1557,7 @@ struct let project ?(varAttr=[]) ?(typAttr=[]) _ t = t - (* TODO: what am I supposed to do here? *) - let invariant ~value_invariant ~offset ~lval x = failwith "TODO" + let invariant ~value_invariant ~offset ~lval x = Invariant.none end module FlagHelperAttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = @@ -1680,9 +1693,17 @@ struct type idx = Idx.t type value = Val.t + type ret = Null | NotNull | Top + let domain_of_t (t_f, _) = F.domain_of_t t_f - let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = Val.meet (F.get ask t_f i) (N.get ask t_n i) + let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = + let f_get = F.get ask t_f i in + let n_get = N.get ask t_n i in + match Val.is_int_ikind f_get, n_get with + | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) + | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) + | _ -> f_get let set (ask:VDQ.t) (t_f, t_n) i v = (F.set ask t_f i v, N.set ask t_n i v) let make ?(varAttr=[]) ?(typAttr=[]) i v = (F.make i v, N.make i v) let length (_, t_n) = N.length t_n @@ -1695,16 +1716,15 @@ struct let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 - let to_string (_, t_n) = (F.top (), N.to_string t_n) - let to_n_string (_, t_n) n = (F.top (), N.to_n_string t_n n) let to_string_length (_, t_n) = N.to_string_length t_n let string_copy (_, t_n1) (_, t_n2) n = (F.top (), N.string_copy t_n1 t_n2 n) let string_concat (_, t_n1) (_, t_n2) n = (F.top (), N.string_concat t_n1 t_n2 n) - let substring_extraction (_, t_n1) (_, t_n2) = (F.top (), N.substring_extraction t_n1 t_n2) + let substring_extraction (_, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with + | Some res -> Some (F.top (), res) + | None -> None let string_comparison (_, t_n1) (_, t_n2) n = N.string_comparison t_n1 t_n2 n let update_length newl (t_f, t_n) = (F.update_length newl t_f, N.update_length newl t_n) let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ask t_f, N.project ask t_n) - (* TODO: what should I do here? *) - let invariant ~value_invariant ~offset ~lval x = failwith "TODO" + let invariant ~value_invariant ~offset ~lval (t_f, _) = F.invariant ~value_invariant ~offset ~lval t_f end diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index f5da9c4d35..b62e65ea60 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -12,7 +12,7 @@ val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain val can_recover_from_top: domain -> bool (** Some domains such as Trivial cannot recover from their value ever being top. {!ValueDomain} handles intialization differently for these *) -module type SMinusDomain = +module type SMinusDomainAndRet = sig include Lattice.S type idx @@ -21,9 +21,6 @@ sig type value (** The abstract domain of values stored in the array. *) - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value - (** Returns the element residing at the given index. *) - val set: VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t (** Returns a new abstract value, where the given index is replaced with the * given element. *) @@ -60,24 +57,24 @@ end (** Abstract domains representing arrays. *) module type S = sig - include SMinusDomain + include SMinusDomainAndRet val domain_of_t: t -> domain (* Returns the domain used for the array*) + + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value + (** Returns the element residing at the given index. *) end (** Abstract domains representing strings a.k.a. null-terminated char arrays. *) module type Str = sig - include SMinusDomain + include SMinusDomainAndRet - val to_string: t -> t - (** Returns an abstract value with at most one null byte marking the end of the string *) + type ret = Null | NotNull | Top - val to_n_string: t -> int -> t - (** [to_n_string index_set n] returns an abstract value with a potential null byte - * marking the end of the string and if needed followed by further null bytes to obtain - * an n bytes string. *) + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + (* overwrites get of module S *) val to_string_length: t -> idx (** Returns length of string represented by input abstract value *) @@ -91,9 +88,10 @@ sig * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of * [s2] if present *) - val substring_extraction: t -> t -> t - (** [substring_extraction haystack needle] returns null if the string represented by the - * abstract value [needle] surely isn't a substring of [haystack], else top *) + val substring_extraction: t -> t -> t option + (** [substring_extraction haystack needle] returns None if the string represented by the + * abstract value [needle] surely isn't a substring of [haystack], Some [to_string haystack] + * if [needle] is empty the empty string, else Some top *) val string_comparison: t -> t -> int option -> idx (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string @@ -106,7 +104,8 @@ sig include Str val domain_of_t: t -> domain - (* Returns the domain used for the array*) + (* Returns the domain used for the array *) + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end module type LatticeWithSmartOps = @@ -120,9 +119,14 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps + val null: unit -> t val not_null: unit -> t val is_null: t -> bool + + val is_int_ikind: t -> Cil.ikind option + val zero_of_ikind: Cil.ikind -> t + val not_zero_of_ikind: Cil.ikind -> t end module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t @@ -145,7 +149,7 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Like partitioned but additionally manages the length of the array. *) -module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): SMinusDomain with type value = Val.t and type idx = Idx.t +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): SMinusDomainAndRet with type value = Val.t and type idx = Idx.t (** This functor creates an array representation by the indexes of all null bytes * the array must and may contain. This is useful to analyze strings, i.e. null- * terminated char arrays, and particularly to determine if operations on strings diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index d8e81032ca..8846a5be1f 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -42,6 +42,10 @@ sig val not_null: unit -> t val is_null: t -> bool + val is_int_ikind: t -> Cil.ikind option + val zero_of_ikind: Cil.ikind -> t + val not_zero_of_ikind: Cil.ikind -> t + val project: VDQ.t -> int_precision option-> ( attributes * attributes ) option -> t -> t val mark_jmpbufs_as_copied: t -> t end @@ -94,8 +98,6 @@ module rec Compound: sig | JmpBuf of JmpBufs.t | Mutex | MutexAttr of MutexAttrDomain.t - | NullByte - | NotNullByte | Bot include S with type t := t and type offs = IndexDomain.t Offset.t end = @@ -113,8 +115,6 @@ struct | JmpBuf of JmpBufs.t | Mutex | MutexAttr of MutexAttrDomain.t - | NullByte - | NotNullByte | Bot [@@deriving eq, ord, hash] @@ -173,8 +173,6 @@ struct | JmpBuf x -> JmpBufs.is_bot x | Mutex -> true | MutexAttr x -> MutexAttr.is_bot x - | NullByte -> true - | NotNullByte -> true | Bot -> true | Top -> false @@ -228,8 +226,6 @@ struct | MutexAttr x -> MutexAttr.is_top x | JmpBuf x -> JmpBufs.is_top x | Mutex -> true - | NullByte -> true - | NotNullByte -> true | Top -> true | Bot -> false @@ -261,7 +257,7 @@ struct | _ -> Top let tag_name : t -> string = function - | Top -> "Top" | Int _ -> "Int" | Float _ -> "Float" | Address _ -> "Address" | Struct _ -> "Struct" | Union _ -> "Union" | Array _ -> "Array" | Blob _ -> "Blob" | Thread _ -> "Thread" | Mutex -> "Mutex" | MutexAttr _ -> "MutexAttr" | NullByte -> "NullByte" | NotNullByte -> "NotNullByte" | JmpBuf _ -> "JmpBuf" | Bot -> "Bot" + | Top -> "Top" | Int _ -> "Int" | Float _ -> "Float" | Address _ -> "Address" | Struct _ -> "Struct" | Union _ -> "Union" | Array _ -> "Array" | Blob _ -> "Blob" | Thread _ -> "Thread" | Mutex -> "Mutex" | MutexAttr _ -> "MutexAttr" | JmpBuf _ -> "JmpBuf" | Bot -> "Bot" include Printable.Std let name () = "compound" @@ -275,9 +271,17 @@ struct let is_top x = x = Top let top_name = "Unknown" - let null () = NullByte - let not_null () = NotNullByte - let is_null x = x = NullByte + let null () = Int(ID.of_int IChar Z.zero) + let not_null () = Top + let is_null = function + | Int n -> ID.to_int n = Some Z.zero + | _ -> false + + let is_int_ikind = function + | Int n -> Some (ID.ikind n) + | _ -> None + let zero_of_ikind ik = Int(ID.of_int ik Z.zero) + let not_zero_of_ikind ik = Int(ID.of_excl_list ik [Z.zero]) let pretty () state = match state with @@ -292,8 +296,6 @@ struct | MutexAttr n -> MutexAttr.pretty () n | JmpBuf n -> JmpBufs.pretty () n | Mutex -> text "mutex" - | NullByte -> text "null-byte" - | NotNullByte -> text "not-null-byte" | Bot -> text bot_name | Top -> text top_name @@ -310,8 +312,6 @@ struct | JmpBuf n -> JmpBufs.show n | Mutex -> "mutex" | MutexAttr x -> MutexAttr.show x - | NullByte -> "null-byte" - | NotNullByte -> "not-null-byte" | Bot -> bot_name | Top -> top_name @@ -1175,8 +1175,6 @@ struct | MutexAttr n -> MutexAttr.printXml f n | JmpBuf n -> JmpBufs.printXml f n | Mutex -> BatPrintf.fprintf f "\n\nmutex\n\n\n" - | NullByte -> BatPrintf.fprintf f "\n\nnull-byte\n\n\n" - | NotNullByte -> BatPrintf.fprintf f "\n\nnot-null-byte\n\n\n" | Bot -> BatPrintf.fprintf f "\n\nbottom\n\n\n" | Top -> BatPrintf.fprintf f "\n\ntop\n\n\n" @@ -1192,8 +1190,6 @@ struct | MutexAttr n -> MutexAttr.to_yojson n | JmpBuf n -> JmpBufs.to_yojson n | Mutex -> `String "mutex" - | NullByte -> `String "null-byte" - | NotNullByte -> `String "not-null-byte" | Bot -> `String "⊥" | Top -> `String "⊤" @@ -1244,8 +1240,6 @@ struct | JmpBuf n -> JmpBuf (JmpBufs.relift n) | MutexAttr n -> MutexAttr (MutexAttr.relift n) | Mutex -> Mutex - | NullByte -> NullByte - | NotNullByte -> NotNullByte | Bot -> Bot | Top -> Top end From b49a043538d4f5d27a451c44d61792714983b86a Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 8 Jun 2023 15:08:11 +0200 Subject: [PATCH 008/233] Fixed incompatible ikinds: changed !Cil.kindOfSizeOf to ILong --- src/analyses/base.ml | 6 ++--- src/cdomains/arrayDomain.ml | 46 ++++++++++++++++++------------------ src/cdomains/arrayDomain.mli | 2 +- 3 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 9c5ea89f34..c83263d445 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2131,9 +2131,9 @@ struct if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, else use top *) let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) - (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with - | Some ar -> Array(ar) - | None -> Address(AD.null_ptr)) in + (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with + | Some ar -> Array(ar) + | None -> Address(AD.null_ptr)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 64b4808aa0..b027a57028 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -104,7 +104,7 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps - + val null: unit -> t val not_null: unit -> t val is_null: t -> bool @@ -1017,14 +1017,14 @@ struct let min_size = min size in (* warn if index is (potentially) out of bounds *) - if checkBounds then (array_oob_check (module Idx) (must_nulls_set, size) (e, i)); + if checkBounds then (array_oob_check (module Idx) ((must_nulls_set, may_nulls_set), size) (e, i)); match max_i, Idx.maximal size with (* if there is no maximum value in index interval *) | None, _ -> (* ... return NotNull if no i >= min_i in may_nulls_set *) if not (MayNulls.exists (Z.leq min_i) may_nulls_set) then NotNull - (* ... else return Top *) + (* ... else return Top *) else Top (* if there is no maximum size *) @@ -1032,7 +1032,7 @@ struct (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) if Z.lt max_i min_size && all_indexes_must_null min_i max_i then Null - (* ... return NotNull if no number in index interval is in may_nulls_set *) + (* ... return NotNull if no number in index interval is in may_nulls_set *) else if not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then NotNull else @@ -1041,7 +1041,7 @@ struct (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) if Z.lt max_i min_size && all_indexes_must_null min_i max_i then Null - (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) + (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) else if Z.lt max_i max_size && not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then NotNull else @@ -1177,11 +1177,11 @@ struct | None, None -> Z.zero, None in match max_i, Val.is_null v with (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) - | Some max_i, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max_i)) - | None, true -> (MustNulls.bot (), MayNulls.top (), Idx.starting !Cil.kindOfSizeOf min_i) + | Some max_i, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) + | None, true -> (MustNulls.bot (), MayNulls.top (), Idx.starting ILong min_i) (* if value <> null, return (top = no indexes, bot = no indexes, size) *) - | Some max_i, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval !Cil.kindOfSizeOf (min_i, max_i)) - | None, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting !Cil.kindOfSizeOf min_i) + | Some max_i, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) + | None, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) let length (_, _, size) = Some size @@ -1220,10 +1220,10 @@ struct let min_must_null = MustNulls.min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) if Z.equal min_must_null (MayNulls.min_elt may_nulls_set) then - (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int !Cil.kindOfSizeOf (Z.succ min_must_null)) + (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else - (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.succ min_must_null)) + (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain @@ -1255,7 +1255,7 @@ struct M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in if n < 0 then - (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) else ((match Idx.minimal size, Idx.maximal size with | Some min_size, Some max_size -> @@ -1277,36 +1277,36 @@ struct "Resulting string might not be null-terminated because src doesn't contain a null byte"; match Idx.maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) - | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - | _ -> (must_nulls_set, may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n))) + | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int ILong (Z.of_int n)) + | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) else if MustNulls.is_empty must_nulls_set then let min_may_null = MayNulls.min_elt may_nulls_set in warn_no_null Z.zero false min_may_null; - (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else let min_must_null = MustNulls.min_elt must_nulls_set in let min_may_null = MayNulls.min_elt may_nulls_set in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int !Cil.kindOfSizeOf (Z.of_int n))) + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with - | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size - | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) + | Some min_size -> Idx.starting ILong min_size + | None -> Idx.starting ILong Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set)) + Idx.starting ILong (MayNulls.min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) + Idx.of_interval ILong (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) @@ -1481,8 +1481,8 @@ struct if Z.lt haystack_max needle_min then None else - Some (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) - | _ -> Some (MustNulls.top (), MayNulls.top (), Idx.top_of !Cil.kindOfSizeOf) + Some (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) + | _ -> Some (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let compare n n_exists = @@ -1501,7 +1501,7 @@ struct (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set1) n) && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set2) n) && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then - Idx.of_excl_list IInt [Z.zero] + Idx.of_excl_list IInt [Z.zero] else Idx.top_of IInt with Not_found -> Idx.top_of IInt) in diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index b62e65ea60..9bfa85fb5d 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -119,7 +119,7 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps - + val null: unit -> t val not_null: unit -> t val is_null: t -> bool From 00941e74bd4995c27b237fe42cf4434348ba64e4 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Fri, 9 Jun 2023 11:34:51 +0200 Subject: [PATCH 009/233] Introduced case for value = bot in make of NullByte --- src/analyses/base.ml | 1 + src/cdomains/arrayDomain.ml | 76 +++++++++---------- src/cdomains/arrayDomain.mli | 1 - src/cdomains/valueDomain.ml | 8 +- .../73-strings/01-string_literals.c | 14 ++-- .../73-strings/02-string_literals_with_null.c | 6 +- .../regression/73-strings/03-string_basics.c | 22 +++--- 7 files changed, 62 insertions(+), 66 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c83263d445..0090f85b0a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2118,6 +2118,7 @@ struct (* else compute strlen in array domain *) else begin match eval_rv (Analyses.ask_of_ctx ctx) gs st s with + (* TODO: found out during debugging that case is not picked even when it should -- why?? *) | Array array_s -> Int(CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index b027a57028..680ff50566 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -106,7 +106,6 @@ sig include LatticeWithSmartOps val null: unit -> t - val not_null: unit -> t val is_null: t -> bool val is_int_ikind: t -> Cil.ikind option @@ -1005,12 +1004,8 @@ struct else false in let min interval = match Idx.minimal interval with - | Some min_num -> - if Z.lt min_num Z.zero then - Z.zero (* assume worst case minimal natural number *) - else - min_num - | None -> Z.zero in (* assume worst case minimal natural number *) + | Some min_num when Z.geq min_num Z.zero -> min_num + | _ -> Z.zero in (* assume worst case minimal natural number *) let min_i = min i in let max_i = Idx.maximal i in @@ -1056,12 +1051,8 @@ struct else add_indexes (Z.succ i) max (MayNulls.add i may_nulls_set) in let min interval = match Idx.minimal interval with - | Some min_num -> - if Z.lt min_num Z.zero then - Z.zero (* assume worst case minimal natural number *) - else - min_num - | None -> Z.zero in (* assume worst case minimal natural number *) + | Some min_num when Z.geq min_num Z.zero -> min_num + | _ -> Z.zero in (* assume worst case minimal natural number *) let min_size = min size in let min_i = min i in @@ -1153,35 +1144,38 @@ struct let make ?(varAttr=[]) ?(typAttr=[]) i v = let min_i, max_i = match Idx.minimal i, Idx.maximal i with - | Some min, Some max -> - if Z.lt min Z.zero && Z.lt max Z.zero then + | Some min_i, Some max_i -> + if Z.lt min_i Z.zero && Z.lt max_i Z.zero then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) - else if Z.lt min Z.zero then + else if Z.lt min_i Z.zero then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; - Z.zero, Some max) + Z.zero, Some max_i) else - min, Some max - | None, Some max -> - if Z.lt max Z.zero then + min_i, Some max_i + | None, Some max_i -> + if Z.lt max_i Z.zero then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) else - Z.zero, Some max - | Some min, None -> - if Z.lt min Z.zero then + Z.zero, Some max_i + | Some min_i, None -> + if Z.lt min_i Z.zero then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; Z.zero, None) else - min, None + min_i, None | None, None -> Z.zero, None in - match max_i, Val.is_null v with + match max_i, Val.is_null v, Val.is_bot v with (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) - | Some max_i, true -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) - | None, true -> (MustNulls.bot (), MayNulls.top (), Idx.starting ILong min_i) + | Some max_i, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) + | None, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.starting ILong min_i) + (* if value = bot, return (top = no indexes, top = all indexes up to maximal size - 1, size) *) + | Some max_i, false, true -> (MustNulls.top (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) + | None, false, true -> (MustNulls.top (), MayNulls.top (), Idx.starting ILong min_i) (* if value <> null, return (top = no indexes, bot = no indexes, size) *) - | Some max_i, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) - | None, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) + | Some max_i, false, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) + | None, false, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) let length (_, _, size) = Some size @@ -1298,15 +1292,15 @@ struct if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with - | Some min_size -> Idx.starting ILong min_size - | None -> Idx.starting ILong Z.zero) + | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size + | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting ILong (MayNulls.min_elt may_nulls_set)) + Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval ILong (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) + Idx.of_interval !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) @@ -1370,9 +1364,10 @@ struct let strlen2 = to_string_length ar2 in update_sets must_nulls_set2 may_nulls_set2 (Idx.minimal strlen2) (Idx.maximal strlen2) (* strncpy = exactly n bytes from src are copied to dest *) - | Some n -> + | Some n when n >= 0 -> let must_nulls_set2, may_nulls_set2, _ = to_n_string ar2 n in update_sets must_nulls_set2 may_nulls_set2 (Some (Z.of_int n)) (Some (Z.of_int n)) + | _ -> (MustNulls.top (), MayNulls.top(), size1) let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = @@ -1456,7 +1451,7 @@ struct let must_nulls_set2', may_nulls_set2', _ = to_string (must_nulls_set2, may_nulls_set2, size2) in compute_concat must_nulls_set2' may_nulls_set2' (* strncat *) - | Some n -> + | Some n when n >= 0 -> (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let must_nulls_set2', may_nulls_set2' = let must_nulls_set2, may_nulls_set2, _ = to_string (must_nulls_set2, may_nulls_set2, size2) in @@ -1467,6 +1462,7 @@ struct else (MustNulls.filter (Z.gt (Z.of_int n)) must_nulls_set2, MayNulls.filter (Z.gt (Z.of_int n)) may_nulls_set2) in compute_concat must_nulls_set2' may_nulls_set2' + | _ -> (MustNulls.top (), MayNulls.top (), size1) let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = (* if needle is empty string, i.e. certain null byte at index 0, return haystack as string *) @@ -1521,14 +1517,11 @@ struct (* compute abstract value for result of strcmp *) compare Z.zero false (* strncmp *) - | Some n -> - if n < 0 then - Idx.top_of IInt - else - let min_size1 = match Idx.minimal size1 with + | Some n when n >= 0 -> + let min_size1 = match Idx.minimal size1 with | Some min_size1 -> min_size1 | None -> Z.zero in - let min_size2 = match Idx.minimal size2 with + let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in (* issue a warning if n is (potentially) smaller than array sizes *) @@ -1552,6 +1545,7 @@ struct M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes"); (* compute abstract value for result of strncmp *) compare (Z.of_int n) true + | _ -> Idx.top_of IInt let update_length new_size (must_nulls_set, may_nulls_set, size) = (must_nulls_set, may_nulls_set, new_size) diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 9bfa85fb5d..ef503248c6 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -121,7 +121,6 @@ sig include LatticeWithSmartOps val null: unit -> t - val not_null: unit -> t val is_null: t -> bool val is_int_ikind: t -> Cil.ikind option diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 8846a5be1f..2ae980369e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -39,7 +39,6 @@ sig val zero_init_value: ?varAttr:attributes -> typ -> t val null: unit -> t - val not_null: unit -> t val is_null: t -> bool val is_int_ikind: t -> Cil.ikind option @@ -272,9 +271,12 @@ struct let top_name = "Unknown" let null () = Int(ID.of_int IChar Z.zero) - let not_null () = Top let is_null = function - | Int n -> ID.to_int n = Some Z.zero + | Int n -> + begin match ID.to_int n with + | Some n -> Z.equal n Z.zero + | None -> false + end | _ -> false let is_int_ikind = function diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 36e4ed121c..14f4d43014 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -22,16 +22,16 @@ int main() { char* s2 = "abcdfg"; char* s3 = hello_world(); - int i = strlen(s1); - __goblint_check(i == 5); + size_t len = strlen(s1); + __goblint_check(len == 5); - i = strlen(s2); - __goblint_check(i == 6); + len = strlen(s2); + __goblint_check(len == 6); - i = strlen(s3); - __goblint_check(i == 12); + len = strlen(s3); + __goblint_check(len == 12); - i = strcmp(s1, s2); + int i = strcmp(s1, s2); __goblint_check(i < 0); i = strcmp(s2, "abcdfg"); diff --git a/tests/regression/73-strings/02-string_literals_with_null.c b/tests/regression/73-strings/02-string_literals_with_null.c index 75d000bbb8..6d6717dcba 100644 --- a/tests/regression/73-strings/02-string_literals_with_null.c +++ b/tests/regression/73-strings/02-string_literals_with_null.c @@ -9,10 +9,10 @@ int main() { char* s3 = "hello world!"; char* s4 = "\0 i am the empty string"; - int i = strlen(s1); - __goblint_check(i == 5); + size_t len = strlen(s1); + __goblint_check(len == 5); - i = strcmp(s1, s2); + int i = strcmp(s1, s2); __goblint_check(i == 0); i = strcmp(s3, s1); diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index db196c64b4..88bbe58796 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -19,23 +19,23 @@ int main() { char s3[10] = "abcd"; char s4[20] = "abcdf"; - int i = strlen(s1); - __goblint_check(i == 6); // UNKNOWN + size_t len = strlen(s1); + __goblint_check(len == 6); // UNKNOWN - i = strlen(s2); - __goblint_check(i == 6); // UNKNOWN + len = strlen(s2); + __goblint_check(len == 6); // UNKNOWN - i = strlen(s3); - __goblint_check(i == 4); // UNKNOWN + len = strlen(s3); + __goblint_check(len == 4); // UNKNOWN strcat(s1, s2); - i = strcmp(s1, "hello world!"); + int i = strcmp(s1, "hello world!"); __goblint_check(i == 0); // UNKNOWN strcpy(s1, "hi "); strncpy(s1, s3, 3); - i = strlen(s1); - __goblint_check(i == 3); // UNKNOWN + len = strlen(s1); + __goblint_check(len == 3); // UNKNOWN strcat(s1, "ababcd"); char* cmp = strstr(s1, "bab"); @@ -52,8 +52,8 @@ int main() { strncpy(s1, "", 20); concat_1(s1, 30); - i = strlen(s1); - __goblint_check(i == 30); // UNKNOWN + len = strlen(s1); + __goblint_check(len == 30); // UNKNOWN cmp = strstr(s1, "0"); __goblint_check(cmp == NULL); // UNKNOWN From 03085f5c16a2cbe267f6ef82764152ee3df2f725 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Sun, 11 Jun 2023 21:28:24 +0200 Subject: [PATCH 010/233] Handle bot for MustNulls / top for MayNulls properly --- src/analyses/base.ml | 38 +-- src/cdomains/arrayDomain.ml | 245 +++++++++++++----- .../regression/73-strings/03-string_basics.c | 23 +- 3 files changed, 220 insertions(+), 86 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0090f85b0a..4cd2f61c53 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2053,18 +2053,18 @@ struct end (* else compute value in array domain *) else - let eval_dst = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in - let eval_src = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in - match eval_dst, eval_src with - | Array array_dst, Array array_src -> - begin match lv with - | Some lv_val -> - let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in - let lv_typ = Cilfacade.typeOfLval lv_val in - lv_a, lv_typ, op_array array_dst array_src - | None -> s1_a, s1_typ, op_array array_dst array_src + let lv_a, lv_typ = match lv with + | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val + | None -> s1_a, s1_typ in + let s1_lval = mkMem ~addr:(Cil.stripCasts s1) ~off:NoOffset in + let s2_lval = mkMem ~addr:(Cil.stripCasts s2) ~off:NoOffset in + match s1_lval, s2_lval with + | (Var v_s1, _), (Var v_s2, _) -> + begin match CPA.find_opt v_s1 st.cpa, CPA.find_opt v_s2 st.cpa with + | Some (Array array_s1), Some (Array array_s2) -> lv_a, lv_typ, op_array array_s1 array_s2 + | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ) end - | _ -> s1_a, s1_typ, VD.top_value (unrollType s1_typ) + | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ) in let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> @@ -2099,6 +2099,7 @@ struct in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strcpy { dest = dst; src; n }, _ -> + (* TODO: This doesn't work, need to convert to Address? If yes, how? *) let dest_a, dest_typ, value = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_copy ar1 ar2 (eval_n n))) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strcat { dest = dst; src; n }, _ -> @@ -2115,11 +2116,18 @@ struct (* if s string literal, compute strlen in string literals domain *) if AD.type_of address = charPtrType then Int(AD.to_string_length address) - (* else compute strlen in array domain *) + (* else compute strlen in array domain; TODO: is there any more elegant way than this? The following didn't work :( *) + (* let eval_dst = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in + let eval_src = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in + match eval_dst, eval_src with + | Array array_dst, Array array_src -> ... *) else - begin match eval_rv (Analyses.ask_of_ctx ctx) gs st s with - (* TODO: found out during debugging that case is not picked even when it should -- why?? *) - | Array array_s -> Int(CArrays.to_string_length array_s) + begin match lval with + | (Var v, _) -> + begin match CPA.find_opt v st.cpa with + | Some (Array array_s) -> Int(CArrays.to_string_length array_s) + | _ -> VD.top_value (unrollType dest_typ) + end | _ -> VD.top_value (unrollType dest_typ) end in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 680ff50566..8b8e5c39e9 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1044,6 +1044,58 @@ struct (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top + (* helper functions *) + let must_nulls_remove i must_nulls_set min_size = + let rec compute_set acc i = + if Z.geq i min_size then + acc + else + compute_set (MustNulls.add i acc) (Z.succ i) in + if MustNulls.is_bot must_nulls_set then + MustNulls.remove i (compute_set (MustNulls.empty ()) Z.zero) + else + MustNulls.remove i must_nulls_set + let must_nulls_filter cond must_nulls_set min_size = + let rec compute_set acc i = + if Z.geq i min_size then + acc + else + compute_set (MustNulls.add i acc) (Z.succ i) in + if MustNulls.is_bot must_nulls_set then + MustNulls.filter cond (compute_set (MustNulls.empty ()) Z.zero) + else + MustNulls.filter cond must_nulls_set + let must_nulls_min_elt must_nulls_set = + if MustNulls.is_bot must_nulls_set then + Z.zero + else + MustNulls.min_elt must_nulls_set + let may_nulls_remove i may_nulls_set max_size = + let rec compute_set acc i = + if Z.geq i max_size then + acc + else + compute_set (MayNulls.add i acc) (Z.succ i) in + if MayNulls.is_top may_nulls_set then + MayNulls.remove i (compute_set (MayNulls.empty ()) Z.zero) + else + MayNulls.remove i may_nulls_set + let may_nulls_filter cond may_nulls_set max_size = + let rec compute_set acc i = + if Z.geq i max_size then + acc + else + compute_set (MayNulls.add i acc) (Z.succ i) in + if MayNulls.is_top may_nulls_set then + MayNulls.filter cond (compute_set (MayNulls.empty ()) Z.zero) + else + MayNulls.filter cond may_nulls_set + let may_nulls_min_elt may_nulls_set = + if MayNulls.is_top may_nulls_set then + Z.zero + else + MayNulls.min_elt may_nulls_set + let set (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) v = let rec add_indexes i max may_nulls_set = if Z.gt i max then @@ -1067,26 +1119,26 @@ struct (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) (* ..., i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) else if Z.lt i min_size then - (MustNulls.remove i must_nulls_set, MayNulls.remove i may_nulls_set, size) + (must_nulls_remove i must_nulls_set min_size, MayNulls.remove i may_nulls_set, size) (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) else if Val.is_null v then (must_nulls_set, MayNulls.add i may_nulls_set, size) (* ..., i >= minimal size and value <> null, remove i only from must_nulls_set *) else - (MustNulls.remove i must_nulls_set, may_nulls_set, size) + (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) | Some max_size -> (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) if Z.lt i min_size && Val.is_null v then (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) (* if i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) else if Z.lt i min_size then - (MustNulls.remove i must_nulls_set, MayNulls.remove i may_nulls_set, size) + (must_nulls_remove i must_nulls_set min_size, may_nulls_remove i may_nulls_set max_size, size) (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) else if Z.lt i max_size && Val.is_null v then (must_nulls_set, MayNulls.add i may_nulls_set, size) (* if minimal size <= i < maximal size and value <> null, remove i only from must_nulls_set *) else if Z.lt i max_size then - (MustNulls.remove i must_nulls_set, may_nulls_set, size) + (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) (* if i >= maximal size, return tuple unmodified *) else (must_nulls_set, may_nulls_set, size) in @@ -1099,7 +1151,7 @@ struct else if Z.equal min_i Z.zero && Z.geq max_i min_size then MustNulls.top () else - MustNulls.filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set in + must_nulls_filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set min_size in let set_interval_may min_i max_i = (* if value <> null, return may_nulls_set unmodified as not clear which index is set to value *) @@ -1133,7 +1185,7 @@ struct | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else - (MustNulls.filter (Z.gt min_i) must_nulls_set, may_nulls_set, size) + (must_nulls_filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then set_exact min_i @@ -1211,13 +1263,24 @@ struct (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; (must_nulls_set, may_nulls_set, size)) else - let min_must_null = MustNulls.min_elt must_nulls_set in + let min_must_null = must_nulls_min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - if Z.equal min_must_null (MayNulls.min_elt may_nulls_set) then + if Z.equal min_must_null (may_nulls_min_elt may_nulls_set) then (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else - (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) + match Idx.maximal size with + | Some max_size -> (MustNulls.empty (), may_nulls_filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) + | None -> + if MayNulls.is_top may_nulls_set then + let rec add_indexes acc i = + if Z.gt i min_must_null then + acc + else + add_indexes (MayNulls.add i acc) (Z.succ i) in + (MustNulls.empty (), add_indexes (MayNulls.empty ()) Z.zero, Idx.of_int ILong (Z.succ min_must_null)) + else + (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain @@ -1276,12 +1339,12 @@ struct (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) else if MustNulls.is_empty must_nulls_set then - let min_may_null = MayNulls.min_elt may_nulls_set in + let min_may_null = may_nulls_min_elt may_nulls_set in warn_no_null Z.zero false min_may_null; (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else - let min_must_null = MustNulls.min_elt must_nulls_set in - let min_may_null = MayNulls.min_elt may_nulls_set in + let min_must_null = must_nulls_min_elt must_nulls_set in + let min_may_null = may_nulls_min_elt may_nulls_set in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) @@ -1297,41 +1360,50 @@ struct (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set)) + Idx.starting !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (MayNulls.min_elt may_nulls_set, MustNulls.min_elt must_nulls_set) + Idx.of_interval !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set, must_nulls_min_elt must_nulls_set) let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) - let update_sets must_nulls_set2 may_nulls_set2 min_len1 min_len2 = - match Idx.minimal size1, Idx.maximal size1, min_len1, min_len2 with + let update_sets must_nulls_set2 may_nulls_set2 size2 len2 = + match Idx.minimal size1, Idx.maximal size1, Idx.minimal len2, Idx.maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> (if Z.lt max_size1 min_len2 then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" else if Z.lt min_size1 max_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in (* get must nulls from src string < minimal size of dest *) - MustNulls.filter (Z.lt min_size1) must_nulls_set2 + must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 (* and keep indexes of dest >= maximal strlen of src *) - |> MustNulls.union (MustNulls.filter (Z.geq max_len2) must_nulls_set1) in + |> MustNulls.union (must_nulls_filter (Z.geq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = + let max_size2 = match Idx.maximal size2 with + | Some max_size2 -> max_size2 + | None -> max_size1 in (* get may nulls from src string < maximal size of dest *) - MayNulls.filter (Z.lt max_size1) may_nulls_set2 + may_nulls_filter (Z.lt max_size1) may_nulls_set2 max_size2 (* and keep indexes of dest >= minimal strlen of src *) - |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - MustNulls.filter (Z.lt min_size1) must_nulls_set2 - |> MustNulls.union (MustNulls.filter (Z.geq max_len2) must_nulls_set1) in + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in + must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 + |> MustNulls.union (must_nulls_filter (Z.geq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2 - |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then @@ -1339,20 +1411,31 @@ struct else if Z.lt min_size1 min_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) - let must_nulls_set_result = MustNulls.filter (Z.lt min_size1) must_nulls_set2 in + let must_nulls_set_result = + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in + must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 in let may_nulls_set_result = - MayNulls.filter (Z.lt max_size1) may_nulls_set2 - |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + let max_size2 = match Idx.maximal size2 with + | Some max_size2 -> max_size2 + | None -> max_size1 in + may_nulls_filter (Z.lt max_size1) may_nulls_set2 max_size2 + |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) - let must_nulls_set_result = MustNulls.filter (Z.lt min_size1) must_nulls_set2 in + let must_nulls_set_result = + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in + must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2 - |> MayNulls.union (MayNulls.filter (Z.geq min_len2) may_nulls_set1) in + |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (MustNulls.top (), MayNulls.top (), size1) in @@ -1360,14 +1443,14 @@ struct match n with (* strcpy *) | None -> - let must_nulls_set2, may_nulls_set2, _ = to_string ar2 in + let must_nulls_set2, may_nulls_set2, size2 = to_string ar2 in let strlen2 = to_string_length ar2 in - update_sets must_nulls_set2 may_nulls_set2 (Idx.minimal strlen2) (Idx.maximal strlen2) + update_sets must_nulls_set2 may_nulls_set2 size2 strlen2 (* strncpy = exactly n bytes from src are copied to dest *) | Some n when n >= 0 -> - let must_nulls_set2, may_nulls_set2, _ = to_n_string ar2 n in - update_sets must_nulls_set2 may_nulls_set2 (Some (Z.of_int n)) (Some (Z.of_int n)) - | _ -> (MustNulls.top (), MayNulls.top(), size1) + let must_nulls_set2, may_nulls_set2, size2 = to_n_string ar2 n in + update_sets must_nulls_set2 may_nulls_set2 size2 (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + | _ -> (MustNulls.top (), MayNulls.top (), size1) let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = @@ -1386,41 +1469,68 @@ struct * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) if MustNulls.is_empty must_nulls_set1 || MustNulls.is_empty must_nulls_set2' then let may_nulls_set_result = - MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 - |> MayNulls.elements - |> BatList.cartesian_product (MayNulls.elements may_nulls_set2') - |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) - |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in + if max_size1_exists then + may_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + |> MayNulls.elements + (* if may_nulls_set2' is top, limit it to max_size1 *) + |> BatList.cartesian_product (MayNulls.elements (may_nulls_filter (fun x -> true) may_nulls_set2' max_size1)) + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list + |> MayNulls.union (may_nulls_filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MayNulls.filter (Z.gt max_size1) + else if not (MayNulls.is_top may_nulls_set1) && not (MayNulls.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then + MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + |> MayNulls.elements + |> BatList.cartesian_product (MayNulls.elements may_nulls_set2') + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list + |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + else + MayNulls.top () in (MustNulls.top (), may_nulls_set_result, size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) - else if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && Z.equal (MustNulls.min_elt must_nulls_set2') (MayNulls.min_elt may_nulls_set2') then - let min_i1 = MustNulls.min_elt must_nulls_set1 in - let min_i2 = MustNulls.min_elt must_nulls_set2' in + else if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && Z.equal (must_nulls_min_elt must_nulls_set2') (may_nulls_min_elt may_nulls_set2') then + let min_i1 = must_nulls_min_elt must_nulls_set1 in + let min_i2 = must_nulls_min_elt must_nulls_set2' in let min_i = Z.add min_i1 min_i2 in let must_nulls_set_result = - MustNulls.filter (Z.lt min_i) must_nulls_set1 + must_nulls_filter (Z.lt min_i) must_nulls_set1 min_size1 |> MustNulls.add min_i |> MustNulls.filter (Z.gt min_size1) in let may_nulls_set_result = - MayNulls.filter (Z.lt min_i) may_nulls_set1 - |> MayNulls.add min_i - |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in + if max_size1_exists then + may_nulls_filter (Z.lt min_i) may_nulls_set1 max_size1 + |> MayNulls.add min_i + |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + else + MayNulls.top () in (must_nulls_set_result, may_nulls_set_result, size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else - let min_i2 = MustNulls.min_elt must_nulls_set2' in - let may_nulls_set2'_until_min_i2 = MayNulls.filter (Z.geq min_i2) may_nulls_set2' in - let must_nulls_set_result = MustNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 in + let min_i2 = must_nulls_min_elt must_nulls_set2' in + let may_nulls_set2'_until_min_i2 = + match Idx.maximal size2 with + | Some max_size2 -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' max_size2 + | None -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in + let must_nulls_set_result = must_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 min_size1 in let may_nulls_set_result = - MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 - |> MayNulls.elements - |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) - |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) - |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) in + if max_size1_exists then + may_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + |> MayNulls.elements + |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list + |> MayNulls.union (may_nulls_filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + else if not (MayNulls.is_top may_nulls_set1) then + MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + |> MayNulls.elements + |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) + |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> MayNulls.of_list + |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + else + MayNulls.top () in (must_nulls_set_result, may_nulls_set_result, size1) in let compute_concat must_nulls_set2' may_nulls_set2' = @@ -1454,13 +1564,22 @@ struct | Some n when n >= 0 -> (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let must_nulls_set2', may_nulls_set2' = - let must_nulls_set2, may_nulls_set2, _ = to_string (must_nulls_set2, may_nulls_set2, size2) in + let must_nulls_set2, may_nulls_set2, size2 = to_string (must_nulls_set2, may_nulls_set2, size2) in if not (MayNulls.exists (Z.gt (Z.of_int n)) may_nulls_set2) then (MustNulls.singleton (Z.of_int n), MayNulls.singleton (Z.of_int n)) else if not (MustNulls.exists (Z.gt (Z.of_int n)) must_nulls_set2) then - (MustNulls.empty (), MayNulls.add (Z.of_int n) (MayNulls.filter (Z.geq (Z.of_int n)) may_nulls_set2)) + let max_size2 = match Idx.maximal size2 with + | Some max_size2 -> max_size2 + | None -> Z.succ (Z.of_int n) in + (MustNulls.empty (), MayNulls.add (Z.of_int n) (may_nulls_filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) else - (MustNulls.filter (Z.gt (Z.of_int n)) must_nulls_set2, MayNulls.filter (Z.gt (Z.of_int n)) may_nulls_set2) in + let min_size2 = match Idx.minimal size2 with + | Some min_size2 -> min_size2 + | None -> Z.zero in + let max_size2 = match Idx.maximal size2 with + | Some max_size2 -> max_size2 + | None -> Z.of_int n in + (must_nulls_filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, may_nulls_filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in compute_concat must_nulls_set2' may_nulls_set2' | _ -> (MustNulls.top (), MayNulls.top (), size1) @@ -1494,9 +1613,9 @@ struct Idx.starting IInt Z.one else (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) - (try if Z.equal (MustNulls.min_elt must_nulls_set1) (MayNulls.min_elt may_nulls_set1) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set1) n) - && Z.equal (MustNulls.min_elt must_nulls_set2) (MayNulls.min_elt may_nulls_set2) && (not n_exists || Z.lt (MustNulls.min_elt must_nulls_set2) n) - && not (Z.equal (MustNulls.min_elt must_nulls_set1) (MustNulls.min_elt must_nulls_set2)) then + (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n) + && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set2) n) + && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then Idx.of_excl_list IInt [Z.zero] else Idx.top_of IInt diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 88bbe58796..38eec582d6 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -13,29 +13,36 @@ void concat_1(char* s, int i) { } int main() { - char* s1 = malloc(40); - strcpy(s1, "hello "); + char s1[40] = "hello "; char s2[] = "world!"; char s3[10] = "abcd"; char s4[20] = "abcdf"; + char* s5 = malloc(40); + strcpy(s5, "hello"); size_t len = strlen(s1); - __goblint_check(len == 6); // UNKNOWN + __goblint_check(len == 6); len = strlen(s2); - __goblint_check(len == 6); // UNKNOWN + __goblint_check(len == 6); len = strlen(s3); - __goblint_check(len == 4); // UNKNOWN + __goblint_check(len == 4); + + len = strlen(s5); + __goblint_check(len == 5); // UNKNOWN strcat(s1, s2); + len = strlen(s1); int i = strcmp(s1, "hello world!"); + __goblint_check(len == 12); __goblint_check(i == 0); // UNKNOWN - strcpy(s1, "hi "); - strncpy(s1, s3, 3); + char tmp[] = "hi "; + strcpy(s1, tmp); + /* strncpy(s1, s3, 3); */ len = strlen(s1); - __goblint_check(len == 3); // UNKNOWN + __goblint_check(len == 3); // UNKNOWN <----- wrong result: calculates 6 instead of 3 probably caused by wrong integration in base strcat(s1, "ababcd"); char* cmp = strstr(s1, "bab"); From d57ac9e014395639dda49f2f99de3a0110197a23 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 12 Jun 2023 23:46:11 +0200 Subject: [PATCH 011/233] Fixed usage of domain in base and minor fixes in logic - Null Byte domain can now be called for all wished functions in base and values are correctly updated - Base now sets dest to top if string functions receive an array as dest and a string literal as src - Added function setting whole array content to top but still memorizing type and size - Fixed inverted comparisons in string_copy - Fixed wrong claim in string_comparison --- src/analyses/base.ml | 47 +++++--- src/cdomains/arrayDomain.ml | 102 +++++++++++------- src/cdomains/arrayDomain.mli | 3 + .../regression/73-strings/03-string_basics.c | 23 +++- 4 files changed, 118 insertions(+), 57 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 4cd2f61c53..abd266f08d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2041,15 +2041,15 @@ struct let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) + lv_a, lv_typ, (f s1_a s2_a), None else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) + lv_a, lv_typ, (f s1_a s2_a), None else - lv_a, lv_typ, (VD.top_value (unrollType lv_typ)) + lv_a, lv_typ, (VD.top_value (unrollType lv_typ)), None | _ -> (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) let _ = AD.string_writing_defined s1_a in - s1_a, s1_typ, VD.top_value (unrollType s1_typ) + s1_a, s1_typ, VD.top_value (unrollType s1_typ), None end (* else compute value in array domain *) else @@ -2061,10 +2061,15 @@ struct match s1_lval, s2_lval with | (Var v_s1, _), (Var v_s2, _) -> begin match CPA.find_opt v_s1 st.cpa, CPA.find_opt v_s2 st.cpa with - | Some (Array array_s1), Some (Array array_s2) -> lv_a, lv_typ, op_array array_s1 array_s2 - | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ) + | Some (Array array_s1), Some (Array array_s2) -> lv_a, lv_typ, op_array array_s1 array_s2, Some v_s1 + | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), None end - | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ) + | (Var v_s1, _), _ -> + begin match CPA.find_opt v_s1 st.cpa with + | Some (Array array_s1) -> lv_a, lv_typ, Array(CArrays.content_to_top array_s1), Some v_s1 + | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), Some v_s1 + end + | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), None in let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> @@ -2099,12 +2104,17 @@ struct in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Strcpy { dest = dst; src; n }, _ -> - (* TODO: This doesn't work, need to convert to Address? If yes, how? *) - let dest_a, dest_typ, value = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_copy ar1 ar2 (eval_n n))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + let dest_a, dest_typ, value, var = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_copy ar1 ar2 (eval_n n))) in + begin match var with + | Some v -> {st with cpa = CPA.add v value st.cpa} + | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + end | Strcat { dest = dst; src; n }, _ -> - let dest_a, dest_typ, value = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_concat ar1 ar2 (eval_n n))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + let dest_a, dest_typ, value, var = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_concat ar1 ar2 (eval_n n))) in + begin match var with + | Some v -> {st with cpa = CPA.add v value st.cpa} + | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + end | Strlen s, _ -> begin match lv with | Some lv_val -> @@ -2139,18 +2149,25 @@ struct (* when haystack, needle and dest type coincide, check if needle is a substring of haystack: if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, else use top *) - let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) + let dest_a, dest_typ, value, var = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with | Some ar -> Array(ar) | None -> Address(AD.null_ptr)) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + begin match var with + | Some v -> + begin match value with + | Address _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + | _ -> {st with cpa = CPA.add v value st.cpa} + end + | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + end | None -> st end | Strcmp { s1; s2; n }, _ -> begin match lv with | Some _ -> (* when s1 and s2 type coincide, compare both both strings completely or their first n characters, otherwise use top *) - let dest_a, dest_typ, value = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int(AD.string_comparison s1_a s2_a (eval_n n)))) + let dest_a, dest_typ, value, _ = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int(AD.string_comparison s1_a s2_a (eval_n n)))) (fun s1_ar s2_ar -> Int(CArrays.string_comparison s1_ar s2_ar (eval_n n))) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 8b8e5c39e9..dc25e52db4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -53,6 +53,7 @@ sig val get_vars_in_e: t -> Cil.varinfo list val map: (value -> value) -> t -> t val fold_left: ('a -> value -> 'a) -> 'a -> t -> 'a + val content_to_top: t -> t val smart_join: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_widen: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_leq: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool @@ -140,6 +141,8 @@ struct let map f x = f x let fold_left f a x = f a x + let content_to_top _ = Val.top () + let printXml f x = BatPrintf.fprintf f "\n\nAny\n%a\n\n\n" Val.printXml x let smart_join _ _ = join let smart_widen _ _ = widen @@ -248,6 +251,7 @@ struct let get_vars_in_e _ = [] let map f (xl, xr) = ((List.map f xl), f xr) let fold_left f a x = f a (join_of_all_parts x) + let content_to_top x = (Base.top (), Val.top ()) let printXml f (xl,xr) = BatPrintf.fprintf f "\n\n unrolled array\n xl\n%a\n\n @@ -340,6 +344,7 @@ struct let is_top = function | Joint x -> Val.is_top x | _-> false + let content_to_top _ = top () let join (x:t) (y:t) = normalize @@ match x, y with @@ -860,6 +865,8 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] + let content_to_top (x, l) = (Base.content_to_top x, l) + let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -907,6 +914,8 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e (x, _) = Base.get_vars_in_e x + let content_to_top (x, l) = (Base.content_to_top x, l) + let smart_join x_eval_int y_eval_int (x,xl) (y,yl) = let l = Idx.join xl yl in (Base.smart_join_with_length (Some l) x_eval_int y_eval_int x y , l) @@ -959,6 +968,8 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] + let content_to_top (x, l) = (Base.content_to_top x, l) + let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -995,6 +1006,11 @@ struct type ret = Null | NotNull | Top + (* helper: returns Idx.maximal except for Overflows that are mapped to None *) + let idx_maximal i = match Idx.maximal i with + | Some i -> (try Some (Z.of_int (Z.to_int i)) with Z.Overflow -> None) + | None -> None + let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = let rec all_indexes_must_null i max = if Z.gt i max then @@ -1008,12 +1024,12 @@ struct | _ -> Z.zero in (* assume worst case minimal natural number *) let min_i = min i in - let max_i = Idx.maximal i in + let max_i = idx_maximal i in let min_size = min size in (* warn if index is (potentially) out of bounds *) if checkBounds then (array_oob_check (module Idx) ((must_nulls_set, may_nulls_set), size) (e, i)); - match max_i, Idx.maximal size with + match max_i, idx_maximal size with (* if there is no maximum value in index interval *) | None, _ -> (* ... return NotNull if no i >= min_i in may_nulls_set *) @@ -1108,10 +1124,10 @@ struct let min_size = min size in let min_i = min i in - let max_i = Idx.maximal i in + let max_i = idx_maximal i in let set_exact i = - match Idx.maximal size with + match idx_maximal size with (* if size has no upper limit *) | None -> (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) @@ -1159,7 +1175,7 @@ struct may_nulls_set (* if value = null *) else - match Idx.maximal size with + match idx_maximal size with (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) | None -> add_indexes min_i max_i may_nulls_set | Some max_size -> @@ -1177,8 +1193,8 @@ struct (* if no maximum number in index interval *) | None -> (* ..., value = null*) - if Val.is_null v && Idx.maximal size = None then - match Idx.maximal size with + if Val.is_null v && idx_maximal size = None then + match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) | None -> (must_nulls_set, MayNulls.top (), size) (* ..., add all i from minimal index to maximal size to may_nulls_set *) @@ -1195,7 +1211,7 @@ struct | _ -> (must_nulls_set, may_nulls_set, size) let make ?(varAttr=[]) ?(typAttr=[]) i v = - let min_i, max_i = match Idx.minimal i, Idx.maximal i with + let min_i, max_i = match Idx.minimal i, idx_maximal i with | Some min_i, Some max_i -> if Z.lt min_i Z.zero && Z.lt max_i Z.zero then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; @@ -1245,6 +1261,8 @@ struct (MustNulls.top (), MayNulls.top (), size) let fold_left f acc _ = f acc (Val.top ()) + + let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), size) let smart_join _ _ = join let smart_widen _ _ = widen @@ -1269,7 +1287,7 @@ struct (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else - match Idx.maximal size with + match idx_maximal size with | Some max_size -> (MustNulls.empty (), may_nulls_filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) | None -> if MayNulls.is_top may_nulls_set then @@ -1307,14 +1325,14 @@ struct |> MayNulls.filter (Z.gt (Z.of_int n)) in let warn_no_null min_must_null exists_min_must_null min_may_null = if Z.geq min_may_null (Z.of_int n) then - M.error "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" + M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" else if (exists_min_must_null && Z.geq min_must_null (Z.of_int n)) || not exists_min_must_null then M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in if n < 0 then (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) else - ((match Idx.minimal size, Idx.maximal size with + ((match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> if Z.gt (Z.of_int n) max_size then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" @@ -1330,9 +1348,9 @@ struct (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then - (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; - match Idx.maximal size with + match idx_maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int ILong (Z.of_int n)) | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) @@ -1368,7 +1386,7 @@ struct let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) let update_sets must_nulls_set2 may_nulls_set2 size2 len2 = - match Idx.minimal size1, Idx.maximal size1, Idx.minimal len2, Idx.maximal len2 with + match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> (if Z.lt max_size1 min_len2 then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" @@ -1379,17 +1397,17 @@ struct | Some min_size2 -> min_size2 | None -> Z.zero in (* get must nulls from src string < minimal size of dest *) - must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 + must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 (* and keep indexes of dest >= maximal strlen of src *) - |> MustNulls.union (must_nulls_filter (Z.geq max_len2) must_nulls_set1 min_size1) in + |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = - let max_size2 = match Idx.maximal size2 with + let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> max_size1 in (* get may nulls from src string < maximal size of dest *) - may_nulls_filter (Z.lt max_size1) may_nulls_set2 max_size2 + may_nulls_filter (Z.gt max_size1) may_nulls_set2 max_size2 (* and keep indexes of dest >= minimal strlen of src *) - |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 max_size1) in + |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then @@ -1398,12 +1416,12 @@ struct let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 - |> MustNulls.union (must_nulls_filter (Z.geq max_len2) must_nulls_set1 min_size1) in + must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 + |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2 - |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then @@ -1415,13 +1433,13 @@ struct let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 in + must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 in let may_nulls_set_result = - let max_size2 = match Idx.maximal size2 with + let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> max_size1 in - may_nulls_filter (Z.lt max_size1) may_nulls_set2 max_size2 - |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 max_size1) in + may_nulls_filter (Z.gt max_size1) may_nulls_set2 max_size2 + |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then @@ -1431,11 +1449,11 @@ struct let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.lt min_size1) must_nulls_set2 min_size2 in + must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2 - |> MayNulls.union (may_nulls_filter (Z.geq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (MustNulls.top (), MayNulls.top (), size1) in @@ -1509,7 +1527,7 @@ struct else let min_i2 = must_nulls_min_elt must_nulls_set2' in let may_nulls_set2'_until_min_i2 = - match Idx.maximal size2 with + match idx_maximal size2 with | Some max_size2 -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' max_size2 | None -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in let must_nulls_set_result = must_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 min_size1 in @@ -1536,7 +1554,7 @@ struct let compute_concat must_nulls_set2' may_nulls_set2' = let strlen1 = to_string_length (must_nulls_set1, may_nulls_set1, size1) in let strlen2 = to_string_length (must_nulls_set2', may_nulls_set2', size2) in - match Idx.minimal size1, Idx.maximal size1, Idx.minimal strlen1, Idx.maximal strlen1, Idx.minimal strlen2, Idx.maximal strlen2 with + match Idx.minimal size1, idx_maximal size1, Idx.minimal strlen1, idx_maximal strlen1, Idx.minimal strlen2, idx_maximal strlen2 with | Some min_size1, Some max_size1, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' (* no upper bound for length of concatenation *) @@ -1568,7 +1586,7 @@ struct if not (MayNulls.exists (Z.gt (Z.of_int n)) may_nulls_set2) then (MustNulls.singleton (Z.of_int n), MayNulls.singleton (Z.of_int n)) else if not (MustNulls.exists (Z.gt (Z.of_int n)) must_nulls_set2) then - let max_size2 = match Idx.maximal size2 with + let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> Z.succ (Z.of_int n) in (MustNulls.empty (), MayNulls.add (Z.of_int n) (may_nulls_filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) @@ -1576,7 +1594,7 @@ struct let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in - let max_size2 = match Idx.maximal size2 with + let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> Z.of_int n in (must_nulls_filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, may_nulls_filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in @@ -1590,7 +1608,7 @@ struct else let haystack_len = to_string_length haystack in let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in - match Idx.maximal haystack_len, Idx.minimal needle_len with + match idx_maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) if Z.lt haystack_max needle_min then @@ -1606,7 +1624,7 @@ struct || (n_exists && Z.equal Z.zero n) then Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) - else if MustNulls.mem Z.zero must_nulls_set1 && not (MustNulls.mem Z.zero must_nulls_set2) then + else if MustNulls.mem Z.zero must_nulls_set1 && not (MayNulls.mem Z.zero may_nulls_set2) then Idx.ending IInt Z.minus_one (* if only s2 = empty string, return positive integer *) else if MustNulls.mem Z.zero must_nulls_set2 then @@ -1644,7 +1662,7 @@ struct | Some min_size2 -> min_size2 | None -> Z.zero in (* issue a warning if n is (potentially) smaller than array sizes *) - (match Idx.maximal size1 with + (match idx_maximal size1 with | Some max_size1 -> if Z.gt (Z.of_int n) max_size1 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 is smaller than n bytes" @@ -1653,7 +1671,7 @@ struct | None -> if Z.gt (Z.of_int n) min_size1 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes"); - (match Idx.maximal size2 with + (match idx_maximal size2 with | Some max_size2 -> if Z.gt (Z.of_int n) max_size2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 is smaller than n bytes" @@ -1738,6 +1756,8 @@ struct | TrivialDomain -> (None, Some (T.top ()), None) | UnrolledDomain -> (None, None, Some (U.top ())) + let content_to_top x = unop_to_t' P.content_to_top T.content_to_top U.content_to_top x + let make ?(varAttr=[]) ?(typAttr=[]) i v = to_t @@ match get_domain ~varAttr ~typAttr with | PartitionedDomain -> (Some (P.make i v), None, None) | TrivialDomain -> (None, Some (T.make i v), None) @@ -1825,15 +1845,17 @@ struct let map f (t_f, t_n) = (F.map f t_f, N.map f t_n) let fold_left f acc (t_f, t_n) = F.fold_left f acc t_f + let content_to_top (t_f, t_n) = (F.content_to_top t_f, N.content_to_top t_n) + let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 let to_string_length (_, t_n) = N.to_string_length t_n - let string_copy (_, t_n1) (_, t_n2) n = (F.top (), N.string_copy t_n1 t_n2 n) - let string_concat (_, t_n1) (_, t_n2) n = (F.top (), N.string_concat t_n1 t_n2 n) - let substring_extraction (_, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with - | Some res -> Some (F.top (), res) + let string_copy (t_f1, t_n1) (_, t_n2) n = (F.content_to_top t_f1, N.string_copy t_n1 t_n2 n) + let string_concat (t_f1, t_n1) (_, t_n2) n = (F.content_to_top t_f1, N.string_concat t_n1 t_n2 n) + let substring_extraction (t_f1, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with + | Some res -> Some (F.content_to_top t_f1, res) | None -> None let string_comparison (_, t_n1) (_, t_n2) n = N.string_comparison t_n1 t_n2 n diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index ef503248c6..dc1b381340 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -46,6 +46,9 @@ sig val fold_left: ('a -> value -> 'a) -> 'a -> t -> 'a (** Left fold (like List.fold_left) over the arrays elements *) + val content_to_top: t -> t + (** Maps the array's content to top of value, but keeps the type and the size if known *) + val smart_join: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 38eec582d6..1cfa33a689 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -38,11 +38,18 @@ int main() { __goblint_check(len == 12); __goblint_check(i == 0); // UNKNOWN + strcpy(s1, "hi "); + strncpy(s1, s3, 3); + len = strlen(s1); // TODO: produces a false warning -- any possibility to fix? + __goblint_check(len == 3); // UNKNOWN + char tmp[] = "hi "; + len = strlen(tmp); + __goblint_check(len == 3); strcpy(s1, tmp); - /* strncpy(s1, s3, 3); */ + strncpy(s1, s3, 3); len = strlen(s1); - __goblint_check(len == 3); // UNKNOWN <----- wrong result: calculates 6 instead of 3 probably caused by wrong integration in base + __goblint_check(len == 3); strcat(s1, "ababcd"); char* cmp = strstr(s1, "bab"); @@ -58,6 +65,18 @@ int main() { __goblint_check(i > 0); // UNKNOWN strncpy(s1, "", 20); + strcpy(tmp, "\0hi"); + i = strcmp(s1, tmp); + __goblint_check(i == 0); // UNKNOWN + + char tmp2[] = ""; + strcpy(s1, tmp2); + i = strcmp(s1, tmp2); + __goblint_check(i == 0); + + i = strcmp(s1, tmp); + __goblint_check(i == 0); // UNKNOWN + concat_1(s1, 30); len = strlen(s1); __goblint_check(len == 30); // UNKNOWN From 44bd644bf0ac9951e19a1cc042fe69eac6805552 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 13 Jun 2023 23:26:51 +0200 Subject: [PATCH 012/233] Added new thorough regression test --- src/cdomains/arrayDomain.ml | 10 +- .../73-strings/01-string_literals.c | 1 + tests/regression/73-strings/04-char_arrays.c | 201 ++++++++++++++++++ 3 files changed, 209 insertions(+), 3 deletions(-) create mode 100644 tests/regression/73-strings/04-char_arrays.c diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index dc25e52db4..2661bb7767 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1326,7 +1326,7 @@ struct let warn_no_null min_must_null exists_min_must_null min_may_null = if Z.geq min_may_null (Z.of_int n) then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" - else if (exists_min_must_null && Z.geq min_must_null (Z.of_int n)) || not exists_min_must_null then + else if (exists_min_must_null && (Z.geq min_must_null (Z.of_int n)) || (Z.gt min_must_null min_may_null)) || not exists_min_must_null then M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in if n < 0 then @@ -1365,8 +1365,11 @@ struct let min_may_null = may_nulls_min_elt may_nulls_set in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; - (* remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) + (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) + if Z.equal min_must_null min_may_null then + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) + else + (MustNulls.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) @@ -1458,6 +1461,7 @@ struct (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (MustNulls.top (), MayNulls.top (), size1) in + (* TODO: would it be useful to warn if size of ar2 is (potentially bigger) than size of ar1? *) match n with (* strcpy *) | None -> diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 14f4d43014..42a888d1b4 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -2,6 +2,7 @@ #include #include +#include char* hello_world() { return "Hello world!"; diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c new file mode 100644 index 0000000000..20e8cababb --- /dev/null +++ b/tests/regression/73-strings/04-char_arrays.c @@ -0,0 +1,201 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval + +#include +#include +#include + +int main() { + example1(); + example2(); + example3(); + example4(); + example5(); + example6(); + example7(); + example8(); + example9(); + + return 0; +} + +void example1() { + char s1[42]; + char s2[20] = "testing"; // must null at 7, may null starting from 7 + + strcpy(s1, s2); // must null and may null at 7 + + size_t len = strlen(s1); + __goblint_check(len == 7); + + strcat(s1, s2); // "testingtesting" + + len = strlen(s1); + __goblint_check(len == 14); +} + +void example2() { + char s1[42]; + char s2[20] = "testing"; // must null at 7, may null starting from 7 + + if (rand() == 42) + s2[1] = '\0'; + + strcpy(s1, s2); // may null at 1 and starting from 7 + + size_t len = strlen(s1); // WARN: no must null in s1 + __goblint_check(len >= 1); + __goblint_check(len <= 7); // UNKNOWN + + strcpy(s2, s1); // WARN: no must null in s1 +} + +void example3() { + char s1[5] = "abc\0d"; // must and may null at 3 + char s2[] = "a"; // must and may null at 1 + + strcpy(s1, s2); // "a\0c\0d" + + size_t len = strlen(s1); + __goblint_check(len == 1); + + s1[1] = 'b'; // "abc\0d" + len = strlen(s1); + __goblint_check(len == 3); +} + +void example4() { + char s1[7] = "hello!"; // must and may null at 6 + char s2[8] = "goblint"; // must and may null at 7 + + strncpy(s1, s2, 7); // WARN + + size_t len = strlen(s1); // WARN + __goblint_check(len >= 7); // no null byte in s1 +} + +void example5() { + char s1[42] = "a string, i.e. null-terminated char array"; // must and may null at 42 + for (int i = 0; i < 42; i += 3) { + if (rand() != 42) + s1[i] = '\0'; + } + s1[41] = '.'; // no must nulls, only may null a 0, 3, 6... + + char s2[42] = "actually containing some text"; // must and may null at 29 + char s3[60] = "text: "; // must and may null at 6 + + strcat(s3, s1); // WARN: no must nulls, may nulls at 6, 9, 12... + + size_t len = strlen(s3); // WARN + __goblint_check(len >= 6); + __goblint_check(len > 6); // UNKNOWN + + strncat(s2, s3, 10); // WARN: no must nulls, may nulls at 35 and 38 + + len = strlen(s2); // WARN + __goblint_check(len >= 35); + __goblint_check(len > 40); // UNKNOWN +} + +void example6() { + char s1[50] = "hello"; // must and may null at 5 + char s2[] = " world!"; // must and may null at 7 + char s3[] = " goblint."; // must and may null at 9 + + if (rand() < 42) + strcat(s1, s2); // "hello world!" -> must and may null at 12 + else + strncat(s1, s3, 8); // "hello goblint" -> must and may null at 13 + + char s4[20]; + strcpy(s4, s1); // WARN: no must nulls, may nulls at 12 and 13 + + size_t len = strlen(s4); + __goblint_check(len >= 12); + __goblint_check(len == 13); // UNKNOWN + + s4[14] = '\0'; // must null at 14, may nulls at 12, 13 and 14 + len = strlen(s4); + __goblint_check(len >= 12); + __goblint_check(len <= 14); + + char s5[20]; + strncpy(s5, s4, 16); // WARN: no must nulls, may nulls at 12, 13, 14, 15... + len = strlen(s5); // WARN + __goblint_check(len >= 12); + __goblint_check(len <= 14); // UNKNOWN + __goblint_check(len < 20); // UNKNOWN +} + +void example7() { + char s1[6] = "abc"; // must and may null at 3 + if (rand() == 42) + s1[5] = '\0'; // must null at 3, may nulls at 3 and 5 + + char s2[] = "hello world"; // must and may null at 11 + + strncpy(s2, s1, 8); // WARN: 8 > size of s1 -- must and may nulls at 3, 4, 5, 6 and 7 + + size_t len = strlen(s2); + __goblint_check(len == 3); + + s2[3] = 'a'; // must and may nulls at 4, 5, 6 and 7 + len = strlen(s2); + __goblint_check(len == 4); + + for (int i = 4; i <= 7; i++) + s2[i] = 'a'; + s2[11] = 'a'; // no must nulls, may nulls at 4, 5, 6 and 7 + + len = strlen(s2); // WARN + __goblint_check(len >= 12); // UNKNOWN: loop transformed to interval + + s2[4] = s2[5] = s2[6] = s2[7] = 'a'; + len = strlen(s2); // WARN: no must nulls and may nulls + __goblint_check(len >= 12); +} + +void example8() { + char empty[] = ""; + char s1[] = "hello world"; // must and may null at 11 + char s2[] = "test"; // must and may null at 4 + + char cmp[50]; + strcpy(cmp, strstr(s1, empty)); // WARN + size_t len = strlen(cmp); // WARN + __goblint_check(len == 11); // UNKNOWN because can't directly assign result of strstr to cmp, + // TODO: might make handling of this useless in NullByte domain? + + char* cmp_ptr = strstr(s2, s1); + __goblint_check(cmp_ptr == NULL); +} + +void example9() { + char empty1[] = ""; + char empty2[] = "\0 also empty"; + char s1[] = "hi"; + char s2[] = "hello"; + + int i = strcmp(empty1, empty2); + __goblint_check(i == 0); + + i = strcmp(empty1, s1); + __goblint_check(i < 0); + + i = strcmp(s1, empty1); + __goblint_check(i > 0); + + i = strcmp(s1, s2); + __goblint_check(i != 0); + + i = strncmp(s1, s2, 2); + __goblint_check(i != 0); // UNKNOWN + + s1[2] = 'a'; + + i = strcmp(s1, s2); // WARN + __goblint_check(i != 0); // UNKNOWN + + i = strncmp(s1, s2, 10); // WARN + __goblint_check(i != 0); // UNKNOWN +} From 472ece8771bb366cf589680e7c65419ec2081fbf Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 29 Jun 2023 21:03:42 +0200 Subject: [PATCH 013/233] Feature: better treatment of edge cases --- src/analyses/base.ml | 30 ++- src/cdomains/arrayDomain.ml | 202 +++++++++++++----- src/cdomains/arrayDomain.mli | 18 +- src/cdomains/valueDomain.ml | 2 +- src/util/options.schema.json | 6 + .../regression/73-strings/03-string_basics.c | 4 +- tests/regression/73-strings/04-char_arrays.c | 9 +- 7 files changed, 189 insertions(+), 82 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index abd266f08d..dbe6438fca 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2126,12 +2126,13 @@ struct (* if s string literal, compute strlen in string literals domain *) if AD.type_of address = charPtrType then Int(AD.to_string_length address) - (* else compute strlen in array domain; TODO: is there any more elegant way than this? The following didn't work :( *) - (* let eval_dst = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in - let eval_src = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in - match eval_dst, eval_src with - | Array array_dst, Array array_src -> ... *) + (* else compute strlen in array domain *) else + (* (* TODO: why isn't the following working? *) + begin match get (Analyses.ask_of_ctx ctx) gs st address None with + | Array array_s -> Int(CArrays.to_string_length array_s) + | _ -> VD.top_value (unrollType dest_typ) + end) in *) begin match lval with | (Var v, _) -> begin match CPA.find_opt v st.cpa with @@ -2145,22 +2146,17 @@ struct end | Strstr { haystack; needle }, _ -> begin match lv with - | Some _ -> + | Some lv_val -> (* when haystack, needle and dest type coincide, check if needle is a substring of haystack: if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, else use top *) - let dest_a, dest_typ, value, var = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) + let dest_a, dest_typ, value, _ = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with - | Some ar -> Array(ar) - | None -> Address(AD.null_ptr)) in - begin match var with - | Some v -> - begin match value with - | Address _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - | _ -> {st with cpa = CPA.add v value st.cpa} - end - | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - end + | true, false -> Address(AD.null_ptr) + | false, true -> Address(eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + (* TODO: below, instead of ~off:NoOffset, how to have a top offset = don't know exactly at which index pointing? *) + | _ -> Address(AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) (AD.null_ptr))) in + set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end | Strcmp { s1; s2; n }, _ -> diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 2661bb7767..f10988fda9 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -79,10 +79,11 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + val to_null_byte_domain: string -> t val to_string_length: t -> idx val string_copy: t -> t -> int option -> t val string_concat: t -> t -> int option -> t - val substring_extraction: t -> t -> t option + val substring_extraction: t -> t -> bool * bool val string_comparison: t -> t -> int option -> idx end @@ -1270,6 +1271,18 @@ struct (* string functions *) + let to_null_byte_domain s = + let last_null = Z.of_int (String.length s) in + let rec build_set i set = + if Z.geq (Z.of_int i) last_null then + MayNulls.add last_null set + else + match String.index_from_opt s i '\x00' with + | Some i -> build_set (i + 1) (MayNulls.add (Z.of_int i) set) + | None -> MayNulls.add last_null set in + let set = build_set 0 (MayNulls.empty ()) in + (set, set, Idx.of_int ILong (Z.succ last_null)) + (** Returns an abstract value with at most one null byte marking the end of the string *) let to_string (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) @@ -1386,9 +1399,9 @@ struct else Idx.of_interval !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set, must_nulls_min_elt must_nulls_set) - let string_copy (must_nulls_set1, may_nulls_set1, size1) ar2 n = + let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) - let update_sets must_nulls_set2 may_nulls_set2 size2 len2 = + let update_sets must_nulls_set2' may_nulls_set2' size2' len2 = match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> (if Z.lt max_size1 min_len2 then @@ -1396,19 +1409,19 @@ struct else if Z.lt min_size1 max_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = match Idx.minimal size2 with + let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in (* get must nulls from src string < minimal size of dest *) - must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 + must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 (* and keep indexes of dest >= maximal strlen of src *) |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = - let max_size2 = match idx_maximal size2 with + let max_size2 = match idx_maximal size2' with | Some max_size2 -> max_size2 | None -> max_size1 in (* get may nulls from src string < maximal size of dest *) - may_nulls_filter (Z.gt max_size1) may_nulls_set2 max_size2 + may_nulls_filter (Z.gt max_size1) may_nulls_set2' max_size2 (* and keep indexes of dest >= minimal strlen of src *) |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) @@ -1416,14 +1429,14 @@ struct (if Z.lt min_size1 max_len2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = match Idx.minimal size2 with + let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 + must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) - may_nulls_set2 + may_nulls_set2' |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> @@ -1433,15 +1446,15 @@ struct M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = match Idx.minimal size2 with + let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 in + must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = - let max_size2 = match idx_maximal size2 with + let max_size2 = match idx_maximal size2' with | Some max_size2 -> max_size2 | None -> max_size1 in - may_nulls_filter (Z.gt max_size1) may_nulls_set2 max_size2 + may_nulls_filter (Z.gt max_size1) may_nulls_set2' max_size2 |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> @@ -1449,29 +1462,54 @@ struct M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = match Idx.minimal size2 with + let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2 min_size2 in + must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) - may_nulls_set2 + may_nulls_set2' |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (MustNulls.top (), MayNulls.top (), size1) in - - (* TODO: would it be useful to warn if size of ar2 is (potentially bigger) than size of ar1? *) + + (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) + let sizes_warning size2 = + (match Idx.minimal size1, idx_maximal size1, Idx.minimal size2, idx_maximal size2 with + | Some min_size1, _, Some min_size2, _ when Z.lt min_size1 min_size2 -> + if not (MayNulls.exists (Z.gt min_size1) may_nulls_set2) then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + else if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + | Some min_size1, _, _, Some max_size2 when Z.lt min_size1 max_size2 -> + if not (MayNulls.exists (Z.gt min_size1) may_nulls_set2) then + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + else if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + | Some min_size1, _, _, None -> + if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + | _, Some max_size1, _, Some max_size2 when Z.lt max_size1 max_size2 -> + if not (MustNulls.exists (Z.gt max_size1) must_nulls_set2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + |_, Some max_size1, _, None -> + if not (MustNulls.exists (Z.gt max_size1) must_nulls_set2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + | _ -> ()) in + match n with (* strcpy *) | None -> - let must_nulls_set2, may_nulls_set2, size2 = to_string ar2 in - let strlen2 = to_string_length ar2 in - update_sets must_nulls_set2 may_nulls_set2 size2 strlen2 + sizes_warning size2; + let must_nulls_set2', may_nulls_set2', size2' = to_string (must_nulls_set2, may_nulls_set2, size2) in + let strlen2 = to_string_length (must_nulls_set2, may_nulls_set2, size2) in + update_sets must_nulls_set2' may_nulls_set2' size2' strlen2 (* strncpy = exactly n bytes from src are copied to dest *) | Some n when n >= 0 -> - let must_nulls_set2, may_nulls_set2, size2 = to_n_string ar2 n in - update_sets must_nulls_set2 may_nulls_set2 size2 (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + sizes_warning (Idx.of_int ILong (Z.of_int n)); + let must_nulls_set2', may_nulls_set2', size2' = to_n_string (must_nulls_set2, may_nulls_set2, size2) n in + update_sets must_nulls_set2' may_nulls_set2' size2' (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) | _ -> (MustNulls.top (), MayNulls.top (), size1) let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = @@ -1606,9 +1644,9 @@ struct | _ -> (MustNulls.top (), MayNulls.top (), size1) let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = - (* if needle is empty string, i.e. certain null byte at index 0, return haystack as string *) + (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) if MustNulls.mem Z.zero must_nulls_set_needle then - Some (to_string haystack) + false, true else let haystack_len = to_string_length haystack in let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in @@ -1616,10 +1654,10 @@ struct | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) if Z.lt haystack_max needle_min then - None + true, false else - Some (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) - | _ -> Some (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) + false, false + | _ -> false, false let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let compare n n_exists = @@ -1836,34 +1874,96 @@ struct let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = let f_get = F.get ask t_f i in - let n_get = N.get ask t_n i in - match Val.is_int_ikind f_get, n_get with - | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) - | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) - | _ -> f_get - let set (ask:VDQ.t) (t_f, t_n) i v = (F.set ask t_f i v, N.set ask t_n i v) - let make ?(varAttr=[]) ?(typAttr=[]) i v = (F.make i v, N.make i v) - let length (_, t_n) = N.length t_n + if get_bool "ana.base.arrays.nullbytes" then + let n_get = N.get ask t_n i in + match Val.is_int_ikind f_get, n_get with + | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) + | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) + | _ -> f_get + else + f_get + let set (ask:VDQ.t) (t_f, t_n) i v = + if get_bool "ana.base.arrays.nullbytes" then + (F.set ask t_f i v, N.set ask t_n i v) + else + (F.set ask t_f i v, N.top ()) + let make ?(varAttr=[]) ?(typAttr=[]) i v = + if get_bool "ana.base.arrays.nullbytes" then + (F.make i v, N.make i v) + else + (F.make i v, N.top ()) + let length (t_f, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + N.length t_n + else + F.length t_f let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (F.move_if_affected ask t_f v f, N.move_if_affected ask t_n v f) let get_vars_in_e (t_f, _) = F.get_vars_in_e t_f - let map f (t_f, t_n) = (F.map f t_f, N.map f t_n) - let fold_left f acc (t_f, t_n) = F.fold_left f acc t_f + let map f (t_f, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + (F.map f t_f, N.map f t_n) + else + (F.map f t_f, N.top ()) + let fold_left f acc (t_f, _) = F.fold_left f acc t_f - let content_to_top (t_f, t_n) = (F.content_to_top t_f, N.content_to_top t_n) + let content_to_top (t_f, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + (F.content_to_top t_f, N.content_to_top t_n) + else + (F.content_to_top t_f, N.top ()) - let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) - let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) - let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 + let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + (F.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) + else + (F.smart_join x y t_f1 t_f2, N.top ()) + let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) + else + (F.smart_widen x y t_f1 t_f2, N.top ()) + let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 + else + F.smart_leq x y t_f1 t_f2 - let to_string_length (_, t_n) = N.to_string_length t_n - let string_copy (t_f1, t_n1) (_, t_n2) n = (F.content_to_top t_f1, N.string_copy t_n1 t_n2 n) - let string_concat (t_f1, t_n1) (_, t_n2) n = (F.content_to_top t_f1, N.string_concat t_n1 t_n2 n) - let substring_extraction (t_f1, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with - | Some res -> Some (F.content_to_top t_f1, res) - | None -> None - let string_comparison (_, t_n1) (_, t_n2) n = N.string_comparison t_n1 t_n2 n + let to_null_byte_domain s = + if get_bool "ana.base.arrays.nullbytes" then + (F.top (), N.to_null_byte_domain s) + else + (F.top (), N.top ()) + let to_string_length (_, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + N.to_string_length t_n + else + Idx.top_of !Cil.kindOfSizeOf + let string_copy (t_f1, t_n1) (_, t_n2) n = + if get_bool "ana.base.arrays.nullbytes" then + (F.content_to_top t_f1, N.string_copy t_n1 t_n2 n) + else + (F.content_to_top t_f1, N.top ()) + let string_concat (t_f1, t_n1) (_, t_n2) n = + if get_bool "ana.base.arrays.nullbytes" then + (F.content_to_top t_f1, N.string_concat t_n1 t_n2 n) + else + (F.content_to_top t_f1, N.top ()) + let substring_extraction (_, t_n1) (_, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + N.substring_extraction t_n1 t_n2 + else + false, false + let string_comparison (_, t_n1) (_, t_n2) n = + if get_bool "ana.base.arrays.nullbytes" then + N.string_comparison t_n1 t_n2 n + else + Idx.top_of IInt - let update_length newl (t_f, t_n) = (F.update_length newl t_f, N.update_length newl t_n) + let update_length newl (t_f, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + (F.update_length newl t_f, N.update_length newl t_n) + else + (F.update_length newl t_f, N.top ()) let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ask t_f, N.project ask t_n) let invariant ~value_invariant ~offset ~lval (t_f, _) = F.invariant ~value_invariant ~offset ~lval t_f end diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index dc1b381340..894fa9192e 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -79,6 +79,9 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret (* overwrites get of module S *) + val to_null_byte_domain: string -> t + (* Converts a string to its abstract value in the NullByte domain *) + val to_string_length: t -> idx (** Returns length of string represented by input abstract value *) @@ -91,10 +94,11 @@ sig * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of * [s2] if present *) - val substring_extraction: t -> t -> t option - (** [substring_extraction haystack needle] returns None if the string represented by the - * abstract value [needle] surely isn't a substring of [haystack], Some [to_string haystack] - * if [needle] is empty the empty string, else Some top *) + val substring_extraction: t -> t -> bool * bool + (** [substring_extraction haystack needle] returns [is_null_ptr, is_offset_0], i.e. + * [true, false] if the string represented by the abstract value [needle] surely isn't a + * substring of [haystack], [false, true] if [needle] is the empty string, + * else [false, false] *) val string_comparison: t -> t -> int option -> idx (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string @@ -151,7 +155,7 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Like partitioned but additionally manages the length of the array. *) -module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): SMinusDomainAndRet with type value = Val.t and type idx = Idx.t +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t (** This functor creates an array representation by the indexes of all null bytes * the array must and may contain. This is useful to analyze strings, i.e. null- * terminated char arrays, and particularly to determine if operations on strings @@ -163,4 +167,6 @@ module FlagHelperAttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: (** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) module AttributeConfiguredArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t -(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte in parallel. *) +(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte + * in parallel if flag "ana.base.arrays.nullbytes" is set. +*) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 2ae980369e..6fa3b21731 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -256,7 +256,7 @@ struct | _ -> Top let tag_name : t -> string = function - | Top -> "Top" | Int _ -> "Int" | Float _ -> "Float" | Address _ -> "Address" | Struct _ -> "Struct" | Union _ -> "Union" | Array _ -> "Array" | Blob _ -> "Blob" | Thread _ -> "Thread" | Mutex -> "Mutex" | MutexAttr _ -> "MutexAttr" | JmpBuf _ -> "JmpBuf" | Bot -> "Bot" + | Top -> "Top" | Int _ -> "Int" | Float _ -> "Float" | Address _ -> "Address" | Struct _ -> "Struct" | Union _ -> "Union" | Array _ -> "Array" | Blob _ -> "Blob" | Thread _ -> "Thread" | Mutex -> "Mutex" | MutexAttr _ -> "MutexAttr" | JmpBuf _ -> "JmpBuf" | Bot -> "Bot" include Printable.Std let name () = "compound" diff --git a/src/util/options.schema.json b/src/util/options.schema.json index 02fc929a8a..471ce8c31d 100644 --- a/src/util/options.schema.json +++ b/src/util/options.schema.json @@ -685,6 +685,12 @@ "description": "Indicates how many values will the unrolled part of the unrolled array domain contain.", "type": "integer", "default": 0 + }, + "nullbytes": { + "title": "ana.base.arrays.nullbytes", + "description": "Whether the Null Byte array domain should be activated.", + "type": "boolean", + "default": false } }, "additionalProperties": false diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 1cfa33a689..180d9a00bc 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes #include #include @@ -55,7 +55,7 @@ int main() { char* cmp = strstr(s1, "bab"); __goblint_check(cmp != NULL); // UNKNOWN - i = strcmp(cmp, "babcd"); // WARN: no check if cmp != NULL (even if it obviously is != NULL) + i = strcmp(cmp, "babcd"); // NOWARN: cmp != NULL __goblint_check(i == 0); // UNKNOWN i = strncmp(s4, s3, 4); diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 20e8cababb..2d1b1bb07f 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes #include #include @@ -161,10 +161,9 @@ void example8() { char s2[] = "test"; // must and may null at 4 char cmp[50]; - strcpy(cmp, strstr(s1, empty)); // WARN - size_t len = strlen(cmp); // WARN - __goblint_check(len == 11); // UNKNOWN because can't directly assign result of strstr to cmp, - // TODO: might make handling of this useless in NullByte domain? + strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL + size_t len = strlen(cmp); + __goblint_check(len == 11); // TODO: shouldn't this be known? char* cmp_ptr = strstr(s2, s1); __goblint_check(cmp_ptr == NULL); From 6bf2d775ae2cecd8e73ca47bd2884c290ea74538 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 4 Jul 2023 16:24:38 +0200 Subject: [PATCH 014/233] Pass argument to `move_if_affected` --- src/cdomains/arrayDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index f10988fda9..7f2e8ce2ee 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1897,7 +1897,7 @@ struct N.length t_n else F.length t_f - let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (F.move_if_affected ask t_f v f, N.move_if_affected ask t_n v f) + let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (F.move_if_affected ~replace_with_const ask t_f v f, N.move_if_affected ~replace_with_const ask t_n v f) let get_vars_in_e (t_f, _) = F.get_vars_in_e t_f let map f (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then From 60d06874f62687227db5afd4bf95163f79a2912e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 4 Jul 2023 16:39:19 +0200 Subject: [PATCH 015/233] More missing optional arguments --- src/cdomains/arrayDomain.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7f2e8ce2ee..2aa7c12976 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1873,9 +1873,9 @@ struct let domain_of_t (t_f, _) = F.domain_of_t t_f let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = - let f_get = F.get ask t_f i in + let f_get = F.get ~checkBounds ask t_f i in if get_bool "ana.base.arrays.nullbytes" then - let n_get = N.get ask t_n i in + let n_get = N.get ~checkBounds ask t_n i in match Val.is_int_ikind f_get, n_get with | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) @@ -1889,9 +1889,9 @@ struct (F.set ask t_f i v, N.top ()) let make ?(varAttr=[]) ?(typAttr=[]) i v = if get_bool "ana.base.arrays.nullbytes" then - (F.make i v, N.make i v) + (F.make ~varAttr ~typAttr i v, N.make i v) else - (F.make i v, N.top ()) + (F.make ~varAttr ~typAttr i v, N.top ()) let length (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.length t_n @@ -1964,6 +1964,6 @@ struct (F.update_length newl t_f, N.update_length newl t_n) else (F.update_length newl t_f, N.top ()) - let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ask t_f, N.project ask t_n) + let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ~varAttr ~typAttr ask t_f, N.project ~varAttr ~typAttr ask t_n) let invariant ~value_invariant ~offset ~lval (t_f, _) = F.invariant ~value_invariant ~offset ~lval t_f end From 3b2f4a55736e83350fe71b345cf0d0beb1fd66ef Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 5 Jul 2023 23:04:53 +0200 Subject: [PATCH 016/233] Fixed integration in base using get thanks to Michael's workaround --- src/analyses/base.ml | 125 +++++++++--------- .../73-strings/01-string_literals.c | 2 +- .../regression/73-strings/03-string_basics.c | 14 +- tests/regression/73-strings/04-char_arrays.c | 2 +- 4 files changed, 72 insertions(+), 71 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index dbe6438fca..441444e69a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2030,46 +2030,66 @@ struct (* do nothing if all characters are needed *) | _ -> None in + let address_from_value (v:value) = match v with + | Address a -> + let rec lo:'a Offset_intf.t -> 'a Offset_intf.t = function + | `Index (i, `NoOffset) -> `NoOffset + | `NoOffset -> `NoOffset + | `Field (f, o) -> `Field (f, lo o) + | `Index (i, o) -> `Index (i, lo o) in + let rmLastOffset = function + | Addr.Addr (v, o) -> Addr.Addr (v, lo o) + | other -> other in + AD.map rmLastOffset a + | _ -> raise (Failure "String function: not an address") + in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_a, s1_typ = addr_type_of_exp s1 in - let s2_a, s2_typ = addr_type_of_exp s2 in + let s1_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in + let s1_a = address_from_value s1_v in + let s1_typ = AD.type_of s1_a in + let s2_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in + let s2_a = address_from_value s2_v in + let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) - if AD.type_of s1_a = charPtrType && AD.type_of s2_a = charPtrType then + if s1_typ = charPtrType && s2_typ = charPtrType then begin match lv, op_addr with | Some lv_val, Some f -> (* when whished types coincide, compute result of operation op_addr, otherwise use top *) let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let lv_typ = Cilfacade.typeOfLval lv_val in if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - lv_a, lv_typ, (f s1_a s2_a), None + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - lv_a, lv_typ, (f s1_a s2_a), None + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) else - lv_a, lv_typ, (VD.top_value (unrollType lv_typ)), None + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) | _ -> (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) let _ = AD.string_writing_defined s1_a in - s1_a, s1_typ, VD.top_value (unrollType s1_typ), None + set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - let s1_lval = mkMem ~addr:(Cil.stripCasts s1) ~off:NoOffset in - let s2_lval = mkMem ~addr:(Cil.stripCasts s2) ~off:NoOffset in - match s1_lval, s2_lval with - | (Var v_s1, _), (Var v_s2, _) -> - begin match CPA.find_opt v_s1 st.cpa, CPA.find_opt v_s2 st.cpa with - | Some (Array array_s1), Some (Array array_s2) -> lv_a, lv_typ, op_array array_s1 array_s2, Some v_s1 - | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), None - end - | (Var v_s1, _), _ -> - begin match CPA.find_opt v_s1 st.cpa with - | Some (Array array_s1) -> lv_a, lv_typ, Array(CArrays.content_to_top array_s1), Some v_s1 - | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), Some v_s1 - end - | _ -> lv_a, lv_typ, VD.top_value (unrollType lv_typ), None + begin match get (Analyses.ask_of_ctx ctx) gs st s1_a None, get (Analyses.ask_of_ctx ctx) gs st s2_a None with + | Array array_s1, Array array_s2 -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, _ when s2_typ = charPtrType -> + let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in + let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | _, Array array_s2 when s1_typ = charPtrType -> + (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) + if op_addr = None then + let _ = AD.string_writing_defined s1_a in + set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + else + let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in + let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + end in let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> @@ -2103,42 +2123,23 @@ struct VD.top_value (unrollType dest_typ) in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - | Strcpy { dest = dst; src; n }, _ -> - let dest_a, dest_typ, value, var = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_copy ar1 ar2 (eval_n n))) in - begin match var with - | Some v -> {st with cpa = CPA.add v value st.cpa} - | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - end - | Strcat { dest = dst; src; n }, _ -> - let dest_a, dest_typ, value, var = string_manipulation dst src None false None (fun ar1 ar2 -> Array(CArrays.string_concat ar1 ar2 (eval_n n))) in - begin match var with - | Some v -> {st with cpa = CPA.add v value st.cpa} - | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - end + | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) + | Strcat { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_concat ar1 ar2 (eval_n n))) | Strlen s, _ -> begin match lv with | Some lv_val -> let dest_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let lval = mkMem ~addr:(Cil.stripCasts s) ~off:NoOffset in - let address = eval_lv (Analyses.ask_of_ctx ctx) gs st lval in - let (value:value) = + let v = eval_rv (Analyses.ask_of_ctx ctx) gs st s in + let a = address_from_value v in + let value:value = (* if s string literal, compute strlen in string literals domain *) - if AD.type_of address = charPtrType then - Int(AD.to_string_length address) + if AD.type_of a = charPtrType then + Int (AD.to_string_length a) (* else compute strlen in array domain *) else - (* (* TODO: why isn't the following working? *) - begin match get (Analyses.ask_of_ctx ctx) gs st address None with - | Array array_s -> Int(CArrays.to_string_length array_s) - | _ -> VD.top_value (unrollType dest_typ) - end) in *) - begin match lval with - | (Var v, _) -> - begin match CPA.find_opt v st.cpa with - | Some (Array array_s) -> Int(CArrays.to_string_length array_s) - | _ -> VD.top_value (unrollType dest_typ) - end + begin match get (Analyses.ask_of_ctx ctx) gs st a None with + | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value @@ -2147,25 +2148,25 @@ struct | Strstr { haystack; needle }, _ -> begin match lv with | Some lv_val -> - (* when haystack, needle and dest type coincide, check if needle is a substring of haystack: - if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, - else use top *) - let dest_a, dest_typ, value, _ = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) + (* check if needle is a substring of haystack in string literals domain if haystack and needle are string literals, + else check in null bytes domain if both haystack and needle are / can be transformed to an array domain representation; + if needle is substring, assign the substring of haystack starting at the first occurrence of needle to dest, + if it surely isn't, assign a null_ptr *) + string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with - | true, false -> Address(AD.null_ptr) - | false, true -> Address(eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - (* TODO: below, instead of ~off:NoOffset, how to have a top offset = don't know exactly at which index pointing? *) - | _ -> Address(AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) (AD.null_ptr))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + | true, false -> Address (AD.null_ptr) + | false, true -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | _ -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end | Strcmp { s1; s2; n }, _ -> begin match lv with | Some _ -> - (* when s1 and s2 type coincide, compare both both strings completely or their first n characters, otherwise use top *) - let dest_a, dest_typ, value, _ = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int(AD.string_comparison s1_a s2_a (eval_n n)))) - (fun s1_ar s2_ar -> Int(CArrays.string_comparison s1_ar s2_ar (eval_n n))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + (* when s1 and s2 are string literals, compare both completely or their first n characters in the string literals domain; + else compare them in the null bytes array domain if they are / can be transformed to an array domain representation *) + string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int (AD.string_comparison s1_a s2_a (eval_n n)))) + (fun s1_ar s2_ar -> Int (CArrays.string_comparison s1_ar s2_ar (eval_n n))) | None -> st end | Abort, _ -> raise Deadcode diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 42a888d1b4..bc27c917be 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -102,7 +102,7 @@ int main() { // do nothing => no warning #else char s4[] = "hello"; - strcpy(s4, s2); // NOWARN + strcpy(s4, s2); // NOWARN -> null byte array domain not enabled strncpy(s4, s3, 2); // NOWARN char s5[13] = "hello"; diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 180d9a00bc..3487a36be7 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -39,9 +39,9 @@ int main() { __goblint_check(i == 0); // UNKNOWN strcpy(s1, "hi "); - strncpy(s1, s3, 3); - len = strlen(s1); // TODO: produces a false warning -- any possibility to fix? - __goblint_check(len == 3); // UNKNOWN + strncpy(s1, s3, 3); // WARN + len = strlen(s1); + __goblint_check(len == 3); char tmp[] = "hi "; len = strlen(tmp); @@ -64,10 +64,10 @@ int main() { i = strncmp(s4, s3, 5); __goblint_check(i > 0); // UNKNOWN - strncpy(s1, "", 20); + strncpy(s1, "", 20); // WARN strcpy(tmp, "\0hi"); i = strcmp(s1, tmp); - __goblint_check(i == 0); // UNKNOWN + __goblint_check(i == 0); char tmp2[] = ""; strcpy(s1, tmp2); @@ -75,11 +75,11 @@ int main() { __goblint_check(i == 0); i = strcmp(s1, tmp); - __goblint_check(i == 0); // UNKNOWN + __goblint_check(i == 0); concat_1(s1, 30); len = strlen(s1); - __goblint_check(len == 30); // UNKNOWN + __goblint_check(len == 30); cmp = strstr(s1, "0"); __goblint_check(cmp == NULL); // UNKNOWN diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 2d1b1bb07f..940960569f 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -163,7 +163,7 @@ void example8() { char cmp[50]; strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL size_t len = strlen(cmp); - __goblint_check(len == 11); // TODO: shouldn't this be known? + __goblint_check(len == 11); char* cmp_ptr = strstr(s2, s1); __goblint_check(cmp_ptr == NULL); From 5873e5f8f5f2fce13db34210cece933a1570b5c1 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 10 Jul 2023 18:46:39 +0200 Subject: [PATCH 017/233] Tackled feedback: minor improvements and logic fix for not_null --- src/analyses/base.ml | 1 + src/cdomains/arrayDomain.ml | 442 ++++++++++--------- src/cdomains/arrayDomain.mli | 9 +- src/cdomains/valueDomain.ml | 22 + tests/regression/73-strings/04-char_arrays.c | 5 +- 5 files changed, 260 insertions(+), 219 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 441444e69a..9ded583c20 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2082,6 +2082,7 @@ struct | _, Array array_s2 when s1_typ = charPtrType -> (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) if op_addr = None then + (* triggers warning, function only evaluated for side-effects *) let _ = AD.string_writing_defined s1_a in set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) else diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 2aa7c12976..35f87cee81 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -39,7 +39,7 @@ let get_domain ~varAttr ~typAttr = let can_recover_from_top x = x <> TrivialDomain -module type SMinusDomainAndRet = +module type S0 = sig include Lattice.S type idx @@ -65,7 +65,7 @@ end module type S = sig - include SMinusDomainAndRet + include S0 val domain_of_t: t -> domain val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value @@ -73,7 +73,7 @@ end module type Str = sig - include SMinusDomainAndRet + include S0 type ret = Null | NotNull | Top @@ -90,7 +90,7 @@ end module type StrWithDomain = sig include Str - + val domain_of_t: t -> domain val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end @@ -106,9 +106,10 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps - + val null: unit -> t val is_null: t -> bool + val is_not_null: t -> bool val is_int_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t @@ -994,6 +995,53 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end +module HelperFunctionsIndexMustMaySets = +struct + module MustSet = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All indexes" end)) + module MaySet = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All indexes" end) + + let compute_set len = + List.init (Z.to_int len) (fun i -> i) + |> List.map Z.of_int + |> MustSet.of_list + + let must_nulls_remove i must_nulls_set min_size = + if MustSet.is_bot must_nulls_set then + MustSet.remove i (compute_set min_size) + else + MustSet.remove i must_nulls_set + + let must_nulls_filter cond must_nulls_set min_size = + if MustSet.is_bot must_nulls_set then + MustSet.filter cond (compute_set min_size) + else + MustSet.filter cond must_nulls_set + + let must_nulls_min_elt must_nulls_set = + if MustSet.is_bot must_nulls_set then + Z.zero + else + MustSet.min_elt must_nulls_set + + let may_nulls_remove i may_nulls_set max_size = + if MaySet.is_top may_nulls_set then + MaySet.remove i (compute_set max_size) + else + MaySet.remove i may_nulls_set + + let may_nulls_filter cond may_nulls_set max_size = + if MaySet.is_top may_nulls_set then + MaySet.filter cond (compute_set max_size) + else + MaySet.filter cond may_nulls_set + + let may_nulls_min_elt may_nulls_set = + if MaySet.is_top may_nulls_set then + Z.zero + else + MaySet.min_elt may_nulls_set +end + module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = struct module MustNulls = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) @@ -1001,6 +1049,8 @@ struct (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod3 (MustNulls) (MayNulls) (Idx) + include HelperFunctionsIndexMustMaySets + let name () = "arrays containing null bytes" type idx = Idx.t type value = Val.t @@ -1013,13 +1063,18 @@ struct | None -> None let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = - let rec all_indexes_must_null i max = - if Z.gt i max then - true - else if MustNulls.mem i must_nulls_set then - all_indexes_must_null (Z.succ i) max + let all_indexes_must_null i max = + let rec check_all_indexes i = + if Z.gt i max then + true + else if MustNulls.mem i must_nulls_set then + check_all_indexes (Z.succ i) + else + false in + if Z.lt (Z.of_int (MustNulls.cardinal must_nulls_set)) (Z.sub max i) then + false else - false in + check_all_indexes i in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1028,8 +1083,6 @@ struct let max_i = idx_maximal i in let min_size = min size in - (* warn if index is (potentially) out of bounds *) - if checkBounds then (array_oob_check (module Idx) ((must_nulls_set, may_nulls_set), size) (e, i)); match max_i, idx_maximal size with (* if there is no maximum value in index interval *) | None, _ -> @@ -1061,58 +1114,6 @@ struct (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top - (* helper functions *) - let must_nulls_remove i must_nulls_set min_size = - let rec compute_set acc i = - if Z.geq i min_size then - acc - else - compute_set (MustNulls.add i acc) (Z.succ i) in - if MustNulls.is_bot must_nulls_set then - MustNulls.remove i (compute_set (MustNulls.empty ()) Z.zero) - else - MustNulls.remove i must_nulls_set - let must_nulls_filter cond must_nulls_set min_size = - let rec compute_set acc i = - if Z.geq i min_size then - acc - else - compute_set (MustNulls.add i acc) (Z.succ i) in - if MustNulls.is_bot must_nulls_set then - MustNulls.filter cond (compute_set (MustNulls.empty ()) Z.zero) - else - MustNulls.filter cond must_nulls_set - let must_nulls_min_elt must_nulls_set = - if MustNulls.is_bot must_nulls_set then - Z.zero - else - MustNulls.min_elt must_nulls_set - let may_nulls_remove i may_nulls_set max_size = - let rec compute_set acc i = - if Z.geq i max_size then - acc - else - compute_set (MayNulls.add i acc) (Z.succ i) in - if MayNulls.is_top may_nulls_set then - MayNulls.remove i (compute_set (MayNulls.empty ()) Z.zero) - else - MayNulls.remove i may_nulls_set - let may_nulls_filter cond may_nulls_set max_size = - let rec compute_set acc i = - if Z.geq i max_size then - acc - else - compute_set (MayNulls.add i acc) (Z.succ i) in - if MayNulls.is_top may_nulls_set then - MayNulls.filter cond (compute_set (MayNulls.empty ()) Z.zero) - else - MayNulls.filter cond may_nulls_set - let may_nulls_min_elt may_nulls_set = - if MayNulls.is_top may_nulls_set then - Z.zero - else - MayNulls.min_elt may_nulls_set - let set (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) v = let rec add_indexes i max may_nulls_set = if Z.gt i max then @@ -1131,32 +1132,34 @@ struct match idx_maximal size with (* if size has no upper limit *) | None -> - (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - if Z.lt i min_size && Val.is_null v then - (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) - (* ..., i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) - else if Z.lt i min_size then + (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) + if Val.is_not_null v && not (MayNulls.is_top may_nulls_set) then (must_nulls_remove i must_nulls_set min_size, MayNulls.remove i may_nulls_set, size) - (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) + else if Val.is_not_null v then + (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) + (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + else if Z.lt i min_size && Val.is_null v then + (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) else if Val.is_null v then (must_nulls_set, MayNulls.add i may_nulls_set, size) - (* ..., i >= minimal size and value <> null, remove i only from must_nulls_set *) + (* ... and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else - (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) + (must_nulls_remove i must_nulls_set min_size, MayNulls.add i may_nulls_set, size) | Some max_size -> - (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - if Z.lt i min_size && Val.is_null v then - (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) - (* if i < minimal size and value <> null, remove i from must_nulls_set and may_nulls_set *) - else if Z.lt i min_size then + (* if value <> null, remove i from must_nulls_set and may_nulls_set *) + if Val.is_not_null v then (must_nulls_remove i must_nulls_set min_size, may_nulls_remove i may_nulls_set max_size, size) - (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) + (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + else if Z.lt i min_size && Val.is_null v then + (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) else if Z.lt i max_size && Val.is_null v then (must_nulls_set, MayNulls.add i may_nulls_set, size) - (* if minimal size <= i < maximal size and value <> null, remove i only from must_nulls_set *) + (* if i < maximal size and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else if Z.lt i max_size then - (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) - (* if i >= maximal size, return tuple unmodified *) + (must_nulls_remove i must_nulls_set min_size, MayNulls.add i may_nulls_set, size) + (* if i >= maximal size, return tuple unmodified *) else (must_nulls_set, may_nulls_set, size) in @@ -1164,7 +1167,7 @@ struct (* if value = null, return must_nulls_set unmodified as not clear which index is set to null *) if Val.is_null v then must_nulls_set - (* if value <> null, only keep indexes must_i < minimal index and must_i > maximal index *) + (* if value <> null or unknown, only keep indexes must_i < minimal index and must_i > maximal index *) else if Z.equal min_i Z.zero && Z.geq max_i min_size then MustNulls.top () else @@ -1172,9 +1175,9 @@ struct let set_interval_may min_i max_i = (* if value <> null, return may_nulls_set unmodified as not clear which index is set to value *) - if not (Val.is_null v) then + if Val.is_not_null v then may_nulls_set - (* if value = null *) + (* if value = null or unknown *) else match idx_maximal size with (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) @@ -1193,16 +1196,27 @@ struct match max_i with (* if no maximum number in index interval *) | None -> - (* ..., value = null*) - if Val.is_null v && idx_maximal size = None then - match idx_maximal size with - (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> (must_nulls_set, MayNulls.top (), size) - (* ..., add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) - (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) - else - (must_nulls_filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) + (* ..., value = null *) + (if Val.is_null v && idx_maximal size = None then + match idx_maximal size with + (* ... and there is no maximal size, modify may_nulls_set to top *) + | None -> (must_nulls_set, MayNulls.top (), size) + (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) + | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) + (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) + else if Val.is_not_null v then + (must_nulls_filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) + (*..., value unknown *) + else + match Idx.minimal size, idx_maximal size with + (* ... and size unknown, modify both sets to top *) + | None, None -> (MustNulls.top (), MayNulls.top (), size) + (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) + | Some min_size, None -> (must_nulls_filter (Z.gt min_size) must_nulls_set min_size, MayNulls.top (), size) + (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) + | None, Some max_size -> (MustNulls.top (), add_indexes min_i (Z.pred max_size) may_nulls_set, size) + (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) + | Some min_size, Some max_size -> (must_nulls_filter (Z.gt min_size) must_nulls_set min_size, add_indexes min_i (Z.pred max_size) may_nulls_set, size)) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then set_exact min_i @@ -1216,7 +1230,7 @@ struct | Some min_i, Some max_i -> if Z.lt min_i Z.zero && Z.lt max_i Z.zero then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; - Z.zero, Some Z.zero) + Z.zero, Some Z.zero) else if Z.lt min_i Z.zero then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; Z.zero, Some max_i) @@ -1225,26 +1239,26 @@ struct | None, Some max_i -> if Z.lt max_i Z.zero then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; - Z.zero, Some Z.zero) + Z.zero, Some Z.zero) else Z.zero, Some max_i | Some min_i, None -> if Z.lt min_i Z.zero then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; - Z.zero, None) + Z.zero, None) else min_i, None | None, None -> Z.zero, None in - match max_i, Val.is_null v, Val.is_bot v with + match max_i, Val.is_null v, Val.is_not_null v with (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) | Some max_i, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) | None, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.starting ILong min_i) - (* if value = bot, return (top = no indexes, top = all indexes up to maximal size - 1, size) *) - | Some max_i, false, true -> (MustNulls.top (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) - | None, false, true -> (MustNulls.top (), MayNulls.top (), Idx.starting ILong min_i) (* if value <> null, return (top = no indexes, bot = no indexes, size) *) - | Some max_i, false, false -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) - | None, false, false -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) + | Some max_i, false, true -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) + | None, false, true -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) + (* if value unknown, return (top = no indexes, top = all indexes up to maximal size - 1, size) *) + | Some max_i, false, false -> (MustNulls.top (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) + | None, false, false -> (MustNulls.top (), MayNulls.top (), Idx.starting ILong min_i) let length (_, _, size) = Some size @@ -1257,14 +1271,14 @@ struct * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) if Val.is_null (f (Val.null ())) then (must_nulls_set, MayNulls.top (), size) - (* else also return top for must_nulls_set *) + (* else also return top for must_nulls_set *) else (MustNulls.top (), MayNulls.top (), size) let fold_left f acc _ = f acc (Val.top ()) let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), size) - + let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -1288,17 +1302,17 @@ struct (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; - (must_nulls_set, may_nulls_set, size)) - (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) + (must_nulls_set, may_nulls_set, size)) + (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; - (must_nulls_set, may_nulls_set, size)) + (must_nulls_set, may_nulls_set, size)) else let min_must_null = must_nulls_min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) if Z.equal min_must_null (may_nulls_min_elt may_nulls_set) then (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) - (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with | Some max_size -> (MustNulls.empty (), may_nulls_filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) @@ -1346,68 +1360,68 @@ struct (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) else ((match Idx.minimal size, idx_maximal size with - | Some min_size, Some max_size -> - if Z.gt (Z.of_int n) max_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - else if Z.gt (Z.of_int n) min_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | Some min_size, None -> - if Z.gt (Z.of_int n) min_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | None, Some max_size -> - if Z.gt (Z.of_int n) max_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - | None, None -> ()); - - (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) - if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end - "Resulting string might not be null-terminated because src doesn't contain a null byte"; - match idx_maximal size with - (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) - | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int ILong (Z.of_int n)) - | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) - (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; - * warn as in any case, resulting array not guaranteed to contain null byte *) - else if MustNulls.is_empty must_nulls_set then - let min_may_null = may_nulls_min_elt may_nulls_set in - warn_no_null Z.zero false min_may_null; - (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) - else - let min_must_null = must_nulls_min_elt must_nulls_set in - let min_may_null = may_nulls_min_elt may_nulls_set in - (* warn if resulting array may not contain null byte *) - warn_no_null min_must_null true min_may_null; - (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) - if Z.equal min_must_null min_may_null then - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) - else - (MustNulls.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) + | Some min_size, Some max_size -> + if Z.gt (Z.of_int n) max_size then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + else if Z.gt (Z.of_int n) min_size then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | Some min_size, None -> + if Z.gt (Z.of_int n) min_size then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | None, Some max_size -> + if Z.gt (Z.of_int n) max_size then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + | None, None -> ()); + + (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) + if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "Resulting string might not be null-terminated because src doesn't contain a null byte"; + match idx_maximal size with + (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) + | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int ILong (Z.of_int n)) + | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) + (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; + * warn as in any case, resulting array not guaranteed to contain null byte *) + else if MustNulls.is_empty must_nulls_set then + let min_may_null = may_nulls_min_elt may_nulls_set in + warn_no_null Z.zero false min_may_null; + (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) + else + let min_must_null = must_nulls_min_elt must_nulls_set in + let min_may_null = may_nulls_min_elt may_nulls_set in + (* warn if resulting array may not contain null byte *) + warn_no_null min_must_null true min_may_null; + (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) + if Z.equal min_must_null min_may_null then + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) + else + (MustNulls.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; - match Idx.minimal size with - | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size - | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) - (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) + match Idx.minimal size with + | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size + | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustNulls.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; Idx.starting !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set)) - (* else return interval [minimal may null, minimal must null] *) + (* else return interval [minimal may null, minimal must null] *) else Idx.of_interval !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set, must_nulls_min_elt must_nulls_set) - + let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) let update_sets must_nulls_set2' may_nulls_set2' size2' len2 = match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> (if Z.lt max_size1 min_len2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" - else if Z.lt min_size1 max_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.lt min_size1 max_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 @@ -1427,7 +1441,7 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 @@ -1441,9 +1455,9 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" - else if Z.lt min_size1 min_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + else if Z.lt min_size1 min_len2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with @@ -1459,7 +1473,7 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with @@ -1516,14 +1530,14 @@ struct let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.lt max_size1 (Z.add minlen1 minlen2) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end - "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (maxlen1_exists && maxlen2_exists && Z.lt min_size1 (Z.add maxlen1 maxlen2)) - || (maxlen1_exists && Z.lt min_size1 (Z.add maxlen1 minlen2)) - || (maxlen2_exists && Z.lt min_size1 (Z.add minlen1 maxlen2)) - || Z.lt min_size1 (Z.add minlen1 minlen2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end - "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest"); + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" + else if (maxlen1_exists && maxlen2_exists && Z.lt min_size1 (Z.add maxlen1 maxlen2)) + || (maxlen1_exists && Z.lt min_size1 (Z.add maxlen1 minlen2)) + || (maxlen2_exists && Z.lt min_size1 (Z.add minlen1 maxlen2)) + || Z.lt min_size1 (Z.add minlen1 minlen2) then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) @@ -1548,7 +1562,7 @@ struct else MayNulls.top () in (MustNulls.top (), may_nulls_set_result, size1) - (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && Z.equal (must_nulls_min_elt must_nulls_set2') (may_nulls_min_elt may_nulls_set2') then let min_i1 = must_nulls_min_elt must_nulls_set1 in let min_i2 = must_nulls_min_elt must_nulls_set2' in @@ -1565,7 +1579,7 @@ struct else MayNulls.top () in (must_nulls_set_result, may_nulls_set_result, size1) - (* else only add all may nulls together <= strlen(dest) + strlen(src) *) + (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else let min_i2 = must_nulls_min_elt must_nulls_set2' in let may_nulls_set2'_until_min_i2 = @@ -1659,40 +1673,40 @@ struct false, false | _ -> false, false - let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) - if (MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2)) - || (n_exists && Z.equal Z.zero n) then - Idx.of_int IInt Z.zero + if (MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2)) + || (n_exists && Z.equal Z.zero n) then + Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) - else if MustNulls.mem Z.zero must_nulls_set1 && not (MayNulls.mem Z.zero may_nulls_set2) then - Idx.ending IInt Z.minus_one + else if MustNulls.mem Z.zero must_nulls_set1 && not (MayNulls.mem Z.zero may_nulls_set2) then + Idx.ending IInt Z.minus_one (* if only s2 = empty string, return positive integer *) - else if MustNulls.mem Z.zero must_nulls_set2 then - Idx.starting IInt Z.one - else - (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) - (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n) - && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set2) n) - && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then - Idx.of_excl_list IInt [Z.zero] - else - Idx.top_of IInt - with Not_found -> Idx.top_of IInt) in + else if MustNulls.mem Z.zero must_nulls_set2 then + Idx.starting IInt Z.one + else + (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) + (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n) + && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set2) n) + && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then + Idx.of_excl_list IInt [Z.zero] + else + Idx.top_of IInt + with Not_found -> Idx.top_of IInt) in match n with (* strcmp *) | None -> (* track any potential buffer overflow and issue warning if needed *) (if MustNulls.is_empty must_nulls_set1 && MayNulls.is_empty may_nulls_set1 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" - else if MustNulls.is_empty must_nulls_set1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" + else if MustNulls.is_empty must_nulls_set1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); (if MustNulls.is_empty must_nulls_set2 && MayNulls.is_empty may_nulls_set2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" - else if MustNulls.is_empty must_nulls_set2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" + else if MustNulls.is_empty must_nulls_set2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); (* compute abstract value for result of strcmp *) compare Z.zero false (* strncmp *) @@ -1703,27 +1717,27 @@ struct let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 | None -> Z.zero in - (* issue a warning if n is (potentially) smaller than array sizes *) + (* issue a warning if n is (potentially) smaller than array sizes *) (match idx_maximal size1 with - | Some max_size1 -> - if Z.gt (Z.of_int n) max_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 is smaller than n bytes" - else if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes" - | None -> - if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes"); + | Some max_size1 -> + if Z.gt (Z.of_int n) max_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 is smaller than n bytes" + else if Z.gt (Z.of_int n) min_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes" + | None -> + if Z.gt (Z.of_int n) min_size1 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes"); (match idx_maximal size2 with - | Some max_size2 -> - if Z.gt (Z.of_int n) max_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 is smaller than n bytes" - else if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes" - | None -> - if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes"); - (* compute abstract value for result of strncmp *) - compare (Z.of_int n) true + | Some max_size2 -> + if Z.gt (Z.of_int n) max_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 is smaller than n bytes" + else if Z.gt (Z.of_int n) min_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes" + | None -> + if Z.gt (Z.of_int n) min_size2 then + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes"); + (* compute abstract value for result of strncmp *) + compare (Z.of_int n) true | _ -> Idx.top_of IInt let update_length new_size (must_nulls_set, may_nulls_set, size) = (must_nulls_set, may_nulls_set, new_size) @@ -1863,7 +1877,7 @@ struct module N = NullByte (Val) (Idx) include Lattice.Prod (F) (N) - + let name () = "AttributeConfiguredArrayDomain" type idx = Idx.t type value = Val.t diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 894fa9192e..e8deae06e0 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -12,7 +12,7 @@ val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain val can_recover_from_top: domain -> bool (** Some domains such as Trivial cannot recover from their value ever being top. {!ValueDomain} handles intialization differently for these *) -module type SMinusDomainAndRet = +module type S0 = sig include Lattice.S type idx @@ -60,7 +60,7 @@ end (** Abstract domains representing arrays. *) module type S = sig - include SMinusDomainAndRet + include S0 val domain_of_t: t -> domain (* Returns the domain used for the array*) @@ -72,7 +72,7 @@ end (** Abstract domains representing strings a.k.a. null-terminated char arrays. *) module type Str = sig - include SMinusDomainAndRet + include S0 type ret = Null | NotNull | Top @@ -126,9 +126,10 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps - + val null: unit -> t val is_null: t -> bool + val is_not_null: t -> bool val is_int_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 6fa3b21731..76f304c37e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -40,6 +40,7 @@ sig val null: unit -> t val is_null: t -> bool + val is_not_null: t -> bool val is_int_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t @@ -278,6 +279,27 @@ struct | None -> false end | _ -> false + let is_not_null = function + | Int n -> + begin match ID.minimal n, ID.maximal n with + | Some min, Some max -> + if Z.gt min Z.zero || Z.lt max Z.zero then + true + else + false + | Some min, None -> + if Z.gt min Z.zero then + true + else + false + | None, Some max -> + if Z.lt max Z.zero then + true + else + false + | _ -> false + end + | _ -> true let is_int_ikind = function | Int n -> Some (ID.ikind n) diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 940960569f..72d5a4637e 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -150,7 +150,10 @@ void example7() { len = strlen(s2); // WARN __goblint_check(len >= 12); // UNKNOWN: loop transformed to interval - s2[4] = s2[5] = s2[6] = s2[7] = 'a'; + s2[4] = 'a'; + s2[5] = 'a'; + s2[6] = 'a'; + s2[7] = 'a'; len = strlen(s2); // WARN: no must nulls and may nulls __goblint_check(len >= 12); } From 40f0de701493334204e8a3619a3e0d9b6262cb6c Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 10 Jul 2023 19:14:45 +0200 Subject: [PATCH 018/233] Fix macOS tests --- src/cdomains/arrayDomain.ml | 2 +- tests/regression/73-strings/01-string_literals.c | 10 +++++----- tests/regression/73-strings/04-char_arrays.c | 12 ++++++++---- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 35f87cee81..f1bab39208 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1001,7 +1001,7 @@ struct module MaySet = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All indexes" end) let compute_set len = - List.init (Z.to_int len) (fun i -> i) + List.init (Z.to_int len) (Fun.id) |> List.map Z.of_int |> MustSet.of_list diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index bc27c917be..159ca57f1c 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -11,7 +11,7 @@ char* hello_world() { void id(char* s) { char* ptr = NULL; // future usage of cmp should warn: workaround for macOS test #ifdef __APPLE__ - #define ID int i = strcmp(ptr, "trigger warning") + #define ID int i = *ptr #else #define ID strcpy(s, s) #endif @@ -71,28 +71,28 @@ int main() { cmp = NULL; // future usage of cmp should warn: workaround for macOS test #ifdef __APPLE__ - #define STRCPY i = strcmp(cmp, "trigger warning") + #define STRCPY i = *cmp #else #define STRCPY strcpy(s1, "hi"); #endif STRCPY; // WARN #ifdef __APPLE__ - #define STRNCPY i = strcmp(cmp, "trigger warning") + #define STRNCPY i = *cmp #else # define STRNCPY strncpy(s1, "hi", 1) #endif STRNCPY; // WARN #ifdef __APPLE__ - #define STRCAT i = strcmp(cmp, "trigger warning") + #define STRCAT i = *cmp #else #define STRCAT strcat(s1, "hi") #endif STRCAT; // WARN #ifdef __APPLE__ - #define STRNCAT i = strcmp(cmp, "trigger warning") + #define STRNCAT i = *cmp #else #define STRNCAT strncat(s1, "hi", 1) #endif diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 72d5a4637e..076169cf05 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -164,10 +164,14 @@ void example8() { char s2[] = "test"; // must and may null at 4 char cmp[50]; - strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL - size_t len = strlen(cmp); - __goblint_check(len == 11); - + #ifdef __APPLE__ + // do nothing => no warning + #else + strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL + size_t len = strlen(cmp); + __goblint_check(len == 11); + #endif + char* cmp_ptr = strstr(s2, s1); __goblint_check(cmp_ptr == NULL); } From 20722581892d8de17684f0d34c94fc2665038639 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt <73504207+nathanschmidt@users.noreply.github.com> Date: Mon, 10 Jul 2023 20:27:10 +0200 Subject: [PATCH 019/233] Fix test 04-char_arrays.c for macOS --- tests/regression/73-strings/04-char_arrays.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 076169cf05..0af19ba968 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -165,12 +165,12 @@ void example8() { char cmp[50]; #ifdef __APPLE__ - // do nothing => no warning + size_t len = 11; #else strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL size_t len = strlen(cmp); - __goblint_check(len == 11); #endif + __goblint_check(len == 11); char* cmp_ptr = strstr(s2, s1); __goblint_check(cmp_ptr == NULL); From 9d21da49f6c477b13fae050a6f5913fffd1a8a2f Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 11 Jul 2023 13:58:02 +0200 Subject: [PATCH 020/233] Updated is_not_null with case for potential null_ptr --- src/cdomains/valueDomain.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 76f304c37e..7480ca12a6 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -299,6 +299,7 @@ struct false | _ -> false end + | Address a when AD.may_be_null a -> false | _ -> true let is_int_ikind = function From 780e02a6eea74b9e8064bda119e9b48ebd0eea0b Mon Sep 17 00:00:00 2001 From: Nathan Schmidt <73504207+nathanschmidt@users.noreply.github.com> Date: Thu, 20 Jul 2023 22:09:36 +0200 Subject: [PATCH 021/233] Update condition for non-zero return by strncmp --- src/cdomains/arrayDomain.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index f1bab39208..7772cec8d4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1687,8 +1687,9 @@ struct Idx.starting IInt Z.one else (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) - (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n) - && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set2) n) + (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) + && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) + && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n || Z.lt (must_nulls_min_elt must_nulls_set2) n ) && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then Idx.of_excl_list IInt [Z.zero] else From 1bf625d8528cf59f3b8b0fac47ca68ded7c57d57 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 20 Jul 2023 22:19:10 +0200 Subject: [PATCH 022/233] Fix indentation --- src/cdomains/arrayDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7772cec8d4..7892826e57 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1688,8 +1688,8 @@ struct else (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) - && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) - && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n || Z.lt (must_nulls_min_elt must_nulls_set2) n ) + && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) + && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n || Z.lt (must_nulls_min_elt must_nulls_set2) n ) && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then Idx.of_excl_list IInt [Z.zero] else From 97cbb4e73fbef33d4e576bab373dfa1c9b0f7aa4 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Fri, 28 Jul 2023 14:15:39 +0200 Subject: [PATCH 023/233] Added examples of thesis --- .../73-strings/01-string_literals.c | 28 ++++++++++++- tests/regression/73-strings/04-char_arrays.c | 42 +++++++++++++++---- 2 files changed, 61 insertions(+), 9 deletions(-) diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 159ca57f1c..9366b516df 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -18,7 +18,28 @@ void id(char* s) { ID; // WARN } -int main() { +void example1() { + char* s1 = "bc\0test"; + char* s2 = "bc"; + char* s3; + if (rand()) + s3 = "aabbcc"; + else + s3 = "ebcdf"; + + int i = strcmp(s1, s2); + __goblint_check(i == 0); + + char* s4 = strstr(s3, s1); + __goblint_check(s4 != NULL); + + size_t len = strlen(s4); + __goblint_check(len >= 3); + __goblint_check(len <= 4); + __goblint_check(len == 3); // UNKNOWN! +} + +void example2() { char* s1 = "abcde"; char* s2 = "abcdfg"; char* s3 = hello_world(); @@ -109,6 +130,11 @@ int main() { strcat(s5, " world"); // NOWARN strncat(s5, "! some further text", 1); // NOWARN #endif +} + +int main() { + example1(); + example2(); return 0; } diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/04-char_arrays.c index 0af19ba968..c86a0b1ebc 100644 --- a/tests/regression/73-strings/04-char_arrays.c +++ b/tests/regression/73-strings/04-char_arrays.c @@ -14,11 +14,37 @@ int main() { example7(); example8(); example9(); + example10(); return 0; } void example1() { + char s1[] = "user1_"; // must and may null at 6 and 7 + char s2[] = "pwd:\0abc"; // must and may null at 4 and 8 + char s3[20]; // no must nulls, all may nulls + + strcpy(s3, s1); // must null at 6, may nulls starting from 6 + + if (rand()) { + s2[4] = ' '; + strncat(s3, s2, 10); // must null at 14, may nulls starting from 14 + } else + strcat(s3, s2); // must null at 10, may nulls starting from 10 + + // s3: no must nulls, may nulls starting from 10 + + s3[14] = '\0'; // must null at 14, may nulls starting from 10 + + size_t len = strlen(s3); + __goblint_check(len >= 10); + __goblint_check(len <= 14); + __goblint_check(len == 10); // UNKNOWN! + + strcpy(s1, s3); // WARN +} + +void example2() { char s1[42]; char s2[20] = "testing"; // must null at 7, may null starting from 7 @@ -33,7 +59,7 @@ void example1() { __goblint_check(len == 14); } -void example2() { +void example3() { char s1[42]; char s2[20] = "testing"; // must null at 7, may null starting from 7 @@ -49,7 +75,7 @@ void example2() { strcpy(s2, s1); // WARN: no must null in s1 } -void example3() { +void example4() { char s1[5] = "abc\0d"; // must and may null at 3 char s2[] = "a"; // must and may null at 1 @@ -63,7 +89,7 @@ void example3() { __goblint_check(len == 3); } -void example4() { +void example5() { char s1[7] = "hello!"; // must and may null at 6 char s2[8] = "goblint"; // must and may null at 7 @@ -73,7 +99,7 @@ void example4() { __goblint_check(len >= 7); // no null byte in s1 } -void example5() { +void example6() { char s1[42] = "a string, i.e. null-terminated char array"; // must and may null at 42 for (int i = 0; i < 42; i += 3) { if (rand() != 42) @@ -97,7 +123,7 @@ void example5() { __goblint_check(len > 40); // UNKNOWN } -void example6() { +void example7() { char s1[50] = "hello"; // must and may null at 5 char s2[] = " world!"; // must and may null at 7 char s3[] = " goblint."; // must and may null at 9 @@ -127,7 +153,7 @@ void example6() { __goblint_check(len < 20); // UNKNOWN } -void example7() { +void example8() { char s1[6] = "abc"; // must and may null at 3 if (rand() == 42) s1[5] = '\0'; // must null at 3, may nulls at 3 and 5 @@ -158,7 +184,7 @@ void example7() { __goblint_check(len >= 12); } -void example8() { +void example9() { char empty[] = ""; char s1[] = "hello world"; // must and may null at 11 char s2[] = "test"; // must and may null at 4 @@ -176,7 +202,7 @@ void example8() { __goblint_check(cmp_ptr == NULL); } -void example9() { +void example10() { char empty1[] = ""; char empty2[] = "\0 also empty"; char s1[] = "hi"; From 545714e6f552495652829fe9a110f414842d0606 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 9 Aug 2023 17:33:54 +0200 Subject: [PATCH 024/233] Add tests from Juliet --- src/cdomains/arrayDomain.ml | 9 +++------ src/cdomains/valueDomain.ml | 2 +- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7892826e57..68e64f125b 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1529,15 +1529,12 @@ struct let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) - (if max_size1_exists && Z.lt max_size1 (Z.add minlen1 minlen2) then + (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (maxlen1_exists && maxlen2_exists && Z.lt min_size1 (Z.add maxlen1 maxlen2)) - || (maxlen1_exists && Z.lt min_size1 (Z.add maxlen1 minlen2)) - || (maxlen2_exists && Z.lt min_size1 (Z.add minlen1 maxlen2)) - || Z.lt min_size1 (Z.add minlen1 minlen2) then + else if (maxlen1_exists && maxlen2_exists && Z.leq min_size1 (Z.add maxlen1 maxlen2)) || not maxlen1_exists || not maxlen2_exists then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end - "The length of the conctenation of the strings in src and dest may be greater than the allocated size for dest"); + "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 7480ca12a6..5dcebf71ce 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -300,7 +300,7 @@ struct | _ -> false end | Address a when AD.may_be_null a -> false - | _ -> true + | _ -> false (* we don't know anything *) let is_int_ikind = function | Int n -> Some (ID.ikind n) From 0acbf242523dfad622fabb252d9c5dbe31575ac1 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 9 Aug 2023 17:34:48 +0200 Subject: [PATCH 025/233] Add tests from Juliet --- tests/regression/73-strings/06-juliet.c | 145 ++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 tests/regression/73-strings/06-juliet.c diff --git a/tests/regression/73-strings/06-juliet.c b/tests/regression/73-strings/06-juliet.c new file mode 100644 index 0000000000..53bc2ba4e9 --- /dev/null +++ b/tests/regression/73-strings/06-juliet.c @@ -0,0 +1,145 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +// TODO: tackle memset -> map it to for loop with set for each cell + +int main() { + CWE121_Stack_Based_Buffer_Overflow__src_char_declare_cpy_01_bad(); + CWE126_Buffer_Overread__CWE170_char_loop_01_bad(); + CWE126_Buffer_Overread__CWE170_char_strncpy_01_bad(); + CWE126_Buffer_Overread__char_declare_loop_01_bad(); + CWE571_Expression_Always_True__string_equals_01_bad(); + CWE665_Improper_Initialization__char_cat_01_bad(); + CWE665_Improper_Initialization__char_ncat_11_bad(); + + return 0; +} + +void CWE121_Stack_Based_Buffer_Overflow__src_char_declare_cpy_01_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + /* FLAW: Initialize data as a large buffer that is larger than the small buffer used in the sink */ + memset(data, 'A', 100-1); /* fill with 'A's */ + data[100-1] = '\0'; /* null terminate */ + { + char dest[50] = ""; + /* POTENTIAL FLAW: Possible buffer overflow if data is larger than dest */ + strcpy(dest, data); // WARN + } +} + +void CWE126_Buffer_Overread__CWE170_char_loop_01_bad() +{ + { + char src[150], dest[100]; + int i; + /* Initialize src */ + memset(src, 'A', 149); + src[149] = '\0'; + for(i=0; i < 99; i++) + { + dest[i] = src[i]; + } + /* FLAW: do not explicitly null terminate dest after the loop */ + __goblint_check(dest[42] != '\0'); + __goblint_check(dest[99] != '\0'); // UNKNOWN + } +} + +void CWE126_Buffer_Overread__CWE170_char_strncpy_01_bad() +{ + { + char data[150], dest[100]; + /* Initialize data */ + memset(data, 'A', 149); + data[149] = '\0'; + /* strncpy() does not null terminate if the string in the src buffer is larger than + * the number of characters being copied to the dest buffer */ + strncpy(dest, data, 99); // WARN + /* FLAW: do not explicitly null terminate dest after the use of strncpy() */ + } +} + +void CWE126_Buffer_Overread__char_declare_loop_01_bad() +{ + char * data; + char dataBadBuffer[50]; + char dataGoodBuffer[100]; + memset(dataBadBuffer, 'A', 50-1); /* fill with 'A's */ + dataBadBuffer[50-1] = '\0'; /* null terminate */ + memset(dataGoodBuffer, 'A', 100-1); /* fill with 'A's */ + dataGoodBuffer[100-1] = '\0'; /* null terminate */ + /* FLAW: Set data pointer to a small buffer */ + data = dataBadBuffer; + { + size_t i, destLen; + char dest[100]; + memset(dest, 'C', 100-1); + dest[100-1] = '\0'; /* null terminate */ + destLen = strlen(dest); + __goblint_check(destLen == 99); + /* POTENTIAL FLAW: using length of the dest where data + * could be smaller than dest causing buffer overread */ + for (i = 0; i < destLen; i++) + { + dest[i] = data[i]; + } + dest[100-1] = '\0'; + } +} + +void CWE665_Improper_Initialization__char_cat_01_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + /* FLAW: Do not initialize data */ + ; /* empty statement needed for some flow variants */ + { + char source[100]; + memset(source, 'C', 100-1); /* fill with 'C's */ + source[100-1] = '\0'; /* null terminate */ + /* POTENTIAL FLAW: If data is not initialized properly, strcat() may not function correctly */ + strcat(data, source); // WARN + } +} + +void CWE571_Expression_Always_True__string_equals_01_bad() +{ + char charString[10] = "true"; + int cmp = strcmp(charString, "true"); + __goblint_check(cmp == 0); // UNKNOWN + + /* FLAW: This expression is always true */ + if (cmp == 0) + { + printf("always prints"); + } +} + +void CWE665_Improper_Initialization__char_ncat_11_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + if(rand()) + { + /* FLAW: Do not initialize data */ + ; /* empty statement needed for some flow variants */ + } + { + size_t sourceLen; + char source[100]; + memset(source, 'C', 100-1); /* fill with 'C's */ + source[100-1] = '\0'; /* null terminate */ + sourceLen = strlen(source); + __goblint_check(sourceLen == 99); + /* POTENTIAL FLAW: If data is not initialized properly, strncat() may not function correctly */ + strncat(data, source, sourceLen); // WARN --> why not?? spurious + } +} From f4d74e2129a7d4e1854d49d7d258a66c04aac472 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 9 Aug 2023 19:14:21 +0200 Subject: [PATCH 026/233] Added larger example --- .../regression/73-strings/07-larger_example.c | 36 +++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 tests/regression/73-strings/07-larger_example.c diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c new file mode 100644 index 0000000000..08676661e6 --- /dev/null +++ b/tests/regression/73-strings/07-larger_example.c @@ -0,0 +1,36 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main() { + char* user; + if (rand()) + user = "Alice"; + else + user = "Bob"; + + if (strcmp(user, "Alice") == 0) + strcpy(user, "++++++++"); // WARN + + char pwd_gen[20]; + + char* p1 = "hello"; + char* p2 = "12345"; + strcat(pwd_gen, p1); // WARN + strncpy(pwd_gen, p2, 6); + __goblint_check(pwd_gen[5] == '\0'); // TODO: fix get in attributeconfiguredarraydomain + strncat(pwd_gen, p1, 4); + __goblint_check(pwd_gen[5] != '\0'); // TODO: fix get in attributeconfiguredarraydomain + + pwd_gen[10] = '\0'; + int cmp = strcmp(pwd_gen, "12345hello"); + __goblint_check(cmp != 0); + + char* pwd = strstr(pwd_gen, p2); + size_t pwd_len = strlen(pwd_gen); + __goblint_check(pwd_len == 9); + + return 0; +} \ No newline at end of file From a24546f55d3f9b0b9c70c836956bfa98c90fcb06 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt <73504207+nathanschmidt@users.noreply.github.com> Date: Wed, 9 Aug 2023 20:35:31 +0200 Subject: [PATCH 027/233] Update 07-larger_example.c --- tests/regression/73-strings/07-larger_example.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c index 08676661e6..950011244b 100644 --- a/tests/regression/73-strings/07-larger_example.c +++ b/tests/regression/73-strings/07-larger_example.c @@ -15,6 +15,8 @@ int main() { strcpy(user, "++++++++"); // WARN char pwd_gen[20]; + for (size_t i = 12; i < 20; i++) + pwd_gen[i] = (char) (rand() % 123); char* p1 = "hello"; char* p2 = "12345"; @@ -33,4 +35,4 @@ int main() { __goblint_check(pwd_len == 9); return 0; -} \ No newline at end of file +} From cc826231df404cad3d77a182477a89e543f39a37 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 10 Aug 2023 20:00:30 +0200 Subject: [PATCH 028/233] Modification to larger example --- tests/regression/73-strings/07-larger_example.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c index 950011244b..5dce3b0cfe 100644 --- a/tests/regression/73-strings/07-larger_example.c +++ b/tests/regression/73-strings/07-larger_example.c @@ -14,6 +14,10 @@ int main() { if (strcmp(user, "Alice") == 0) strcpy(user, "++++++++"); // WARN + __goblint_check(strcmp(user, "Alice") == 0); // UNKNOWN + __goblint_check(strcmp(user, "Bob") == 0); // UNKNOWN + __goblint_check(strcmp(user, "Eve") != 0); // TODO: check implementation, maybe returning top wrong and we should return bot in string literals domain + char pwd_gen[20]; for (size_t i = 12; i < 20; i++) pwd_gen[i] = (char) (rand() % 123); @@ -26,7 +30,6 @@ int main() { strncat(pwd_gen, p1, 4); __goblint_check(pwd_gen[5] != '\0'); // TODO: fix get in attributeconfiguredarraydomain - pwd_gen[10] = '\0'; int cmp = strcmp(pwd_gen, "12345hello"); __goblint_check(cmp != 0); From b122f4c4c00b555bf757956b6c01de3a5bd80e13 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 6 Sep 2023 12:23:19 +0200 Subject: [PATCH 029/233] Fixed cardinal on top, simplified compute_concat --- src/cdomains/arrayDomain.ml | 53 ++++++++++--------- .../regression/73-strings/07-larger_example.c | 2 +- 2 files changed, 30 insertions(+), 25 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 68e64f125b..e1d7062a70 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -253,7 +253,7 @@ struct let get_vars_in_e _ = [] let map f (xl, xr) = ((List.map f xl), f xr) let fold_left f a x = f a (join_of_all_parts x) - let content_to_top x = (Base.top (), Val.top ()) + let content_to_top _ = (Base.top (), Val.top ()) let printXml f (xl,xr) = BatPrintf.fprintf f "\n\n unrolled array\n xl\n%a\n\n @@ -867,7 +867,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, l) + let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) let smart_join _ _ = join let smart_widen _ _ = widen @@ -916,7 +916,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e (x, _) = Base.get_vars_in_e x - let content_to_top (x, l) = (Base.content_to_top x, l) + let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) let smart_join x_eval_int y_eval_int (x,xl) (y,yl) = let l = Idx.join xl yl in @@ -970,7 +970,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, l) + let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) let smart_join _ _ = join let smart_widen _ _ = widen @@ -1071,7 +1071,9 @@ struct check_all_indexes (Z.succ i) else false in - if Z.lt (Z.of_int (MustNulls.cardinal must_nulls_set)) (Z.sub max i) then + if MustNulls.is_bot may_nulls_set then + true + else if Z.lt (Z.of_int (MustNulls.cardinal must_nulls_set)) (Z.sub max i) then false else check_all_indexes i in @@ -1277,7 +1279,7 @@ struct let fold_left f acc _ = f acc (Val.top ()) - let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), size) + let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) let smart_join _ _ = join let smart_widen _ _ = widen @@ -1607,22 +1609,25 @@ struct let compute_concat must_nulls_set2' may_nulls_set2' = let strlen1 = to_string_length (must_nulls_set1, may_nulls_set1, size1) in let strlen2 = to_string_length (must_nulls_set2', may_nulls_set2', size2) in - match Idx.minimal size1, idx_maximal size1, Idx.minimal strlen1, idx_maximal strlen1, Idx.minimal strlen2, idx_maximal strlen2 with - | Some min_size1, Some max_size1, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> - update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' - (* no upper bound for length of concatenation *) - | Some min_size1, Some max_size1, Some minlen1, None, Some minlen2, Some _ - | Some min_size1, Some max_size1, Some minlen1, Some _, Some minlen2, None - | Some min_size1, Some max_size1, Some minlen1, None, Some minlen2, None -> - update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' - (* no upper bound for size of dest *) - | Some min_size1, None, Some minlen1, Some maxlen1, Some minlen2, Some maxlen2 -> - update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' - (* no upper bound for size of dest and length of concatenation *) - | Some min_size1, None, Some minlen1, None, Some minlen2, Some _ - | Some min_size1, None, Some minlen1, Some _, Some minlen2, None - | Some min_size1, None, Some minlen1, None, Some minlen2, None -> - update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with + | Some min_size1, Some minlen1, Some minlen2 -> + begin match idx_maximal size1, idx_maximal strlen1, idx_maximal strlen2 with + | Some max_size1, Some maxlen1, Some maxlen2 -> + update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for length of concatenation *) + | Some max_size1, None, Some _ + | Some max_size1, Some _, None + | Some max_size1, None, None -> + update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest *) + | None, Some maxlen1, Some maxlen2 -> + update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + (* no upper bound for size of dest and length of concatenation *) + | None, None, Some _ + | None, Some _, None + | None, None, None -> + update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + end (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (MustNulls.top (), MayNulls.top (), size1) in @@ -1942,7 +1947,7 @@ struct let to_null_byte_domain s = if get_bool "ana.base.arrays.nullbytes" then - (F.top (), N.to_null_byte_domain s) + (F.make (Idx.top_of ILong) (Val.meet (Val.not_zero_of_ikind IChar) (Val.zero_of_ikind IChar)), N.to_null_byte_domain s) else (F.top (), N.top ()) let to_string_length (_, t_n) = @@ -1955,7 +1960,7 @@ struct (F.content_to_top t_f1, N.string_copy t_n1 t_n2 n) else (F.content_to_top t_f1, N.top ()) - let string_concat (t_f1, t_n1) (_, t_n2) n = + let string_concat (t_f1, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then (F.content_to_top t_f1, N.string_concat t_n1 t_n2 n) else diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c index 5dce3b0cfe..b20fa929b5 100644 --- a/tests/regression/73-strings/07-larger_example.c +++ b/tests/regression/73-strings/07-larger_example.c @@ -16,7 +16,7 @@ int main() { __goblint_check(strcmp(user, "Alice") == 0); // UNKNOWN __goblint_check(strcmp(user, "Bob") == 0); // UNKNOWN - __goblint_check(strcmp(user, "Eve") != 0); // TODO: check implementation, maybe returning top wrong and we should return bot in string literals domain + __goblint_check(strcmp(user, "Eve") != 0); char pwd_gen[20]; for (size_t i = 12; i < 20; i++) From 4a088c938f97f2bd61bc56f97356a7cff479d3d1 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Wed, 6 Sep 2023 18:24:12 +0200 Subject: [PATCH 030/233] Fixed `content_to_top` --- src/cdomains/arrayDomain.ml | 32 ++++++++++++------- src/cdomains/arrayDomain.mli | 12 +++++-- src/cdomains/valueDomain.ml | 16 ++++++++++ .../regression/73-strings/07-larger_example.c | 4 +-- 4 files changed, 47 insertions(+), 17 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index e1d7062a70..1f1999514e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -95,9 +95,15 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end -module type LatticeWithSmartOps = +module type LatticeWithInvalidate = sig include Lattice.S + val invalidate_abstract_value: t -> t +end + +module type LatticeWithSmartOps = +sig + include LatticeWithInvalidate val smart_join: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> bool @@ -116,7 +122,7 @@ sig val not_zero_of_ikind: Cil.ikind -> t end -module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = +module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = struct include Val let name () = "trivial arrays" @@ -143,7 +149,7 @@ struct let map f x = f x let fold_left f a x = f a x - let content_to_top _ = Val.top () + let content_to_top x = Val.invalidate_abstract_value x let printXml f x = BatPrintf.fprintf f "\n\nAny\n%a\n\n\n" Val.printXml x let smart_join _ _ = join @@ -174,7 +180,7 @@ let factor () = | 0 -> failwith "ArrayDomain: ana.base.arrays.unrolling-factor needs to be set when using the unroll domain" | x -> x -module Unroll (Val: Lattice.S) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module Unroll (Val: LatticeWithInvalidate) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Factor = struct let x () = (get_int "ana.base.arrays.unrolling-factor") end module Base = Lattice.ProdList (Val) (Factor) @@ -253,7 +259,9 @@ struct let get_vars_in_e _ = [] let map f (xl, xr) = ((List.map f xl), f xr) let fold_left f a x = f a (join_of_all_parts x) - let content_to_top _ = (Base.top (), Val.top ()) + let content_to_top (xl, xr) = + let invalidated_val _ = Val.invalidate_abstract_value xr in + (List.map invalidated_val xl, invalidated_val xr) let printXml f (xl,xr) = BatPrintf.fprintf f "\n\n unrolled array\n xl\n%a\n\n @@ -346,7 +354,7 @@ struct let is_top = function | Joint x -> Val.is_top x | _-> false - let content_to_top _ = top () + let content_to_top x = Joint (Val.invalidate_abstract_value (join_of_all_parts x)) let join (x:t) (y:t) = normalize @@ match x, y with @@ -847,7 +855,7 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) else () -module TrivialWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Base = Trivial (Val) (Idx) include Lattice.Prod (Base) (Idx) @@ -867,7 +875,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) + let content_to_top (x, l) = (Base.content_to_top x, l) let smart_join _ _ = join let smart_widen _ _ = widen @@ -916,7 +924,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e (x, _) = Base.get_vars_in_e x - let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) + let content_to_top (x, l) = (Base.content_to_top x, l) let smart_join x_eval_int y_eval_int (x,xl) (y,yl) = let l = Idx.join xl yl in @@ -949,7 +957,7 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end -module UnrollWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module UnrollWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Base = Unroll (Val) (Idx) include Lattice.Prod (Base) (Idx) @@ -970,7 +978,7 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, Idx.top_of ILong) + let content_to_top (x, l) = (Base.content_to_top x, l) let smart_join _ _ = join let smart_widen _ _ = widen @@ -1279,7 +1287,7 @@ struct let fold_left f acc _ = f acc (Val.top ()) - let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) + let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), size) let smart_join _ _ = join let smart_widen _ _ = widen diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index e8deae06e0..915dfee470 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -115,9 +115,15 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end -module type LatticeWithSmartOps = +module type LatticeWithInvalidate = sig include Lattice.S + val invalidate_abstract_value: t -> t +end + +module type LatticeWithSmartOps = +sig + include LatticeWithInvalidate val smart_join: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool @@ -136,12 +142,12 @@ sig val not_zero_of_ikind: Cil.ikind -> t end -module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t +module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is taken as a parameter to satisfy the type system, it is not * used in the implementation. *) -module TrivialWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is also used to manage the length. *) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 6029111942..d204774493 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -24,6 +24,7 @@ sig val affect_move: ?replace_with_const:bool -> VDQ.t -> t -> varinfo -> (exp -> int option) -> t val affecting_vars: t -> varinfo list val invalidate_value: VDQ.t -> typ -> t -> t + val invalidate_abstract_value: t -> t val is_safe_cast: typ -> typ -> bool val cast: ?torg:typ -> typ -> t -> t val smart_join: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t @@ -757,6 +758,21 @@ struct | _, Bot -> Bot (* Leave uninitialized value (from malloc) alone in free to avoid trashing everything. TODO: sound? *) | t , _ -> top_value t + let invalidate_abstract_value = function + | Top -> Top + | Int i -> Int (ID.top_of (ID.ikind i)) + | Float f -> Float (FD.top_of (FD.get_fkind f)) + | Address _ -> Address (AD.top_ptr) + | Struct _ -> Struct (Structs.top ()) + | Union _ -> Union (Unions.top ()) + | Array _ -> Array (CArrays.top ()) + | Blob _ -> Blob (Blobs.top ()) + | Thread _ -> Thread (Threads.top ()) + | JmpBuf _ -> JmpBuf (JmpBufs.top ()) + | Mutex -> Mutex + | MutexAttr _ -> MutexAttr (MutexAttrDomain.top ()) + | Bot -> Bot + (* take the last offset in offset and move it over to left *) let shift_one_over left offset = diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c index b20fa929b5..f756108343 100644 --- a/tests/regression/73-strings/07-larger_example.c +++ b/tests/regression/73-strings/07-larger_example.c @@ -26,9 +26,9 @@ int main() { char* p2 = "12345"; strcat(pwd_gen, p1); // WARN strncpy(pwd_gen, p2, 6); - __goblint_check(pwd_gen[5] == '\0'); // TODO: fix get in attributeconfiguredarraydomain + __goblint_check(pwd_gen[5] == '\0'); strncat(pwd_gen, p1, 4); - __goblint_check(pwd_gen[5] != '\0'); // TODO: fix get in attributeconfiguredarraydomain + __goblint_check(pwd_gen[5] != '\0'); int cmp = strcmp(pwd_gen, "12345hello"); __goblint_check(cmp != 0); From fd95dbe0947e85da6155a6ecba0c02efb270295d Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Thu, 7 Sep 2023 17:34:57 +0200 Subject: [PATCH 031/233] Minor bugfix, updated test IDs and annotations --- src/cdomains/arrayDomain.ml | 2 +- .../{04-char_arrays.c => 05-char_arrays.c} | 0 tests/regression/73-strings/06-juliet.c | 43 +++++++++++++------ 3 files changed, 31 insertions(+), 14 deletions(-) rename tests/regression/73-strings/{04-char_arrays.c => 05-char_arrays.c} (100%) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 1f1999514e..4503d3c7fb 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1079,7 +1079,7 @@ struct check_all_indexes (Z.succ i) else false in - if MustNulls.is_bot may_nulls_set then + if MustNulls.is_bot must_nulls_set then true else if Z.lt (Z.of_int (MustNulls.cardinal must_nulls_set)) (Z.sub max i) then false diff --git a/tests/regression/73-strings/04-char_arrays.c b/tests/regression/73-strings/05-char_arrays.c similarity index 100% rename from tests/regression/73-strings/04-char_arrays.c rename to tests/regression/73-strings/05-char_arrays.c diff --git a/tests/regression/73-strings/06-juliet.c b/tests/regression/73-strings/06-juliet.c index 53bc2ba4e9..a5320d4c4b 100644 --- a/tests/regression/73-strings/06-juliet.c +++ b/tests/regression/73-strings/06-juliet.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --set ana.base.arrays.domain partitioned --enable ana.base.arrays.nullbytes #include #include @@ -24,8 +24,11 @@ void CWE121_Stack_Based_Buffer_Overflow__src_char_declare_cpy_01_bad() char dataBuffer[100]; data = dataBuffer; /* FLAW: Initialize data as a large buffer that is larger than the small buffer used in the sink */ - memset(data, 'A', 100-1); /* fill with 'A's */ + /* memset(data, 'A', 100-1); // fill with 'A's -- memset not supported currently, replaced with for-loop */ + for (size_t i = 0; i < 100-1; i++) + data[i] = 'A'; data[100-1] = '\0'; /* null terminate */ + __goblint_check(data[42] == 'A'); { char dest[50] = ""; /* POTENTIAL FLAW: Possible buffer overflow if data is larger than dest */ @@ -39,14 +42,16 @@ void CWE126_Buffer_Overread__CWE170_char_loop_01_bad() char src[150], dest[100]; int i; /* Initialize src */ - memset(src, 'A', 149); + /* memset(src, 'A', 149); */ + for (i = 0; i < 149; i++) + src[i] = 'A'; src[149] = '\0'; for(i=0; i < 99; i++) { dest[i] = src[i]; } /* FLAW: do not explicitly null terminate dest after the loop */ - __goblint_check(dest[42] != '\0'); + __goblint_check(dest[42] != '\0'); // UNKNOWN __goblint_check(dest[99] != '\0'); // UNKNOWN } } @@ -56,7 +61,9 @@ void CWE126_Buffer_Overread__CWE170_char_strncpy_01_bad() { char data[150], dest[100]; /* Initialize data */ - memset(data, 'A', 149); + /* memset(data, 'A', 149); */ + for (size_t i = 0; i < 149; i++) + data[i] = 'A'; data[149] = '\0'; /* strncpy() does not null terminate if the string in the src buffer is larger than * the number of characters being copied to the dest buffer */ @@ -70,19 +77,25 @@ void CWE126_Buffer_Overread__char_declare_loop_01_bad() char * data; char dataBadBuffer[50]; char dataGoodBuffer[100]; - memset(dataBadBuffer, 'A', 50-1); /* fill with 'A's */ + /* memset(dataBadBuffer, 'A', 50-1); // fill with 'A's */ + for (size_t i = 0; i < 50-1; i++) + dataBadBuffer[i] = 'A'; dataBadBuffer[50-1] = '\0'; /* null terminate */ - memset(dataGoodBuffer, 'A', 100-1); /* fill with 'A's */ + /* memset(dataGoodBuffer, 'A', 100-1); // fill with 'A's */ + for (size_t i = 0; i < 100-1; i++) + dataGoodBuffer[i] = 'A'; dataGoodBuffer[100-1] = '\0'; /* null terminate */ /* FLAW: Set data pointer to a small buffer */ data = dataBadBuffer; { size_t i, destLen; char dest[100]; - memset(dest, 'C', 100-1); + /* memset(dest, 'C', 100-1); */ + for (i = 0; i < 100-1; i++) + dest[i] = 'C'; dest[100-1] = '\0'; /* null terminate */ destLen = strlen(dest); - __goblint_check(destLen == 99); + __goblint_check(destLen <= 99); /* POTENTIAL FLAW: using length of the dest where data * could be smaller than dest causing buffer overread */ for (i = 0; i < destLen; i++) @@ -102,7 +115,9 @@ void CWE665_Improper_Initialization__char_cat_01_bad() ; /* empty statement needed for some flow variants */ { char source[100]; - memset(source, 'C', 100-1); /* fill with 'C's */ + /* memset(source, 'C', 100-1); // fill with 'C's */ + for (size_t i = 0; i < 100-1; i++) + source[i] = 'C'; source[100-1] = '\0'; /* null terminate */ /* POTENTIAL FLAW: If data is not initialized properly, strcat() may not function correctly */ strcat(data, source); // WARN @@ -135,11 +150,13 @@ void CWE665_Improper_Initialization__char_ncat_11_bad() { size_t sourceLen; char source[100]; - memset(source, 'C', 100-1); /* fill with 'C's */ + /* memset(source, 'C', 100-1); // fill with 'C's */ + for (size_t i = 0; i < 100-1; i++) + source[i] = 'C'; source[100-1] = '\0'; /* null terminate */ sourceLen = strlen(source); - __goblint_check(sourceLen == 99); + __goblint_check(sourceLen <= 99); /* POTENTIAL FLAW: If data is not initialized properly, strncat() may not function correctly */ - strncat(data, source, sourceLen); // WARN --> why not?? spurious + strncat(data, source, sourceLen); // NOWARN because sourceLen is not exactly known => array domain not consulted } } From e4d7e2bdb78f703ac78c7e35276c80f5425d91ef Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Fri, 8 Sep 2023 12:46:22 +0200 Subject: [PATCH 032/233] Fixed test 06 for MacOS --- tests/regression/73-strings/06-juliet.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/regression/73-strings/06-juliet.c b/tests/regression/73-strings/06-juliet.c index a5320d4c4b..cda8ffd6dd 100644 --- a/tests/regression/73-strings/06-juliet.c +++ b/tests/regression/73-strings/06-juliet.c @@ -157,6 +157,10 @@ void CWE665_Improper_Initialization__char_ncat_11_bad() sourceLen = strlen(source); __goblint_check(sourceLen <= 99); /* POTENTIAL FLAW: If data is not initialized properly, strncat() may not function correctly */ - strncat(data, source, sourceLen); // NOWARN because sourceLen is not exactly known => array domain not consulted + #ifdef __APPLE__ + ; + #else + strncat(data, source, sourceLen); // NOWARN because sourceLen is not exactly known => array domain not consulted + #endif } } From 0a5737414fd9aac74b4adfff61e4e842bb37aad7 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 14 Sep 2023 14:48:51 +0200 Subject: [PATCH 033/233] Make it work with Blobs --- src/analyses/base.ml | 30 +++++++++++++---- .../regression/73-strings/03-string_basics.c | 4 +-- tests/regression/73-strings/08-cursed.c | 32 +++++++++++++++++++ 3 files changed, 57 insertions(+), 9 deletions(-) create mode 100644 tests/regression/73-strings/08-cursed.c diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 30c1fc3c52..cc8f912832 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2065,7 +2065,7 @@ struct | Addr.Addr (v, o) -> Addr.Addr (v, lo o) | other -> other in AD.map rmLastOffset a - | _ -> raise (Failure "String function: not an address") + | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = let s1_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in @@ -2075,6 +2075,7 @@ struct let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) + (* TODO: comparing types structurally should not be done (use typSig instead!) *) if s1_typ = charPtrType && s2_typ = charPtrType then begin match lv, op_addr with | Some lv_val, Some f -> @@ -2093,16 +2094,30 @@ struct set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) - else + else let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match get (Analyses.ask_of_ctx ctx) gs st s1_a None, get (Analyses.ask_of_ctx ctx) gs st s2_a None with + begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) - | Array array_s1, _ when s2_typ = charPtrType -> + | Array array_s1, _ when s2_typ = charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Bot, Array array_s2 -> + (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let size = ctx.ask (Q.BlobSize s1) in + let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in + let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) + | Bot , _ when s2_typ = charPtrType -> + (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let size = ctx.ask (Q.BlobSize s1) in + let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in + let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in + let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in + let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) | _, Array array_s2 when s1_typ = charPtrType -> (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) if op_addr = None then @@ -2113,7 +2128,8 @@ struct let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) - | _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + | vals1, _ -> + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in let st = match desc.special args, f.vname with @@ -2157,7 +2173,7 @@ struct let dest_typ = Cilfacade.typeOfLval lv_val in let v = eval_rv (Analyses.ask_of_ctx ctx) gs st s in let a = address_from_value v in - let value:value = + let value:value = (* if s string literal, compute strlen in string literals domain *) if AD.type_of a = charPtrType then Int (AD.to_string_length a) @@ -2181,7 +2197,7 @@ struct (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with | true, false -> Address (AD.null_ptr) | false, true -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | _ -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + | _ -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 3487a36be7..09a1ad8e81 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -30,7 +30,7 @@ int main() { __goblint_check(len == 4); len = strlen(s5); - __goblint_check(len == 5); // UNKNOWN + __goblint_check(len == 5); strcat(s1, s2); len = strlen(s1); @@ -87,4 +87,4 @@ int main() { free(s1); return 0; -} \ No newline at end of file +} diff --git a/tests/regression/73-strings/08-cursed.c b/tests/regression/73-strings/08-cursed.c new file mode 100644 index 0000000000..421f9f7b18 --- /dev/null +++ b/tests/regression/73-strings/08-cursed.c @@ -0,0 +1,32 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main() { + // These should behave identically + char s1[40]; + char* s5 = malloc(40); + char* s6 = malloc(40); + + strcpy(s1, "hello"); + strcpy(s5, "hello"); + + int len = strlen(s5); + __goblint_check(len == 5); + + int len2 = strlen(s1); + __goblint_check(len2 == 5); + + strcpy(s6,s5); + int len3 = strlen(s6); + __goblint_check(len3 == 5); + + // Why does this not know the string length after the copy? + // This goes into the array/array case, so it seems unrelated to blob problems. + strcpy(s5, "badabingbadaboom"); + len2 = strlen(s5); // no must 0 bytes anywhere? + + return 0; +} From 1aaec466e5234e8906fbf9075f3177bd99b88724 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 14 Sep 2023 15:42:30 +0200 Subject: [PATCH 034/233] Update malloced strings destructively where possible --- src/analyses/base.ml | 8 ++++---- src/cdomains/valueDomain.ml | 14 ++++++++------ tests/regression/73-strings/08-cursed.c | 7 +++---- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index cc8f912832..44ef339d2e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1382,7 +1382,7 @@ struct (** [set st addr val] returns a state where [addr] is set to [val] * it is always ok to put None for lval_raw and rval_raw, this amounts to not using/maintaining * precise information about arrays. *) - let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?lval_raw ?rval_raw ?t_override (gs:glob_fun) (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = + let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (gs:glob_fun) (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = let update_variable x t y z = if M.tracing then M.tracel "set" ~var:x.vname "update_variable: start '%s' '%a'\nto\n%a\n\n" x.vname VD.pretty y CPA.pretty z; let r = update_variable x t y z in (* refers to defintion that is outside of set *) @@ -1415,7 +1415,7 @@ struct let update_offset old_value = (* Projection globals to highest Precision *) let projected_value = project_val (Queries.to_value_domain_ask a) None None value (is_global a x) in - let new_value = VD.update_offset (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in + let new_value = VD.update_offset ~blob_destructive (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in if WeakUpdates.mem x st.weak then VD.join old_value new_value else if invariant then ( @@ -2099,11 +2099,11 @@ struct | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with - | Array array_s1, Array array_s2 -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) | Array array_s1, _ when s2_typ = charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) | Bot, Array array_s2 -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let size = ctx.ask (Q.BlobSize s1) in diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index e5c4727b72..9b4b09d930 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -19,7 +19,7 @@ sig include Lattice.S type offs val eval_offset: VDQ.t -> (AD.t -> t) -> t-> offs -> exp option -> lval option -> typ -> t - val update_offset: VDQ.t -> t -> offs -> t -> exp option -> lval -> typ -> t + val update_offset: ?blob_destructive:bool -> VDQ.t -> t -> offs -> t -> exp option -> lval -> typ -> t val update_array_lengths: (exp -> t) -> t -> Cil.typ -> t val affect_move: ?replace_with_const:bool -> VDQ.t -> t -> varinfo -> (exp -> int option) -> t val affecting_vars: t -> varinfo list @@ -288,12 +288,12 @@ struct true else false - | Some min, None -> + | Some min, None -> if Z.gt min Z.zero then true else false - | None, Some max -> + | None, Some max -> if Z.lt max Z.zero then true else @@ -953,7 +953,7 @@ struct in do_eval_offset ask f x offs exp l o v t - let update_offset (ask: VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (v:lval) (t:typ): t = + let update_offset ?(blob_destructive=false) (ask: VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (v:lval) (t:typ): t = let rec do_update_offset (ask:VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (l:lval option) (o:offset option) (v:lval) (t:typ):t = if M.tracing then M.traceli "update_offset" "do_update_offset %a %a (%a) %a\n" pretty x Offs.pretty offs (Pretty.docOpt (CilType.Exp.pretty ())) exp pretty value; let mu = function Blob (Blob (y, s', orig), s, orig2) -> Blob (y, ID.join s s',orig) | x -> x in @@ -1001,9 +1001,11 @@ struct | (Var var, _) -> let blob_size_opt = ID.to_int s in not @@ ask.is_multiple var - && not @@ Cil.isVoidType t (* Size of value is known *) && Option.is_some blob_size_opt (* Size of blob is known *) - && BI.equal (Option.get blob_size_opt) (BI.of_int @@ Cil.alignOf_int t) + && (( + not @@ Cil.isVoidType t (* Size of value is known *) + && BI.equal (Option.get blob_size_opt) (BI.of_int @@ Cil.alignOf_int t) + ) || blob_destructive) | _ -> false end in diff --git a/tests/regression/73-strings/08-cursed.c b/tests/regression/73-strings/08-cursed.c index 421f9f7b18..1507b92563 100644 --- a/tests/regression/73-strings/08-cursed.c +++ b/tests/regression/73-strings/08-cursed.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes --set ana.malloc.unique_address_count 1 #include #include @@ -23,10 +23,9 @@ int main() { int len3 = strlen(s6); __goblint_check(len3 == 5); - // Why does this not know the string length after the copy? - // This goes into the array/array case, so it seems unrelated to blob problems. strcpy(s5, "badabingbadaboom"); - len2 = strlen(s5); // no must 0 bytes anywhere? + int len2 = strlen(s5); + __goblint_check(len2 == 16); return 0; } From a0a501c8f7ec444a5aa40614ee6f0de28a2ec0e1 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Sat, 16 Sep 2023 14:48:36 +0200 Subject: [PATCH 035/233] Replaced type comparison with `CilType.Typ.equal` --- src/analyses/base.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 44ef339d2e..f093eec9e5 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2075,8 +2075,7 @@ struct let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) - (* TODO: comparing types structurally should not be done (use typSig instead!) *) - if s1_typ = charPtrType && s2_typ = charPtrType then + if CilType.Typ.equal s1_typ charPtrType && CilType.Typ.equal s2_typ charPtrType then begin match lv, op_addr with | Some lv_val, Some f -> (* when whished types coincide, compute result of operation op_addr, otherwise use top *) @@ -2100,7 +2099,7 @@ struct | None -> s1_a, s1_typ in begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) - | Array array_s1, _ when s2_typ = charPtrType -> + | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) @@ -2110,7 +2109,7 @@ struct let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) - | Bot , _ when s2_typ = charPtrType -> + | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let size = ctx.ask (Q.BlobSize s1) in let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in @@ -2118,7 +2117,7 @@ struct let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) - | _, Array array_s2 when s1_typ = charPtrType -> + | _, Array array_s2 when CilType.Typ.equal s1_typ charPtrType -> (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) if op_addr = None then (* triggers warning, function only evaluated for side-effects *) @@ -2128,7 +2127,7 @@ struct let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) - | vals1, _ -> + | _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in From fa77d12fd4012fdeae4928c049b09ba18565cb47 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Sat, 23 Sep 2023 17:45:35 +0200 Subject: [PATCH 036/233] Solve failure `Queries.ID.unlift` --- src/analyses/base.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 420612ba1a..3810a92277 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2097,13 +2097,17 @@ struct | Bot, Array array_s2 -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let size = ctx.ask (Q.BlobSize s1) in - let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in + let s_id = + try ValueDomainQueries.ID.unlift (Fun.id) size + with Failure _ -> ID.top_of ILong in let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) let size = ctx.ask (Q.BlobSize s1) in - let s_id = ValueDomainQueries.ID.unlift (Fun.id) size in + let s_id = + try ValueDomainQueries.ID.unlift (Fun.id) size + with Failure _ -> ID.top_of ILong in let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in From 34c2037190aff2e3117f1bb2f3d46b2978430a5b Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Sat, 23 Sep 2023 20:59:23 +0200 Subject: [PATCH 037/233] Draft for new regression tests --- .../73-strings/09-dynamic_char_arrays.c | 92 +++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 tests/regression/73-strings/09-dynamic_char_arrays.c diff --git a/tests/regression/73-strings/09-dynamic_char_arrays.c b/tests/regression/73-strings/09-dynamic_char_arrays.c new file mode 100644 index 0000000000..58f9eba1e1 --- /dev/null +++ b/tests/regression/73-strings/09-dynamic_char_arrays.c @@ -0,0 +1,92 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main () { + example1(); + example2(); + example3(); + example4(); + + return 0; +} + +void example1() { + size_t i; + if (rand()) + i = 0; + else + i = 1; + + char* s1 = malloc(50); + s1 = "goblint"; // must null at 7, may nulls starting from 7 + __goblint_check(s1[i] != '\0'); + + char* s2 = malloc(6); + s2 = "\0\0\0\0\0"; // NOWARN: all must and may nulls + __goblint_check(s2[i] == '\0'); + + strcpy(s1, s2); // must null at 0 and 7, mays nulls at 0 and starting from 7 + __goblint_check(s1[i] == '\0'); // UNKNOWN + + s1[i] = 'a'; // must null at 7, mays nulls at 0 and starting from 7 + + size_t len = strlen(s1); + __goblint_check(len >= 0); + __goblint_check(len > 0); // UNKNOWN + __goblint_check(len <= 7); + + s2[0] = 'a'; // all must and may null >= 1 + __goblint_check(s2[i] == '\0'); // UNKNOWN +} + +void example2() { + char* s1 = malloc(50); + for (size_t i = 0; i < 50; i++) + s1[i] = '\0'; + __goblint_check(s1[0] == '\0'); // UNKNOWN: no must nulls, all may nulls + + char* s2 = malloc(50); + for (size_t i = 0; i < 50; i++) + s2[i] = 'a'; + __goblint_check(s2[10] != '\0'); // no must and may nulls + + strcpy(s1, s2); // WARN: no must and may nulls + strcpy(s2, "definite buffer overflow"); // WARN + + s2[49] = '\0'; // must and may null at 49 + + strncpy(s1, s2, 10); // WARN +} + +void example3() { + char* s1 = malloc(10); // no must null, all may nulls + char* s2 = malloc(10); // no must null, all may nulls + strncpy(s1, s2, 4); // WARN: no must null, all may nulls + __goblint_check(s1[3] == '\0'); // UNKNOWN + + s1[0] = 'a'; + s1[1] = 'b'; // no must null, may nulls >= 2 + + strcat(s1, s2); // WARN: no must null, may nulls >= 2 + __goblint_check(s1[1] != '\0'); + __goblint_check(s1[2] == '\0'); // UNKNOWN + + int cmp = strncmp(s1, s2, 0); + __goblint_check(cmp == 0); +} + +void example4() { + size_t size; + if (rand()) + size = 15; + else + size = 20; + + char* s = malloc(size); + + s[17] = '\0'; // no must nulls, may null at 17 + __goblint_check(s[17] == '\0'); // UNKNOWN! +} \ No newline at end of file From e0d9a2add72e00d06e57a7dc85e5693c76495c2f Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Sat, 23 Sep 2023 22:43:12 +0200 Subject: [PATCH 038/233] Updated regression tests --- tests/regression/73-strings/05-char_arrays.c | 97 +++++++++++++++++++ .../73-strings/09-dynamic_char_arrays.c | 92 ------------------ 2 files changed, 97 insertions(+), 92 deletions(-) delete mode 100644 tests/regression/73-strings/09-dynamic_char_arrays.c diff --git a/tests/regression/73-strings/05-char_arrays.c b/tests/regression/73-strings/05-char_arrays.c index c86a0b1ebc..edb5a2ab57 100644 --- a/tests/regression/73-strings/05-char_arrays.c +++ b/tests/regression/73-strings/05-char_arrays.c @@ -15,6 +15,11 @@ int main() { example8(); example9(); example10(); + example11(); + example12(); + example13(); + example14(); + example15(); return 0; } @@ -231,3 +236,95 @@ void example10() { i = strncmp(s1, s2, 10); // WARN __goblint_check(i != 0); // UNKNOWN } + +void example11() { + size_t i; + if (rand()) + i = 0; + else + i = 1; + + char s1[50] = "goblint"; // must null at 7, may nulls starting from 7 + __goblint_check(s1[i] != '\0'); + + char s2[6] = "\0\0\0\0\0"; // all must and may nulls + __goblint_check(s2[i] == '\0'); + + strcpy(s1, s2); // must null at 0 and 7, mays nulls at 0 and starting from 7 + __goblint_check(s1[i] == '\0'); // UNKNOWN + + s1[i] = 'a'; // must null at 7, mays nulls at 0 and starting from 7 + + size_t len = strlen(s1); + __goblint_check(len >= 0); + __goblint_check(len > 0); // UNKNOWN + __goblint_check(len <= 7); + + s2[0] = 'a'; // all must and may null >= 1 + __goblint_check(s2[i] == '\0'); // UNKNOWN +} + +void example12() { + char s1[50]; + for (size_t i = 0; i < 50; i++) + s1[i] = '\0'; + __goblint_check(s1[0] == '\0'); // no must null, all may nulls + __goblint_check(s1[1] == '\0'); // known by trivial array domain + + char s2[5]; + s2[0] = 'a'; s2[1] = 'a'; s2[2] = 'a'; s2[3] = 'a'; s2[4] ='a'; + __goblint_check(s2[10] != '\0'); // no must null and may nulls + + strcpy(s1, s2); // WARN: no must nulls, may nulls >= 5 + strcpy(s2, "definite buffer overflow"); // WARN + + s2[4] = '\0'; // must and may null at 4 + + strncpy(s1, s2, 4); // WARN +} + +void example13() { + char s1[10]; // no must null, all may nulls + char s2[10]; // no must null, all may nulls + strncpy(s1, s2, 4); // WARN: no must null, all may nulls + __goblint_check(s1[3] == '\0'); // UNKNOWN + + s1[0] = 'a'; + s1[1] = 'b'; // no must null, may nulls >= 2 + + strcat(s1, s2); // WARN: no must null, may nulls >= 2 + __goblint_check(s1[1] != '\0'); + __goblint_check(s1[2] == '\0'); // UNKNOWN + + int cmp = strncmp(s1, s2, 0); + __goblint_check(cmp == 0); +} + +void example14() { + size_t size; + if (rand()) + size = 15; + else + size = 20; + + char* s = malloc(size); + + strcpy(s, ""); // must null at 0, all may null + + strcat(s, "123456789012345678"); // WARN +} + +example15() { + char* s1 = malloc(8); + strcpy(s1, "goblint"); // must and may null at 7 + + char s2[42] = "static"; // must null at 6, may null >= 6 + + strcat(s2, s1); // must null at 13, may null >= 13 + __goblint_check(s2[12] != '\0'); + __goblint_check(s2[13] == '\0'); + __goblint_check(s2[14] == '\0'); // UNKNOWN + + char* s3 = strstr(s1, s2); + __goblint_check(s3 == NULL); +} diff --git a/tests/regression/73-strings/09-dynamic_char_arrays.c b/tests/regression/73-strings/09-dynamic_char_arrays.c deleted file mode 100644 index 58f9eba1e1..0000000000 --- a/tests/regression/73-strings/09-dynamic_char_arrays.c +++ /dev/null @@ -1,92 +0,0 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes - -#include -#include -#include - -int main () { - example1(); - example2(); - example3(); - example4(); - - return 0; -} - -void example1() { - size_t i; - if (rand()) - i = 0; - else - i = 1; - - char* s1 = malloc(50); - s1 = "goblint"; // must null at 7, may nulls starting from 7 - __goblint_check(s1[i] != '\0'); - - char* s2 = malloc(6); - s2 = "\0\0\0\0\0"; // NOWARN: all must and may nulls - __goblint_check(s2[i] == '\0'); - - strcpy(s1, s2); // must null at 0 and 7, mays nulls at 0 and starting from 7 - __goblint_check(s1[i] == '\0'); // UNKNOWN - - s1[i] = 'a'; // must null at 7, mays nulls at 0 and starting from 7 - - size_t len = strlen(s1); - __goblint_check(len >= 0); - __goblint_check(len > 0); // UNKNOWN - __goblint_check(len <= 7); - - s2[0] = 'a'; // all must and may null >= 1 - __goblint_check(s2[i] == '\0'); // UNKNOWN -} - -void example2() { - char* s1 = malloc(50); - for (size_t i = 0; i < 50; i++) - s1[i] = '\0'; - __goblint_check(s1[0] == '\0'); // UNKNOWN: no must nulls, all may nulls - - char* s2 = malloc(50); - for (size_t i = 0; i < 50; i++) - s2[i] = 'a'; - __goblint_check(s2[10] != '\0'); // no must and may nulls - - strcpy(s1, s2); // WARN: no must and may nulls - strcpy(s2, "definite buffer overflow"); // WARN - - s2[49] = '\0'; // must and may null at 49 - - strncpy(s1, s2, 10); // WARN -} - -void example3() { - char* s1 = malloc(10); // no must null, all may nulls - char* s2 = malloc(10); // no must null, all may nulls - strncpy(s1, s2, 4); // WARN: no must null, all may nulls - __goblint_check(s1[3] == '\0'); // UNKNOWN - - s1[0] = 'a'; - s1[1] = 'b'; // no must null, may nulls >= 2 - - strcat(s1, s2); // WARN: no must null, may nulls >= 2 - __goblint_check(s1[1] != '\0'); - __goblint_check(s1[2] == '\0'); // UNKNOWN - - int cmp = strncmp(s1, s2, 0); - __goblint_check(cmp == 0); -} - -void example4() { - size_t size; - if (rand()) - size = 15; - else - size = 20; - - char* s = malloc(size); - - s[17] = '\0'; // no must nulls, may null at 17 - __goblint_check(s[17] == '\0'); // UNKNOWN! -} \ No newline at end of file From 5ebd1a1a9271e4f183bc59940a7f2da2713cfd12 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 24 Sep 2023 11:14:46 +0200 Subject: [PATCH 039/233] Bot in string_manipulation: correct ik right away --- src/analyses/base.ml | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3810a92277..d0f9dcc03e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2096,19 +2096,21 @@ struct set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) | Bot, Array array_s2 -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in let size = ctx.ask (Q.BlobSize s1) in - let s_id = - try ValueDomainQueries.ID.unlift (Fun.id) size - with Failure _ -> ID.top_of ILong in - let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in + let s_id = + try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size + with Failure _ -> ID.top_of ptrdiff_ik in + let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in let size = ctx.ask (Q.BlobSize s1) in - let s_id = - try ValueDomainQueries.ID.unlift (Fun.id) size - with Failure _ -> ID.top_of ILong in - let empty_array = CArrays.make (ID.cast_to (Cilfacade.ptrdiff_ikind ()) s_id) (Int (ID.top_of IChar)) in + let s_id = + try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size + with Failure _ -> ID.top_of ptrdiff_ik in + let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) From d0a90d83e943992aca1cd1756d9bcd723df25d74 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 24 Sep 2023 11:49:13 +0200 Subject: [PATCH 040/233] Escape `\0` in XML for g2html compatibility --- src/util/xmlUtil.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/util/xmlUtil.ml b/src/util/xmlUtil.ml index e33be1b215..c0eaa074e9 100644 --- a/src/util/xmlUtil.ml +++ b/src/util/xmlUtil.ml @@ -11,4 +11,5 @@ let escape (x:string):string = Str.global_replace (Str.regexp "\"") """ |> Str.global_replace (Str.regexp "'") "'" |> Str.global_replace (Str.regexp "[\x0b\001\x0c\x0f\x0e\x05]") "" |> (* g2html just cannot handle from some kernel benchmarks, even when escaped... *) - Str.global_replace (Str.regexp "[\x1b]") "" (* g2html cannot handle from chrony *) + Str.global_replace (Str.regexp "[\x1b]") "" |> (* g2html cannot handle from chrony *) + Str.global_replace (Str.regexp "\x00") "\\\\0" (* produces \\0, is needed if an example contains \0 *) From 2f7c07fa498b1be95b81dbf293aa892dfa0bc31f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 24 Sep 2023 12:00:48 +0200 Subject: [PATCH 041/233] Add problematic example --- tests/regression/73-strings/09-malloc.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 tests/regression/73-strings/09-malloc.c diff --git a/tests/regression/73-strings/09-malloc.c b/tests/regression/73-strings/09-malloc.c new file mode 100644 index 0000000000..118db6f0e6 --- /dev/null +++ b/tests/regression/73-strings/09-malloc.c @@ -0,0 +1,16 @@ +// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main () { + char* s1 = malloc(50); + s1[0] = 'a'; + + char s2[50]; + s2[0] = 'a'; + + int len1 = strlen(s1); //WARN + int len2 = strlen(s2); //WARN +} From 48d0e5dec19cddd3a0e78febc562b26126ad8446 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 24 Sep 2023 12:05:44 +0200 Subject: [PATCH 042/233] Make also fail in the CI --- tests/regression/73-strings/09-malloc.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/regression/73-strings/09-malloc.c b/tests/regression/73-strings/09-malloc.c index 118db6f0e6..913ec821c0 100644 --- a/tests/regression/73-strings/09-malloc.c +++ b/tests/regression/73-strings/09-malloc.c @@ -1,5 +1,4 @@ // PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval --enable ana.base.arrays.nullbytes - #include #include #include @@ -11,6 +10,7 @@ int main () { char s2[50]; s2[0] = 'a'; - int len1 = strlen(s1); //WARN - int len2 = strlen(s2); //WARN + // Use size_t to avoid integer warnings hiding the lack of string warnings + size_t len1 = strlen(s1); //WARN + size_t len2 = strlen(s2); //WARN } From 5ac2f23a2029290940b65b85554f69242b42d830 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 9 Oct 2023 17:18:08 +0200 Subject: [PATCH 043/233] Integrate review suggestions --- src/analyses/base.ml | 8 +- src/cdomains/arrayDomain.ml | 518 +++++++++++++++++------------------ src/cdomains/arrayDomain.mli | 21 +- src/cdomains/valueDomain.ml | 45 +-- 4 files changed, 274 insertions(+), 318 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d0f9dcc03e..c8c13fe3ef 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2047,7 +2047,7 @@ struct in let address_from_value (v:value) = match v with | Address a -> - let rec lo:'a Offset_intf.t -> 'a Offset_intf.t = function + let rec lo = function | `Index (i, `NoOffset) -> `NoOffset | `NoOffset -> `NoOffset | `Field (f, o) -> `Field (f, lo o) @@ -2191,9 +2191,9 @@ struct if it surely isn't, assign a null_ptr *) string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with - | true, false -> Address (AD.null_ptr) - | false, true -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | _ -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + | CArrays.IsNotSubstr -> Address (AD.null_ptr) + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 4503d3c7fb..a09d15bd23 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -53,7 +53,6 @@ sig val get_vars_in_e: t -> Cil.varinfo list val map: (value -> value) -> t -> t val fold_left: ('a -> value -> 'a) -> 'a -> t -> 'a - val content_to_top: t -> t val smart_join: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_widen: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_leq: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool @@ -76,14 +75,15 @@ sig include S0 type ret = Null | NotNull | Top + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret val to_null_byte_domain: string -> t val to_string_length: t -> idx val string_copy: t -> t -> int option -> t val string_concat: t -> t -> int option -> t - val substring_extraction: t -> t -> bool * bool + val substring_extraction: t -> t -> substr val string_comparison: t -> t -> int option -> idx end @@ -117,7 +117,7 @@ sig val is_null: t -> bool val is_not_null: t -> bool - val is_int_ikind: t -> Cil.ikind option + val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t val not_zero_of_ikind: Cil.ikind -> t end @@ -149,8 +149,6 @@ struct let map f x = f x let fold_left f a x = f a x - let content_to_top x = Val.invalidate_abstract_value x - let printXml f x = BatPrintf.fprintf f "\n\nAny\n%a\n\n\n" Val.printXml x let smart_join _ _ = join let smart_widen _ _ = widen @@ -259,9 +257,6 @@ struct let get_vars_in_e _ = [] let map f (xl, xr) = ((List.map f xl), f xr) let fold_left f a x = f a (join_of_all_parts x) - let content_to_top (xl, xr) = - let invalidated_val _ = Val.invalidate_abstract_value xr in - (List.map invalidated_val xl, invalidated_val xr) let printXml f (xl,xr) = BatPrintf.fprintf f "\n\n unrolled array\n xl\n%a\n\n @@ -354,7 +349,6 @@ struct let is_top = function | Joint x -> Val.is_top x | _-> false - let content_to_top x = Joint (Val.invalidate_abstract_value (join_of_all_parts x)) let join (x:t) (y:t) = normalize @@ match x, y with @@ -875,8 +869,6 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, l) - let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -924,8 +916,6 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e (x, _) = Base.get_vars_in_e x - let content_to_top (x, l) = (Base.content_to_top x, l) - let smart_join x_eval_int y_eval_int (x,xl) (y,yl) = let l = Idx.join xl yl in (Base.smart_join_with_length (Some l) x_eval_int y_eval_int x y , l) @@ -978,8 +968,6 @@ struct let fold_left f a (x, l) = Base.fold_left f a x let get_vars_in_e _ = [] - let content_to_top (x, l) = (Base.content_to_top x, l) - let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -1003,87 +991,87 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end -module HelperFunctionsIndexMustMaySets = +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = struct - module MustSet = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All indexes" end)) - module MaySet = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All indexes" end) + module MustSet = struct + module M = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) + include M - let compute_set len = - List.init (Z.to_int len) (Fun.id) - |> List.map Z.of_int - |> MustSet.of_list + let compute_set len = + List.init (Z.to_int len) Z.of_int + |> of_list - let must_nulls_remove i must_nulls_set min_size = - if MustSet.is_bot must_nulls_set then - MustSet.remove i (compute_set min_size) - else - MustSet.remove i must_nulls_set + let remove i must_nulls_set min_size = + if M.is_bot must_nulls_set then + M.remove i (compute_set min_size) + else + M.remove i must_nulls_set - let must_nulls_filter cond must_nulls_set min_size = - if MustSet.is_bot must_nulls_set then - MustSet.filter cond (compute_set min_size) - else - MustSet.filter cond must_nulls_set + let filter cond must_nulls_set min_size = + if M.is_bot must_nulls_set then + M.filter cond (compute_set min_size) + else + M.filter cond must_nulls_set - let must_nulls_min_elt must_nulls_set = - if MustSet.is_bot must_nulls_set then - Z.zero - else - MustSet.min_elt must_nulls_set + let min_elt must_nulls_set = + if M.is_bot must_nulls_set then + Z.zero + else + M.min_elt must_nulls_set + end - let may_nulls_remove i may_nulls_set max_size = - if MaySet.is_top may_nulls_set then - MaySet.remove i (compute_set max_size) - else - MaySet.remove i may_nulls_set + module MaySet = struct + module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) + include M - let may_nulls_filter cond may_nulls_set max_size = - if MaySet.is_top may_nulls_set then - MaySet.filter cond (compute_set max_size) - else - MaySet.filter cond may_nulls_set + let remove i may_nulls_set max_size = + if M.is_top may_nulls_set then + M.remove i (MustSet.compute_set max_size) + else + M.remove i may_nulls_set - let may_nulls_min_elt may_nulls_set = - if MaySet.is_top may_nulls_set then - Z.zero - else - MaySet.min_elt may_nulls_set -end + let filter cond may_nulls_set max_size = + if M.is_top may_nulls_set then + M.filter cond (MustSet.compute_set max_size) + else + M.filter cond may_nulls_set -module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = -struct - module MustNulls = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) - module MayNulls = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) - (* (Must Null Set, May Null Set, Array Size) *) - include Lattice.Prod3 (MustNulls) (MayNulls) (Idx) + let min_elt may_nulls_set = + if M.is_top may_nulls_set then + Z.zero + else + M.min_elt may_nulls_set + end - include HelperFunctionsIndexMustMaySets + (* (Must Null Set, May Null Set, Array Size) *) + include Lattice.Prod3 (MustSet) (MaySet) (Idx) let name () = "arrays containing null bytes" type idx = Idx.t type value = Val.t type ret = Null | NotNull | Top + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr (* helper: returns Idx.maximal except for Overflows that are mapped to None *) let idx_maximal i = match Idx.maximal i with - | Some i -> (try Some (Z.of_int (Z.to_int i)) with Z.Overflow -> None) - | None -> None + | Some i when Z.fits_int i -> Some i + | _ -> None - let get ?(checkBounds=true) (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = + let get (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = let all_indexes_must_null i max = - let rec check_all_indexes i = - if Z.gt i max then - true - else if MustNulls.mem i must_nulls_set then - check_all_indexes (Z.succ i) - else - false in - if MustNulls.is_bot must_nulls_set then + if MustSet.is_bot must_nulls_set then true - else if Z.lt (Z.of_int (MustNulls.cardinal must_nulls_set)) (Z.sub max i) then + else if Z.lt (Z.of_int (MustSet.cardinal must_nulls_set)) (Z.sub max i) then false else + let rec check_all_indexes i = + if Z.gt i max then + true + else if MustSet.mem i must_nulls_set then + check_all_indexes (Z.succ i) + else + false in check_all_indexes i in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num @@ -1097,7 +1085,7 @@ struct (* if there is no maximum value in index interval *) | None, _ -> (* ... return NotNull if no i >= min_i in may_nulls_set *) - if not (MayNulls.exists (Z.leq min_i) may_nulls_set) then + if not (MaySet.exists (Z.leq min_i) may_nulls_set) then NotNull (* ... else return Top *) else @@ -1108,7 +1096,7 @@ struct if Z.lt max_i min_size && all_indexes_must_null min_i max_i then Null (* ... return NotNull if no number in index interval is in may_nulls_set *) - else if not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + else if not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then NotNull else Top @@ -1117,7 +1105,7 @@ struct if Z.lt max_i min_size && all_indexes_must_null min_i max_i then Null (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) - else if Z.lt max_i max_size && not (MayNulls.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + else if Z.lt max_i max_size && not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then NotNull else Top @@ -1129,7 +1117,7 @@ struct if Z.gt i max then may_nulls_set else - add_indexes (Z.succ i) max (MayNulls.add i may_nulls_set) in + add_indexes (Z.succ i) max (MaySet.add i may_nulls_set) in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1143,32 +1131,32 @@ struct (* if size has no upper limit *) | None -> (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) - if Val.is_not_null v && not (MayNulls.is_top may_nulls_set) then - (must_nulls_remove i must_nulls_set min_size, MayNulls.remove i may_nulls_set, size) + if Val.is_not_null v && not (MaySet.is_top may_nulls_set) then + (MustSet.remove i must_nulls_set min_size, MaySet.M.remove i may_nulls_set, size) else if Val.is_not_null v then - (must_nulls_remove i must_nulls_set min_size, may_nulls_set, size) + (MustSet.remove i must_nulls_set min_size, may_nulls_set, size) (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) else if Z.lt i min_size && Val.is_null v then - (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (MustSet.add i must_nulls_set, MaySet.add i may_nulls_set, size) (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) else if Val.is_null v then - (must_nulls_set, MayNulls.add i may_nulls_set, size) + (must_nulls_set, MaySet.add i may_nulls_set, size) (* ... and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else - (must_nulls_remove i must_nulls_set min_size, MayNulls.add i may_nulls_set, size) + (MustSet.remove i must_nulls_set min_size, MaySet.add i may_nulls_set, size) | Some max_size -> (* if value <> null, remove i from must_nulls_set and may_nulls_set *) if Val.is_not_null v then - (must_nulls_remove i must_nulls_set min_size, may_nulls_remove i may_nulls_set max_size, size) + (MustSet.remove i must_nulls_set min_size, MaySet.remove i may_nulls_set max_size, size) (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) else if Z.lt i min_size && Val.is_null v then - (MustNulls.add i must_nulls_set, MayNulls.add i may_nulls_set, size) + (MustSet.add i must_nulls_set, MaySet.add i may_nulls_set, size) (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) else if Z.lt i max_size && Val.is_null v then - (must_nulls_set, MayNulls.add i may_nulls_set, size) + (must_nulls_set, MaySet.add i may_nulls_set, size) (* if i < maximal size and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else if Z.lt i max_size then - (must_nulls_remove i must_nulls_set min_size, MayNulls.add i may_nulls_set, size) + (MustSet.remove i must_nulls_set min_size, MaySet.add i may_nulls_set, size) (* if i >= maximal size, return tuple unmodified *) else (must_nulls_set, may_nulls_set, size) in @@ -1179,9 +1167,9 @@ struct must_nulls_set (* if value <> null or unknown, only keep indexes must_i < minimal index and must_i > maximal index *) else if Z.equal min_i Z.zero && Z.geq max_i min_size then - MustNulls.top () + MustSet.top () else - must_nulls_filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set min_size in + MustSet.filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set min_size in let set_interval_may min_i max_i = (* if value <> null, return may_nulls_set unmodified as not clear which index is set to value *) @@ -1195,7 +1183,7 @@ struct | Some max_size -> (* ... add all indexes < maximal size to may_nulls_set *) if Z.equal min_i Z.zero && Z.geq max_i max_size then - MayNulls.top () + MaySet.top () else if Z.geq max_i max_size then add_indexes min_i (Z.pred max_size) may_nulls_set else @@ -1210,23 +1198,23 @@ struct (if Val.is_null v && idx_maximal size = None then match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> (must_nulls_set, MayNulls.top (), size) + | None -> (must_nulls_set, MaySet.top (), size) (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else if Val.is_not_null v then - (must_nulls_filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) + (MustSet.filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) (*..., value unknown *) else match Idx.minimal size, idx_maximal size with (* ... and size unknown, modify both sets to top *) - | None, None -> (MustNulls.top (), MayNulls.top (), size) + | None, None -> (MustSet.top (), MaySet.top (), size) (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) - | Some min_size, None -> (must_nulls_filter (Z.gt min_size) must_nulls_set min_size, MayNulls.top (), size) + | Some min_size, None -> (MustSet.filter (Z.gt min_size) must_nulls_set min_size, MaySet.top (), size) (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) - | None, Some max_size -> (MustNulls.top (), add_indexes min_i (Z.pred max_size) may_nulls_set, size) + | None, Some max_size -> (MustSet.top (), add_indexes min_i (Z.pred max_size) may_nulls_set, size) (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) - | Some min_size, Some max_size -> (must_nulls_filter (Z.gt min_size) must_nulls_set min_size, add_indexes min_i (Z.pred max_size) may_nulls_set, size)) + | Some min_size, Some max_size -> (MustSet.filter (Z.gt min_size) must_nulls_set min_size, add_indexes min_i (Z.pred max_size) may_nulls_set, size)) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then set_exact min_i @@ -1261,14 +1249,14 @@ struct | None, None -> Z.zero, None in match max_i, Val.is_null v, Val.is_not_null v with (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) - | Some max_i, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) - | None, true, _ -> (MustNulls.bot (), MayNulls.top (), Idx.starting ILong min_i) + | Some max_i, true, _ -> (MustSet.bot (), MaySet.top (), Idx.of_interval ILong (min_i, max_i)) + | None, true, _ -> (MustSet.bot (), MaySet.top (), Idx.starting ILong min_i) (* if value <> null, return (top = no indexes, bot = no indexes, size) *) - | Some max_i, false, true -> (MustNulls.top (), MayNulls.bot (), Idx.of_interval ILong (min_i, max_i)) - | None, false, true -> (MustNulls.top (), MayNulls.bot (), Idx.starting ILong min_i) + | Some max_i, false, true -> (MustSet.top (), MaySet.bot (), Idx.of_interval ILong (min_i, max_i)) + | None, false, true -> (MustSet.top (), MaySet.bot (), Idx.starting ILong min_i) (* if value unknown, return (top = no indexes, top = all indexes up to maximal size - 1, size) *) - | Some max_i, false, false -> (MustNulls.top (), MayNulls.top (), Idx.of_interval ILong (min_i, max_i)) - | None, false, false -> (MustNulls.top (), MayNulls.top (), Idx.starting ILong min_i) + | Some max_i, false, false -> (MustSet.top (), MaySet.top (), Idx.of_interval ILong (min_i, max_i)) + | None, false, false -> (MustSet.top (), MaySet.top (), Idx.starting ILong min_i) let length (_, _, size) = Some size @@ -1280,15 +1268,13 @@ struct (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) if Val.is_null (f (Val.null ())) then - (must_nulls_set, MayNulls.top (), size) + (must_nulls_set, MaySet.top (), size) (* else also return top for must_nulls_set *) else - (MustNulls.top (), MayNulls.top (), size) + (MustSet.top (), MaySet.top (), size) let fold_left f acc _ = f acc (Val.top ()) - let content_to_top (_, _, size) = (MustNulls.top (), MayNulls.top (), size) - let smart_join _ _ = join let smart_widen _ _ = widen let smart_leq _ _ = leq @@ -1299,43 +1285,43 @@ struct let last_null = Z.of_int (String.length s) in let rec build_set i set = if Z.geq (Z.of_int i) last_null then - MayNulls.add last_null set + MaySet.add last_null set else match String.index_from_opt s i '\x00' with - | Some i -> build_set (i + 1) (MayNulls.add (Z.of_int i) set) - | None -> MayNulls.add last_null set in - let set = build_set 0 (MayNulls.empty ()) in + | Some i -> build_set (i + 1) (MaySet.add (Z.of_int i) set) + | None -> MaySet.add last_null set in + let set = build_set 0 (MaySet.empty ()) in (set, set, Idx.of_int ILong (Z.succ last_null)) (** Returns an abstract value with at most one null byte marking the end of the string *) let to_string (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) - if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; (must_nulls_set, may_nulls_set, size)) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) - else if MustNulls.is_empty must_nulls_set then + else if MustSet.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; (must_nulls_set, may_nulls_set, size)) else - let min_must_null = must_nulls_min_elt must_nulls_set in + let min_must_null = MustSet.min_elt must_nulls_set in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - if Z.equal min_must_null (may_nulls_min_elt may_nulls_set) then - (MustNulls.singleton min_must_null, MayNulls.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) + if Z.equal min_must_null (MaySet.min_elt may_nulls_set) then + (MustSet.singleton min_must_null, MaySet.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with - | Some max_size -> (MustNulls.empty (), may_nulls_filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) + | Some max_size -> (MustSet.empty (), MaySet.filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) | None -> - if MayNulls.is_top may_nulls_set then + if MaySet.is_top may_nulls_set then let rec add_indexes acc i = if Z.gt i min_must_null then acc else - add_indexes (MayNulls.add i acc) (Z.succ i) in - (MustNulls.empty (), add_indexes (MayNulls.empty ()) Z.zero, Idx.of_int ILong (Z.succ min_must_null)) + add_indexes (MaySet.add i acc) (Z.succ i) in + (MustSet.empty (), add_indexes (MaySet.empty ()) Z.zero, Idx.of_int ILong (Z.succ min_must_null)) else - (MustNulls.empty (), MayNulls.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) + (MustSet.empty (), MaySet.M.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain @@ -1345,21 +1331,21 @@ struct if Z.geq i max then set else - add_indexes (Z.succ i) max (MayNulls.add i set) in + add_indexes (Z.succ i) max (MaySet.add i set) in let update_must_indexes min_must_null must_nulls_set = if Z.equal min_must_null Z.zero then - MustNulls.bot () + MustSet.bot () else (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) add_indexes min_must_null (Z.of_int n) must_nulls_set - |> MustNulls.filter (Z.gt (Z.of_int n)) in + |> MustSet.M.filter (Z.gt (Z.of_int n)) in let update_may_indexes min_may_null may_nulls_set = if Z.equal min_may_null Z.zero then - MayNulls.top () + MaySet.top () else (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) add_indexes min_may_null (Z.of_int n) may_nulls_set - |> MayNulls.filter (Z.gt (Z.of_int n)) in + |> MaySet.M.filter (Z.gt (Z.of_int n)) in let warn_no_null min_must_null exists_min_must_null min_may_null = if Z.geq min_may_null (Z.of_int n) then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" @@ -1367,7 +1353,7 @@ struct M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in if n < 0 then - (MustNulls.top (), MayNulls.top (), Idx.top_of ILong) + (MustSet.top (), MaySet.top (), Idx.top_of ILong) else ((match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> @@ -1384,7 +1370,7 @@ struct | None, None -> ()); (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) - if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with @@ -1393,35 +1379,35 @@ struct | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) - else if MustNulls.is_empty must_nulls_set then - let min_may_null = may_nulls_min_elt may_nulls_set in + else if MustSet.is_empty must_nulls_set then + let min_may_null = MaySet.min_elt may_nulls_set in warn_no_null Z.zero false min_may_null; (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else - let min_must_null = must_nulls_min_elt must_nulls_set in - let min_may_null = may_nulls_min_elt may_nulls_set in + let min_must_null = MustSet.min_elt must_nulls_set in + let min_may_null = MaySet.min_elt may_nulls_set in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) if Z.equal min_must_null min_may_null then (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else - (MustNulls.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) + (MustSet.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) - if MustNulls.is_empty must_nulls_set && MayNulls.is_empty may_nulls_set then + if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) - else if MustNulls.is_empty must_nulls_set then + else if MustSet.is_empty must_nulls_set then (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set)) + Idx.starting !Cil.kindOfSizeOf (MaySet.min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (may_nulls_min_elt may_nulls_set, must_nulls_min_elt must_nulls_set) + Idx.of_interval !Cil.kindOfSizeOf (MaySet.min_elt may_nulls_set, MustSet.min_elt must_nulls_set) let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) @@ -1437,17 +1423,17 @@ struct | Some min_size2 -> min_size2 | None -> Z.zero in (* get must nulls from src string < minimal size of dest *) - must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 + MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 (* and keep indexes of dest >= maximal strlen of src *) - |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in + |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = let max_size2 = match idx_maximal size2' with | Some max_size2 -> max_size2 | None -> max_size1 in (* get may nulls from src string < maximal size of dest *) - may_nulls_filter (Z.gt max_size1) may_nulls_set2' max_size2 + MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 (* and keep indexes of dest >= minimal strlen of src *) - |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in + |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then @@ -1456,12 +1442,12 @@ struct let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 - |> MustNulls.union (must_nulls_filter (Z.leq max_len2) must_nulls_set1 min_size1) in + MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 + |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' - |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then @@ -1473,13 +1459,13 @@ struct let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 in + MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = let max_size2 = match idx_maximal size2' with | Some max_size2 -> max_size2 | None -> max_size1 in - may_nulls_filter (Z.gt max_size1) may_nulls_set2' max_size2 - |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 max_size1) in + MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 + |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then @@ -1489,36 +1475,36 @@ struct let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 | None -> Z.zero in - must_nulls_filter (Z.gt min_size1) must_nulls_set2' min_size2 in + MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' - |> MayNulls.union (may_nulls_filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in (must_nulls_set_result, may_nulls_set_result, size1) (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustNulls.top (), MayNulls.top (), size1) in + | _ -> (MustSet.top (), MaySet.top (), size1) in (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) let sizes_warning size2 = (match Idx.minimal size1, idx_maximal size1, Idx.minimal size2, idx_maximal size2 with | Some min_size1, _, Some min_size2, _ when Z.lt min_size1 min_size2 -> - if not (MayNulls.exists (Z.gt min_size1) may_nulls_set2) then + if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" - else if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" | Some min_size1, _, _, Some max_size2 when Z.lt min_size1 max_size2 -> - if not (MayNulls.exists (Z.gt min_size1) may_nulls_set2) then + if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" - else if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" | Some min_size1, _, _, None -> - if not (MustNulls.exists (Z.gt min_size1) must_nulls_set2) then + if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" | _, Some max_size1, _, Some max_size2 when Z.lt max_size1 max_size2 -> - if not (MustNulls.exists (Z.gt max_size1) must_nulls_set2) then + if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" |_, Some max_size1, _, None -> - if not (MustNulls.exists (Z.gt max_size1) must_nulls_set2) then + if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" | _ -> ()) in @@ -1534,7 +1520,7 @@ struct sizes_warning (Idx.of_int ILong (Z.of_int n)); let must_nulls_set2', may_nulls_set2', size2' = to_n_string (must_nulls_set2, may_nulls_set2, size2) n in update_sets must_nulls_set2' may_nulls_set2' size2' (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - | _ -> (MustNulls.top (), MayNulls.top (), size1) + | _ -> (MustSet.top (), MaySet.top (), size1) let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = @@ -1548,70 +1534,70 @@ struct (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) - if MustNulls.is_empty must_nulls_set1 || MustNulls.is_empty must_nulls_set2' then + if MustSet.is_empty must_nulls_set1 || MustSet.is_empty must_nulls_set2' then let may_nulls_set_result = if max_size1_exists then - may_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 - |> MayNulls.elements + MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + |> MaySet.elements (* if may_nulls_set2' is top, limit it to max_size1 *) - |> BatList.cartesian_product (MayNulls.elements (may_nulls_filter (fun x -> true) may_nulls_set2' max_size1)) + |> BatList.cartesian_product (MaySet.elements (MaySet.filter (fun x -> true) may_nulls_set2' max_size1)) |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (may_nulls_filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) - |> MayNulls.filter (Z.gt max_size1) - else if not (MayNulls.is_top may_nulls_set1) && not (MayNulls.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then - MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 - |> MayNulls.elements - |> BatList.cartesian_product (MayNulls.elements may_nulls_set2') + |> MaySet.of_list + |> MaySet.union (MaySet.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MaySet.M.filter (Z.gt max_size1) + else if not (MaySet.is_top may_nulls_set1) && not (MaySet.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then + MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + |> MaySet.elements + |> BatList.cartesian_product (MaySet.elements may_nulls_set2') |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MaySet.of_list + |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) else - MayNulls.top () in - (MustNulls.top (), may_nulls_set_result, size1) + MaySet.top () in + (MustSet.top (), may_nulls_set_result, size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) - else if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) && Z.equal (must_nulls_min_elt must_nulls_set2') (may_nulls_min_elt may_nulls_set2') then - let min_i1 = must_nulls_min_elt must_nulls_set1 in - let min_i2 = must_nulls_min_elt must_nulls_set2' in + else if Z.equal (MustSet.min_elt must_nulls_set1) (MaySet.min_elt may_nulls_set1) && Z.equal (MustSet.min_elt must_nulls_set2') (MaySet.min_elt may_nulls_set2') then + let min_i1 = MustSet.min_elt must_nulls_set1 in + let min_i2 = MustSet.min_elt must_nulls_set2' in let min_i = Z.add min_i1 min_i2 in let must_nulls_set_result = - must_nulls_filter (Z.lt min_i) must_nulls_set1 min_size1 - |> MustNulls.add min_i - |> MustNulls.filter (Z.gt min_size1) in + MustSet.filter (Z.lt min_i) must_nulls_set1 min_size1 + |> MustSet.add min_i + |> MustSet.M.filter (Z.gt min_size1) in let may_nulls_set_result = if max_size1_exists then - may_nulls_filter (Z.lt min_i) may_nulls_set1 max_size1 - |> MayNulls.add min_i - |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + MaySet.filter (Z.lt min_i) may_nulls_set1 max_size1 + |> MaySet.add min_i + |> MaySet.M.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) else - MayNulls.top () in + MaySet.top () in (must_nulls_set_result, may_nulls_set_result, size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else - let min_i2 = must_nulls_min_elt must_nulls_set2' in + let min_i2 = MustSet.min_elt must_nulls_set2' in let may_nulls_set2'_until_min_i2 = match idx_maximal size2 with - | Some max_size2 -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' max_size2 - | None -> may_nulls_filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in - let must_nulls_set_result = must_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 min_size1 in + | Some max_size2 -> MaySet.filter (Z.geq min_i2) may_nulls_set2' max_size2 + | None -> MaySet.filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in + let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 min_size1 in let may_nulls_set_result = if max_size1_exists then - may_nulls_filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 - |> MayNulls.elements - |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) + MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + |> MaySet.elements + |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (may_nulls_filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) - |> MayNulls.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) - else if not (MayNulls.is_top may_nulls_set1) then - MayNulls.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 - |> MayNulls.elements - |> BatList.cartesian_product (MayNulls.elements may_nulls_set2'_until_min_i2) + |> MaySet.of_list + |> MaySet.union (MaySet.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MaySet.M.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + else if not (MaySet.is_top may_nulls_set1) then + MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + |> MaySet.elements + |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> Z.add i1 i2) - |> MayNulls.of_list - |> MayNulls.union (MayNulls.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MaySet.of_list + |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) else - MayNulls.top () in + MaySet.top () in (must_nulls_set_result, may_nulls_set_result, size1) in let compute_concat must_nulls_set2' may_nulls_set2' = @@ -1637,7 +1623,7 @@ struct update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' end (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustNulls.top (), MayNulls.top (), size1) in + | _ -> (MustSet.top (), MaySet.top (), size1) in match n with (* strcat *) @@ -1649,13 +1635,13 @@ struct (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let must_nulls_set2', may_nulls_set2' = let must_nulls_set2, may_nulls_set2, size2 = to_string (must_nulls_set2, may_nulls_set2, size2) in - if not (MayNulls.exists (Z.gt (Z.of_int n)) may_nulls_set2) then - (MustNulls.singleton (Z.of_int n), MayNulls.singleton (Z.of_int n)) - else if not (MustNulls.exists (Z.gt (Z.of_int n)) must_nulls_set2) then + if not (MaySet.exists (Z.gt (Z.of_int n)) may_nulls_set2) then + (MustSet.singleton (Z.of_int n), MaySet.singleton (Z.of_int n)) + else if not (MustSet.exists (Z.gt (Z.of_int n)) must_nulls_set2) then let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> Z.succ (Z.of_int n) in - (MustNulls.empty (), MayNulls.add (Z.of_int n) (may_nulls_filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) + (MustSet.empty (), MaySet.add (Z.of_int n) (MaySet.filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) else let min_size2 = match Idx.minimal size2 with | Some min_size2 -> min_size2 @@ -1663,14 +1649,14 @@ struct let max_size2 = match idx_maximal size2 with | Some max_size2 -> max_size2 | None -> Z.of_int n in - (must_nulls_filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, may_nulls_filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in + (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in compute_concat must_nulls_set2' may_nulls_set2' - | _ -> (MustNulls.top (), MayNulls.top (), size1) + | _ -> (MustSet.top (), MaySet.top (), size1) let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) - if MustNulls.mem Z.zero must_nulls_set_needle then - false, true + if MustSet.mem Z.zero must_nulls_set_needle then + IsSubstrAtIndex0 else let haystack_len = to_string_length haystack in let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in @@ -1678,29 +1664,29 @@ struct | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) if Z.lt haystack_max needle_min then - true, false + IsNotSubstr else - false, false - | _ -> false, false + IsMaybeSubstr + | _ -> IsMaybeSubstr let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) - if (MustNulls.mem Z.zero must_nulls_set1 && (MustNulls.mem Z.zero must_nulls_set2)) + if (MustSet.mem Z.zero must_nulls_set1 && (MustSet.mem Z.zero must_nulls_set2)) || (n_exists && Z.equal Z.zero n) then Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) - else if MustNulls.mem Z.zero must_nulls_set1 && not (MayNulls.mem Z.zero may_nulls_set2) then + else if MustSet.mem Z.zero must_nulls_set1 && not (MaySet.mem Z.zero may_nulls_set2) then Idx.ending IInt Z.minus_one (* if only s2 = empty string, return positive integer *) - else if MustNulls.mem Z.zero must_nulls_set2 then + else if MustSet.mem Z.zero must_nulls_set2 then Idx.starting IInt Z.one else (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) - (try if Z.equal (must_nulls_min_elt must_nulls_set1) (may_nulls_min_elt may_nulls_set1) - && Z.equal (must_nulls_min_elt must_nulls_set2) (may_nulls_min_elt may_nulls_set2) - && (not n_exists || Z.lt (must_nulls_min_elt must_nulls_set1) n || Z.lt (must_nulls_min_elt must_nulls_set2) n ) - && not (Z.equal (must_nulls_min_elt must_nulls_set1) (must_nulls_min_elt must_nulls_set2)) then + (try if Z.equal (MustSet.min_elt must_nulls_set1) (MaySet.min_elt may_nulls_set1) + && Z.equal (MustSet.min_elt must_nulls_set2) (MaySet.min_elt may_nulls_set2) + && (not n_exists || Z.lt (MustSet.min_elt must_nulls_set1) n || Z.lt (MustSet.min_elt must_nulls_set2) n ) + && not (Z.equal (MustSet.min_elt must_nulls_set1) (MustSet.min_elt must_nulls_set2)) then Idx.of_excl_list IInt [Z.zero] else Idx.top_of IInt @@ -1710,13 +1696,13 @@ struct (* strcmp *) | None -> (* track any potential buffer overflow and issue warning if needed *) - (if MustNulls.is_empty must_nulls_set1 && MayNulls.is_empty may_nulls_set1 then + (if MustSet.is_empty must_nulls_set1 && MaySet.is_empty may_nulls_set1 then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" - else if MustNulls.is_empty must_nulls_set1 then + else if MustSet.is_empty must_nulls_set1 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); - (if MustNulls.is_empty must_nulls_set2 && MayNulls.is_empty may_nulls_set2 then + (if MustSet.is_empty must_nulls_set2 && MaySet.is_empty may_nulls_set2 then M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" - else if MustNulls.is_empty must_nulls_set2 then + else if MustSet.is_empty must_nulls_set2 then M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); (* compute abstract value for result of strcmp *) compare Z.zero false @@ -1758,7 +1744,7 @@ struct let invariant ~value_invariant ~offset ~lval x = Invariant.none end -module FlagHelperAttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = +module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = struct module P = PartitionedWithLength(Val)(Idx) module T = TrivialWithLength(Val)(Idx) @@ -1823,8 +1809,6 @@ struct | TrivialDomain -> (None, Some (T.top ()), None) | UnrolledDomain -> (None, None, Some (U.top ())) - let content_to_top x = unop_to_t' P.content_to_top T.content_to_top U.content_to_top x - let make ?(varAttr=[]) ?(typAttr=[]) i v = to_t @@ match get_domain ~varAttr ~typAttr with | PartitionedDomain -> (Some (P.make i v), None, None) | TrivialDomain -> (None, Some (T.make i v), None) @@ -1882,26 +1866,27 @@ struct (U.invariant ~value_invariant ~offset ~lval) end -module AttributeConfiguredArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t = +module AttributeConfiguredAndNullByteArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t = struct - module F = FlagHelperAttributeConfiguredArrayDomain (Val) (Idx) + module A = AttributeConfiguredArrayDomain (Val) (Idx) module N = NullByte (Val) (Idx) - include Lattice.Prod (F) (N) + include Lattice.Prod (A) (N) - let name () = "AttributeConfiguredArrayDomain" + let name () = "AttributeConfiguredAndNullByteArrayDomain" type idx = Idx.t type value = Val.t type ret = Null | NotNull | Top + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr - let domain_of_t (t_f, _) = F.domain_of_t t_f + let domain_of_t (t_f, _) = A.domain_of_t t_f let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = - let f_get = F.get ~checkBounds ask t_f i in + let f_get = A.get ~checkBounds ask t_f i in if get_bool "ana.base.arrays.nullbytes" then - let n_get = N.get ~checkBounds ask t_n i in - match Val.is_int_ikind f_get, n_get with + let n_get = N.get ask t_n i in + match Val.get_ikind f_get, n_get with | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) | _ -> f_get @@ -1909,55 +1894,49 @@ struct f_get let set (ask:VDQ.t) (t_f, t_n) i v = if get_bool "ana.base.arrays.nullbytes" then - (F.set ask t_f i v, N.set ask t_n i v) + (A.set ask t_f i v, N.set ask t_n i v) else - (F.set ask t_f i v, N.top ()) + (A.set ask t_f i v, N.top ()) let make ?(varAttr=[]) ?(typAttr=[]) i v = if get_bool "ana.base.arrays.nullbytes" then - (F.make ~varAttr ~typAttr i v, N.make i v) + (A.make ~varAttr ~typAttr i v, N.make i v) else - (F.make ~varAttr ~typAttr i v, N.top ()) + (A.make ~varAttr ~typAttr i v, N.top ()) let length (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.length t_n else - F.length t_f - let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (F.move_if_affected ~replace_with_const ask t_f v f, N.move_if_affected ~replace_with_const ask t_n v f) - let get_vars_in_e (t_f, _) = F.get_vars_in_e t_f + A.length t_f + let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (A.move_if_affected ~replace_with_const ask t_f v f, N.move_if_affected ~replace_with_const ask t_n v f) + let get_vars_in_e (t_f, _) = A.get_vars_in_e t_f let map f (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then - (F.map f t_f, N.map f t_n) - else - (F.map f t_f, N.top ()) - let fold_left f acc (t_f, _) = F.fold_left f acc t_f - - let content_to_top (t_f, t_n) = - if get_bool "ana.base.arrays.nullbytes" then - (F.content_to_top t_f, N.content_to_top t_n) + (A.map f t_f, N.map f t_n) else - (F.content_to_top t_f, N.top ()) + (A.map f t_f, N.top ()) + let fold_left f acc (t_f, _) = A.fold_left f acc t_f let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then - (F.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) + (A.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) else - (F.smart_join x y t_f1 t_f2, N.top ()) + (A.smart_join x y t_f1 t_f2, N.top ()) let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then - (F.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) + (A.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) else - (F.smart_widen x y t_f1 t_f2, N.top ()) + (A.smart_widen x y t_f1 t_f2, N.top ()) let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then - F.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 + A.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 else - F.smart_leq x y t_f1 t_f2 + A.smart_leq x y t_f1 t_f2 let to_null_byte_domain s = if get_bool "ana.base.arrays.nullbytes" then - (F.make (Idx.top_of ILong) (Val.meet (Val.not_zero_of_ikind IChar) (Val.zero_of_ikind IChar)), N.to_null_byte_domain s) + (A.make (Idx.top_of ILong) (Val.meet (Val.not_zero_of_ikind IChar) (Val.zero_of_ikind IChar)), N.to_null_byte_domain s) else - (F.top (), N.top ()) + (A.top (), N.top ()) let to_string_length (_, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.to_string_length t_n @@ -1965,19 +1944,18 @@ struct Idx.top_of !Cil.kindOfSizeOf let string_copy (t_f1, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then - (F.content_to_top t_f1, N.string_copy t_n1 t_n2 n) + (A.map Val.invalidate_abstract_value t_f1, N.string_copy t_n1 t_n2 n) else - (F.content_to_top t_f1, N.top ()) + (A.map Val.invalidate_abstract_value t_f1, N.top ()) let string_concat (t_f1, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then - (F.content_to_top t_f1, N.string_concat t_n1 t_n2 n) - else - (F.content_to_top t_f1, N.top ()) - let substring_extraction (_, t_n1) (_, t_n2) = - if get_bool "ana.base.arrays.nullbytes" then - N.substring_extraction t_n1 t_n2 + (A.map Val.invalidate_abstract_value t_f1, N.string_concat t_n1 t_n2 n) else - false, false + (A.map Val.invalidate_abstract_value t_f1, N.top ()) + let substring_extraction (_, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with + | IsNotSubstr when get_bool "ana.base.arrays.nullbytes" -> IsNotSubstr + | IsSubstrAtIndex0 when get_bool "ana.base.arrays.nullbytes" -> IsSubstrAtIndex0 + | _ -> IsMaybeSubstr let string_comparison (_, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then N.string_comparison t_n1 t_n2 n @@ -1986,9 +1964,9 @@ struct let update_length newl (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then - (F.update_length newl t_f, N.update_length newl t_n) + (A.update_length newl t_f, N.update_length newl t_n) else - (F.update_length newl t_f, N.top ()) - let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (F.project ~varAttr ~typAttr ask t_f, N.project ~varAttr ~typAttr ask t_n) - let invariant ~value_invariant ~offset ~lval (t_f, _) = F.invariant ~value_invariant ~offset ~lval t_f + (A.update_length newl t_f, N.top ()) + let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (A.project ~varAttr ~typAttr ask t_f, N.project ~varAttr ~typAttr ask t_n) + let invariant ~value_invariant ~offset ~lval (t_f, _) = A.invariant ~value_invariant ~offset ~lval t_f end diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 915dfee470..fef063f765 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -46,9 +46,6 @@ sig val fold_left: ('a -> value -> 'a) -> 'a -> t -> 'a (** Left fold (like List.fold_left) over the arrays elements *) - val content_to_top: t -> t - (** Maps the array's content to top of value, but keeps the type and the size if known *) - val smart_join: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool @@ -75,8 +72,9 @@ sig include S0 type ret = Null | NotNull | Top + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret (* overwrites get of module S *) val to_null_byte_domain: string -> t @@ -94,11 +92,10 @@ sig * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of * [s2] if present *) - val substring_extraction: t -> t -> bool * bool - (** [substring_extraction haystack needle] returns [is_null_ptr, is_offset_0], i.e. - * [true, false] if the string represented by the abstract value [needle] surely isn't a - * substring of [haystack], [false, true] if [needle] is the empty string, - * else [false, false] *) + val substring_extraction: t -> t -> substr + (** [substring_extraction haystack needle] returns [IsNotSubstr] if the string represented by + * the abstract value [needle] surely isn't a substring of [haystack], [IsSubstrAtIndex0] if + * [needle] is the empty string, else [Unknown] *) val string_comparison: t -> t -> int option -> idx (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string @@ -137,7 +134,7 @@ sig val is_null: t -> bool val is_not_null: t -> bool - val is_int_ikind: t -> Cil.ikind option + val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t val not_zero_of_ikind: Cil.ikind -> t end @@ -170,10 +167,10 @@ module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = * for this domain. It additionally tracks the array size. *) -module FlagHelperAttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +module AttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) -module AttributeConfiguredArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t +module AttributeConfiguredAndNullByteArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t (** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte * in parallel if flag "ana.base.arrays.nullbytes" is set. *) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index b396f3802c..aa52770475 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -43,7 +43,7 @@ sig val is_null: t -> bool val is_not_null: t -> bool - val is_int_ikind: t -> Cil.ikind option + val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t val not_zero_of_ikind: Cil.ikind -> t @@ -272,38 +272,19 @@ struct let is_top x = x = Top let top_name = "Unknown" - let null () = Int(ID.of_int IChar Z.zero) + let null () = Int (ID.of_int IChar Z.zero) + let is_null = function - | Int n -> - begin match ID.to_int n with - | Some n -> Z.equal n Z.zero - | None -> false - end + | Int n -> GobOption.exists (Z.equal Z.zero) (ID.to_int n) | _ -> false + let is_not_null = function | Int n -> - begin match ID.minimal n, ID.maximal n with - | Some min, Some max -> - if Z.gt min Z.zero || Z.lt max Z.zero then - true - else - false - | Some min, None -> - if Z.gt min Z.zero then - true - else - false - | None, Some max -> - if Z.lt max Z.zero then - true - else - false - | _ -> false - end - | Address a when AD.may_be_null a -> false + let zero_ik = ID.of_int (ID.ikind n) Z.zero in + ID.to_bool (ID.ne n zero_ik) = Some true | _ -> false (* we don't know anything *) - let is_int_ikind = function + let get_ikind = function | Int n -> Some (ID.ikind n) | _ -> None let zero_of_ikind ik = Int(ID.of_int ik Z.zero) @@ -758,14 +739,14 @@ struct | _, Bot -> Bot (* Leave uninitialized value (from malloc) alone in free to avoid trashing everything. TODO: sound? *) | t , _ -> top_value t - let invalidate_abstract_value = function + let rec invalidate_abstract_value = function | Top -> Top | Int i -> Int (ID.top_of (ID.ikind i)) | Float f -> Float (FD.top_of (FD.get_fkind f)) | Address _ -> Address (AD.top_ptr) - | Struct _ -> Struct (Structs.top ()) - | Union _ -> Union (Unions.top ()) - | Array _ -> Array (CArrays.top ()) + | Struct s -> Struct (Structs.map invalidate_abstract_value s) + | Union u -> Union (Unions.top ()) + | Array a -> Array (CArrays.map invalidate_abstract_value a) | Blob _ -> Blob (Blobs.top ()) | Thread _ -> Thread (Threads.top ()) | JmpBuf _ -> JmpBuf (JmpBufs.top ()) @@ -1291,7 +1272,7 @@ and Structs: StructDomain.S with type field = fieldinfo and type value = Compoun and Unions: UnionDomain.S with type t = UnionDomain.Field.t * Compound.t and type value = Compound.t = UnionDomain.Simple (Compound) -and CArrays: ArrayDomain.StrWithDomain with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredArrayDomain(Compound)(ArrIdxDomain) +and CArrays: ArrayDomain.StrWithDomain with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredAndNullByteArrayDomain(Compound)(ArrIdxDomain) and Blobs: Blob with type size = ID.t and type value = Compound.t and type origin = ZeroInit.t = Blob (Compound) (ID) From c407d3dd8282f2b6c128038f21919113f19da244 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 9 Oct 2023 19:02:55 +0200 Subject: [PATCH 044/233] Added test cases to increase coverage --- tests/regression/73-strings/05-char_arrays.c | 53 ++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/tests/regression/73-strings/05-char_arrays.c b/tests/regression/73-strings/05-char_arrays.c index edb5a2ab57..e5c7596063 100644 --- a/tests/regression/73-strings/05-char_arrays.c +++ b/tests/regression/73-strings/05-char_arrays.c @@ -20,6 +20,9 @@ int main() { example13(); example14(); example15(); + example16(); + example17(); + example18(); return 0; } @@ -328,3 +331,53 @@ example15() { char* s3 = strstr(s1, s2); __goblint_check(s3 == NULL); } + +example16() { + size_t i; + if (rand()) + i = 3; + else + i = 1/0; + + char s[5] = "abab"; + __goblint_check(s[i] != '\0'); // UNKNOWN + + s[4] = 'a'; + __goblint_check(s[i] != '\0'); + + s[4] = '\0'; + s[i] = '\0'; + __goblint_check(s[4] == '\0'); + __goblint_check(s[3] == '\0'); // UNKNOWN + + s[i] = 'a'; + __goblint_check(s[4] == '\0'); // UNKNOWN +} + +example17() { + char s1[20]; + char s2[10]; + strcat(s1, s2); // WARN + __goblint_check(s1[0] == '\0'); // UNKNOWN + __goblint_check(s1[5] == '\0'); // UNKNOWN + __goblint_check(s1[12] == '\0'); // UNKNOWN +} + +example18() { + char s1[20] = "hello"; + char s2[10] = "world"; + + size_t i; + if (rand()) + i = 1; + else + i = 2; + s1[i] = '\0'; + + strcat(s1, s2); + __goblint_check(s1[1] != '\0'); + __goblint_check(s1[6] == '\0'); // UNKNOWN + __goblint_check(s1[7] == '\0'); // UNKNOWN + __goblint_check(s1[8] != '\0'); // UNKNOWN because might still be uninitialized + __goblint_check(s1[10] == '\0'); // UNKNOWN +} From 0e31b8d8d0b19679414d7621086c9ab408d8318c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 26 Oct 2023 19:02:07 +0300 Subject: [PATCH 045/233] Add unknown thread ID --- src/analyses/useAfterFree.ml | 2 +- src/cdomains/mHP.ml | 2 +- src/cdomains/threadIdDomain.ml | 73 +++++++++++++++++++++++++++++++++- 3 files changed, 74 insertions(+), 3 deletions(-) diff --git a/src/analyses/useAfterFree.ml b/src/analyses/useAfterFree.ml index ef63ab3e91..96a06a6cc1 100644 --- a/src/analyses/useAfterFree.ml +++ b/src/analyses/useAfterFree.ml @@ -76,7 +76,7 @@ struct end else if HeapVars.mem heap_var (snd ctx.local) then begin if is_double_free then set_mem_safety_flag InvalidFree else set_mem_safety_flag InvalidDeref; - M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "%s might occur in current unique thread %a for heap variable %a" bug_name ThreadIdDomain.FlagConfiguredTID.pretty current CilType.Varinfo.pretty heap_var + M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "%s might occur in current unique thread %a for heap variable %a" bug_name ThreadIdDomain.Thread.pretty current CilType.Varinfo.pretty heap_var end end | `Top -> diff --git a/src/cdomains/mHP.ml b/src/cdomains/mHP.ml index 8037cfa21d..016a72a77e 100644 --- a/src/cdomains/mHP.ml +++ b/src/cdomains/mHP.ml @@ -4,7 +4,7 @@ include Printable.Std let name () = "mhp" -module TID = ThreadIdDomain.FlagConfiguredTID +module TID = ThreadIdDomain.Thread module Pretty = GoblintCil.Pretty type t = { diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index 7193552048..ff6edf8bda 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -279,6 +279,77 @@ struct let name () = "FlagConfiguredTID: " ^ if history_enabled () then H.name () else P.name () end -module Thread = FlagConfiguredTID +module Thread : Stateful = +struct + include Printable.Std + type t = + | Thread of FlagConfiguredTID.t + | UnknownThread + [@@deriving eq, ord, hash] + + let name () = "Thread id" + let pretty () t = + match t with + | Thread tid -> FlagConfiguredTID.pretty () tid + | UnknownThread -> Pretty.text "Unknown thread id" + + let show t = + match t with + | Thread tid -> FlagConfiguredTID.show tid + | UnknownThread -> "Unknown thread id" + + let printXml f t = + match t with + | Thread tid -> FlagConfiguredTID.printXml f tid + | UnknownThread -> BatPrintf.fprintf f "\n\nUnknown thread id\n\n\n" + + let to_yojson t = + match t with + | Thread tid -> FlagConfiguredTID.to_yojson tid + | UnknownThread -> `String "Unknown thread id" + + let relift t = + match t with + | Thread tid -> Thread (FlagConfiguredTID.relift tid) + | UnknownThread -> UnknownThread + + let lift t = Thread t + + let threadinit v ~multiple = Thread (FlagConfiguredTID.threadinit v ~multiple) + + let is_main t = + match t with + | Thread tid -> FlagConfiguredTID.is_main tid + | UnknownThread -> false + + let is_unique t = + match t with + | Thread tid -> FlagConfiguredTID.is_unique tid + | UnknownThread -> false + + let may_create t1 t2 = + match t1, t2 with + | Thread tid1, Thread tid2 -> FlagConfiguredTID.may_create tid1 tid2 + | _, _ -> true + + let is_must_parent t1 t2 = + match t1, t2 with + | Thread tid1, Thread tid2 -> FlagConfiguredTID.is_must_parent tid1 tid2 + | _, _ -> false + + module D = FlagConfiguredTID.D + + let threadenter (t, d) node i v = + match t with + | Thread tid -> List.map lift (FlagConfiguredTID.threadenter (tid, d) node i v) + | UnknownThread -> assert false + + let threadspawn = FlagConfiguredTID.threadspawn + + let created t d = + match t with + | Thread tid -> Option.map (List.map lift) (FlagConfiguredTID.created tid d) + | UnknownThread -> None +end module ThreadLifted = Lift (Thread) From 192108b69ced96430d69148ad360cff22c4e0bf5 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 26 Oct 2023 19:34:30 +0300 Subject: [PATCH 046/233] Use set instead of toppedSet for ThreadSet --- src/cdomains/concDomain.ml | 21 ++++++++++++++++++++- src/cdomains/threadIdDomain.ml | 12 +++++++----- 2 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src/cdomains/concDomain.ml b/src/cdomains/concDomain.ml index b16cdf1d9f..5f609a31d8 100644 --- a/src/cdomains/concDomain.ml +++ b/src/cdomains/concDomain.ml @@ -1,6 +1,25 @@ (** Domains for thread sets and their uniqueness. *) -module ThreadSet = SetDomain.ToppedSet (ThreadIdDomain.Thread) (struct let topname = "All Threads" end) +module ThreadSet = +struct + include SetDomain.Make (ThreadIdDomain.Thread) + + let is_top = mem UnknownThread + + let top () = singleton UnknownThread + + let merge uop cop x y = + match is_top x, is_top y with + | true, true -> uop x y + | false, true -> x + | true, false -> y + | false, false -> cop x y + + let meet x y = merge join meet x y + + let narrow x y = merge (fun x y -> widen x (join x y)) narrow x y + +end module MustThreadSet = SetDomain.Reverse(ThreadSet) module CreatedThreadSet = ThreadSet diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index ff6edf8bda..c0a8f2390f 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -279,13 +279,15 @@ struct let name () = "FlagConfiguredTID: " ^ if history_enabled () then H.name () else P.name () end -module Thread : Stateful = +type thread = + | Thread of FlagConfiguredTID.t + | UnknownThread +[@@deriving eq, ord, hash] + +module Thread : Stateful with type t = thread = struct include Printable.Std - type t = - | Thread of FlagConfiguredTID.t - | UnknownThread - [@@deriving eq, ord, hash] + type t = thread [@@deriving eq, ord, hash] let name () = "Thread id" let pretty () t = From 1221860befda16cbdf5c3ca3bc3e1d6a775dca46 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 27 Oct 2023 12:03:34 +0300 Subject: [PATCH 047/233] Add test for unknown thread id --- .../51-threadjoins/07-trivial-unknowntid.c | 34 +++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 tests/regression/51-threadjoins/07-trivial-unknowntid.c diff --git a/tests/regression/51-threadjoins/07-trivial-unknowntid.c b/tests/regression/51-threadjoins/07-trivial-unknowntid.c new file mode 100644 index 0000000000..2797291ee3 --- /dev/null +++ b/tests/regression/51-threadjoins/07-trivial-unknowntid.c @@ -0,0 +1,34 @@ +//PARAM: --set ana.activated[+] threadJoins +#include + +int g = 10; +int h = 10; +pthread_mutex_t A = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + g++; // RACE! + return NULL; +} + +void *t_benign(void *arg) { + h++; // NORACE + pthread_t id2; + pthread_create(&id2, NULL, t_fun, NULL); + foo(&id2); + pthread_join(id2, NULL); + return NULL; +} + +int main(void) { + int t; + + pthread_t id2; + pthread_create(&id2, NULL, t_benign, NULL); + pthread_join(id2, NULL); + // t_benign and t_fun should be in here + + g++; // RACE! + h++; // NORACE + + return 0; +} From 2df78822dc866fbb9bd26dbb6ccba893c280f114 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 27 Oct 2023 12:04:31 +0300 Subject: [PATCH 048/233] Fix unsoundness on unknown function call with tid as argument --- src/cdomains/valueDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index cba4b04c18..d3c8bc6989 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -708,7 +708,7 @@ struct let v = invalidate_value ask voidType (CArrays.get ask n (array_idx_top)) in Array (CArrays.set ask n (array_idx_top) v) | t , Blob n -> Blob (Blobs.invalidate_value ask t n) - | _ , Thread _ -> state (* TODO: no top thread ID set! *) + | _ , Thread tid -> Thread (Threads.join (Threads.top ()) tid) | _ , JmpBuf _ -> state (* TODO: no top jmpbuf *) | _, Bot -> Bot (* Leave uninitialized value (from malloc) alone in free to avoid trashing everything. TODO: sound? *) | t , _ -> top_value t From a401a68ee26c9d40ee7f2ec0e0a467c93211240a Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 27 Oct 2023 23:25:49 +0300 Subject: [PATCH 049/233] Replace exception handling with top checks --- src/analyses/apron/relationPriv.apron.ml | 22 +++++++++++----------- src/analyses/basePriv.ml | 22 +++++++++++----------- src/analyses/threadAnalysis.ml | 7 ++++--- src/analyses/threadJoins.ml | 4 ++-- 4 files changed, 28 insertions(+), 27 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index b386af162b..3adfa272bb 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -1011,17 +1011,17 @@ struct ) ) else ( - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st - | exception SetDomain.Unsupported _ -> - (* elements throws if the thread set is top *) - st + if ConcDomain.ThreadSet.is_top tids + then st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: relation_components_t) = diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 0154924a1c..ed6439a847 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -544,17 +544,17 @@ struct ) ) else ( - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st - | exception SetDomain.Unsupported _ -> - (* elements throws if the thread set is top *) - st + if (ConcDomain.ThreadSet.is_top tids) + then st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: BaseComponents (D).t) = diff --git a/src/analyses/threadAnalysis.ml b/src/analyses/threadAnalysis.ml index 1e679a4707..acc53d9dee 100644 --- a/src/analyses/threadAnalysis.ml +++ b/src/analyses/threadAnalysis.ml @@ -54,15 +54,16 @@ struct | ThreadJoin { thread = id; ret_var } -> (* TODO: generalize ThreadJoin like ThreadCreate *) (let has_clean_exit tid = not (BatTuple.Tuple3.third (ctx.global tid)) in + let tids = ctx.ask (Queries.EvalThread id) in let join_thread s tid = if has_clean_exit tid && not (is_not_unique ctx tid) then D.remove tid s else s in - match TS.elements (ctx.ask (Queries.EvalThread id)) with - | threads -> List.fold_left join_thread ctx.local threads - | exception SetDomain.Unsupported _ -> ctx.local) + if TS.is_top tids + then ctx.local + else List.fold_left join_thread ctx.local (TS.elements tids)) | _ -> ctx.local let query ctx (type a) (q: a Queries.t): a Queries.result = diff --git a/src/analyses/threadJoins.ml b/src/analyses/threadJoins.ml index f2cd36619f..2977ed9082 100644 --- a/src/analyses/threadJoins.ml +++ b/src/analyses/threadJoins.ml @@ -52,7 +52,7 @@ struct if TIDs.is_top threads then ctx.local else ( - (* elements throws if the thread set is top *) + (* all elements are known *) let threads = TIDs.elements threads in match threads with | [tid] when TID.is_unique tid-> @@ -70,7 +70,7 @@ struct (MustTIDs.bot(), true) (* consider everything joined, MustTIDs is reversed so bot is All threads *) ) else ( - (* elements throws if the thread set is top *) + (* all elements are known *) let threads = TIDs.elements threads in if List.compare_length_with threads 1 > 0 then M.info ~category:Unsound "Ambiguous thread ID assume-joined, assuming all of those threads must-joined."; From 4cb8c97c0d35b69dd6cf18452dff49e7453a2666 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Sun, 29 Oct 2023 20:15:50 +0200 Subject: [PATCH 050/233] Join threads with top when joining with int or address --- src/cdomains/valueDomain.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index d3c8bc6989..f5e9c45845 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -552,11 +552,9 @@ struct | y, Blob (x,s,o) -> Blob (join (x:t) y, s, o) | (Thread x, Thread y) -> Thread (Threads.join x y) | (Int x, Thread y) - | (Thread y, Int x) -> - Thread y (* TODO: ignores int! *) + | (Thread y, Int x) -> Thread (Threads.join y (Threads.top ())) | (Address x, Thread y) - | (Thread y, Address x) -> - Thread y (* TODO: ignores address! *) + | (Thread y, Address x) -> Thread (Threads.join y (Threads.top ())) | (JmpBuf x, JmpBuf y) -> JmpBuf (JmpBufs.join x y) | (Mutex, Mutex) -> Mutex | (MutexAttr x, MutexAttr y) -> MutexAttr (MutexAttr.join x y) From ae7a4061ffa1b120c20e3f641a637c197494cc12 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Sun, 29 Oct 2023 20:20:32 +0200 Subject: [PATCH 051/233] Implement widen for threads with int and address similarly to the Address and Int case --- src/cdomains/valueDomain.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index f5e9c45845..c8b3ac928e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -583,11 +583,9 @@ struct | (Blob x, Blob y) -> Blob (Blobs.widen x y) (* TODO: why no blob special cases like in join? *) | (Thread x, Thread y) -> Thread (Threads.widen x y) | (Int x, Thread y) - | (Thread y, Int x) -> - Thread y (* TODO: ignores int! *) + | (Thread y, Int x) -> Thread (Threads.widen y (Threads.join y (Threads.top ()))) | (Address x, Thread y) - | (Thread y, Address x) -> - Thread y (* TODO: ignores address! *) + | (Thread y, Address x) -> Thread (Threads.widen y (Threads.join y (Threads.top ()))) | (Mutex, Mutex) -> Mutex | (JmpBuf x, JmpBuf y) -> JmpBuf (JmpBufs.widen x y) | (MutexAttr x, MutexAttr y) -> MutexAttr (MutexAttr.widen x y) From 894e6189dfa5a27dbb0872d5feeae23e35568888 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Sun, 29 Oct 2023 21:20:47 +0200 Subject: [PATCH 052/233] Handle top thread when handling thread joins in base --- src/analyses/base.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6536a9c496..58ab2dc219 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2372,6 +2372,7 @@ struct | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) From 0f1389808ff3a848a9d6e6484df3f381860c7ddc Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 1 Nov 2023 17:14:03 +0200 Subject: [PATCH 053/233] Fix indentation --- src/analyses/apron/relationPriv.apron.ml | 22 +++++++++++----------- src/analyses/basePriv.ml | 22 +++++++++++----------- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index 3adfa272bb..2baf4cdca8 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -1011,17 +1011,17 @@ struct ) ) else ( - if ConcDomain.ThreadSet.is_top tids - then st - else - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st + if ConcDomain.ThreadSet.is_top tids then + st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: relation_components_t) = diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index ed6439a847..013a48a2d6 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -544,17 +544,17 @@ struct ) ) else ( - if (ConcDomain.ThreadSet.is_top tids) - then st - else - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st + if ConcDomain.ThreadSet.is_top tids then + st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: BaseComponents (D).t) = From e19f87e8c0647ebc84db6de4494d07c4817ab4c1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 21 Nov 2023 10:16:58 +0200 Subject: [PATCH 054/233] Add multiple as argument to threadenter in threadIdDomain --- src/cdomains/threadIdDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index a22b692921..d0c3f7b61b 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -342,9 +342,9 @@ struct module D = FlagConfiguredTID.D - let threadenter (t, d) node i v = + let threadenter ~multiple (t, d) node i v = match t with - | Thread tid -> List.map lift (FlagConfiguredTID.threadenter (tid, d) node i v) + | Thread tid -> List.map lift (FlagConfiguredTID.threadenter ~multiple (tid, d) node i v) | UnknownThread -> assert false let threadspawn = FlagConfiguredTID.threadspawn From 17ebe80cb217b8d6837f7b892fb75a3e11f0e3b0 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 09:29:30 +0100 Subject: [PATCH 055/233] Enable `mutex-meet-tid` for ValidDeref --- src/autoTune.ml | 6 +++++- .../74-invalid_deref/31-multithreaded.c | 21 +++++++++++++++++++ 2 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 tests/regression/74-invalid_deref/31-multithreaded.c diff --git a/src/autoTune.ml b/src/autoTune.ml index fefdeb32fd..dca3ee405a 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -222,7 +222,11 @@ let focusOnMemSafetySpecification (spec: Svcomp.Specification.t) = print_endline "Setting \"cil.addNestedScopeAttr\" to true"; set_bool "cil.addNestedScopeAttr" true; print_endline @@ "Specification: ValidDeref -> enabling memOutOfBounds analysis \"" ^ (String.concat ", " memOobAna) ^ "\""; - enableAnalyses memOobAna + enableAnalyses memOobAna; + (* Set privatization to mutex-meet-tid *) + set_string "ana.base.privatization" "mutex-meet-tid"; + (* Required for mutex-meet-tid privatization *) + GobConfig.set_auto "ana.path_sens[+]" "threadflag"; | ValidMemtrack | ValidMemcleanup -> (* Enable the memLeak analysis *) let memLeakAna = ["memLeak"] in diff --git a/tests/regression/74-invalid_deref/31-multithreaded.c b/tests/regression/74-invalid_deref/31-multithreaded.c new file mode 100644 index 0000000000..e0dc146ba8 --- /dev/null +++ b/tests/regression/74-invalid_deref/31-multithreaded.c @@ -0,0 +1,21 @@ +//PARAM: --set ana.activated[+] useAfterFree --set ana.activated[+] threadJoins --set ana.path_sens[+] threadflag --set ana.activated[+] memOutOfBounds --enable ana.int.interval --set ana.base.arrays.domain partitioned --set ana.base.privatization mutex-meet-tid +#include + +int data; +int *p = &data, *q; +pthread_mutex_t mutex; +void *t_fun(void *arg) { + pthread_mutex_lock(&mutex); + *p = 8; + pthread_mutex_unlock(&mutex); + return ((void *)0); +} +int main() { + pthread_t id; + pthread_create(&id, ((void *)0), t_fun, ((void *)0)); + q = p; + pthread_mutex_lock(&mutex); + *q = 8; + pthread_mutex_unlock(&mutex); + return 0; +} From c5cda332088a48507f44b3c93733c13539189e04 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 11:22:10 +0100 Subject: [PATCH 056/233] Move `AfterConfig.run` to after the autotuner --- src/analyses/base.ml | 8 +++++++- src/maingoblint.ml | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 84be8c7a19..518d4d88c6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1056,7 +1056,13 @@ struct ); (* Warn if any of the addresses contains a non-local and non-global variable *) if AD.exists (function - | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global a v) + | AD.Addr.Addr (v, _) -> + (M.tracel "wtf" "checking for %a\n" CilType.Varinfo.pretty v; + if v.vglob then + (* this is OK *) + false + else + (not (CPA.mem v st.cpa)) || WeakUpdates.mem v st.weak) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 82a19aa4ae..79b0d121f6 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -191,10 +191,10 @@ let handle_flags () = let handle_options () = check_arguments (); - AfterConfig.run (); Sys.set_signal (GobSys.signal_of_string (get_string "dbg.solver-signal")) Signal_ignore; (* Ignore solver-signal before solving (e.g. MyCFG), otherwise exceptions self-signal the default, which crashes instead of printing backtrace. *) if AutoTune.isActivated "memsafetySpecification" && get_string "ana.specification" <> "" then AutoTune.focusOnMemSafetySpecification (); + AfterConfig.run (); Cilfacade.init_options (); handle_flags () From 8ae117253f84b9b419d52a318af06dc7e4518475 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 11:53:08 +0100 Subject: [PATCH 057/233] Revert spurious changes to `base.ml` --- src/analyses/base.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 518d4d88c6..84be8c7a19 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1056,13 +1056,7 @@ struct ); (* Warn if any of the addresses contains a non-local and non-global variable *) if AD.exists (function - | AD.Addr.Addr (v, _) -> - (M.tracel "wtf" "checking for %a\n" CilType.Varinfo.pretty v; - if v.vglob then - (* this is OK *) - false - else - (not (CPA.mem v st.cpa)) || WeakUpdates.mem v st.weak) + | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global a v) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; From 06f543a0139b12366591f792642167e0e5ca2285 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 13:21:19 +0100 Subject: [PATCH 058/233] Undo setting mutex-meet-tid privatization in autotuner --- src/autoTune.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/autoTune.ml b/src/autoTune.ml index dca3ee405a..9627aed85f 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -223,10 +223,6 @@ let focusOnMemSafetySpecification (spec: Svcomp.Specification.t) = set_bool "cil.addNestedScopeAttr" true; print_endline @@ "Specification: ValidDeref -> enabling memOutOfBounds analysis \"" ^ (String.concat ", " memOobAna) ^ "\""; enableAnalyses memOobAna; - (* Set privatization to mutex-meet-tid *) - set_string "ana.base.privatization" "mutex-meet-tid"; - (* Required for mutex-meet-tid privatization *) - GobConfig.set_auto "ana.path_sens[+]" "threadflag"; | ValidMemtrack | ValidMemcleanup -> (* Enable the memLeak analysis *) let memLeakAna = ["memLeak"] in From c1cced80063009ea5549da7927338f0c12216579 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 20:56:40 +0100 Subject: [PATCH 059/233] Address requested changes to `invalidate_abstract_value` --- src/cdomains/valueDomain.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index b6fbfaf7dc..985d7cca8b 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -58,6 +58,7 @@ sig type origin include Lattice.S with type t = value * size * origin + val map: (value -> value) -> t -> t val value: t -> value val invalidate_value: VDQ.t -> typ -> t -> t end @@ -77,6 +78,7 @@ struct type size = Size.t type origin = ZeroInit.t + let map f (v, s, o) = f v, s, o let value (a, b, c) = a let relift (a, b, c) = Value.relift a, b, c let invalidate_value ask t (v, s, o) = Value.invalidate_value ask t v, s, o @@ -745,9 +747,9 @@ struct | Float f -> Float (FD.top_of (FD.get_fkind f)) | Address _ -> Address (AD.top_ptr) | Struct s -> Struct (Structs.map invalidate_abstract_value s) - | Union u -> Union (Unions.top ()) + | Union u -> Union (Unions.top ()) (* More precise invalidate does not make sense, as it is not clear which component is accessed. *) | Array a -> Array (CArrays.map invalidate_abstract_value a) - | Blob _ -> Blob (Blobs.top ()) + | Blob b -> Blob (Blobs.map invalidate_abstract_value b) | Thread _ -> Thread (Threads.top ()) | JmpBuf _ -> JmpBuf (JmpBufs.top ()) | Mutex -> Mutex From e54510811fb2ca73837a5e4168adac5fdc30f1eb Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 21:07:27 +0100 Subject: [PATCH 060/233] Simplify `substring_extraction` --- src/cdomains/arrayDomain.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 543ff2458a..d191562426 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1883,7 +1883,7 @@ struct type value = Val.t type ret = Null | NotNull | Top - type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + type substr = N.substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr let domain_of_t (t_f, _) = A.domain_of_t t_f @@ -1957,10 +1957,11 @@ struct (A.map Val.invalidate_abstract_value t_f1, N.string_concat t_n1 t_n2 n) else (A.map Val.invalidate_abstract_value t_f1, N.top ()) - let substring_extraction (_, t_n1) (_, t_n2) = match N.substring_extraction t_n1 t_n2 with - | IsNotSubstr when get_bool "ana.base.arrays.nullbytes" -> IsNotSubstr - | IsSubstrAtIndex0 when get_bool "ana.base.arrays.nullbytes" -> IsSubstrAtIndex0 - | _ -> IsMaybeSubstr + let substring_extraction (_, t_n1) (_, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + N.substring_extraction t_n1 t_n2 + else + IsMaybeSubstr let string_comparison (_, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then N.string_comparison t_n1 t_n2 n From 1343915c17b8fcd15fd1c781eba53af45436d098 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 21:17:03 +0100 Subject: [PATCH 061/233] Some simplifications --- src/cdomains/arrayDomain.ml | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d191562426..c20c85967e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1921,16 +1921,14 @@ struct (A.map f t_f, N.top ()) let fold_left f acc (t_f, _) = A.fold_left f acc t_f - let smart_join x y (t_f1, t_n1) (t_f2, t_n2) = + let smart_binop op_a op_n x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then - (A.smart_join x y t_f1 t_f2, N.smart_join x y t_n1 t_n2) + (op_a x y t_f1 t_f2, op_n x y t_n1 t_n2) else - (A.smart_join x y t_f1 t_f2, N.top ()) - let smart_widen x y (t_f1, t_n1) (t_f2, t_n2) = - if get_bool "ana.base.arrays.nullbytes" then - (A.smart_widen x y t_f1 t_f2, N.smart_widen x y t_n1 t_n2) - else - (A.smart_widen x y t_f1 t_f2, N.top ()) + (op_a x y t_f1 t_f2, N.top ()) + + let smart_join = smart_binop A.smart_join N.smart_join + let smart_widen = smart_binop A.smart_widen N.smart_widen let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then A.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 @@ -1947,16 +1945,18 @@ struct N.to_string_length t_n else Idx.top_of !Cil.kindOfSizeOf - let string_copy (t_f1, t_n1) (_, t_n2) n = - if get_bool "ana.base.arrays.nullbytes" then - (A.map Val.invalidate_abstract_value t_f1, N.string_copy t_n1 t_n2 n) - else - (A.map Val.invalidate_abstract_value t_f1, N.top ()) - let string_concat (t_f1, t_n1) (_, t_n2) n = + + (* invalidates the information in A, and applies op t_n1 t_n2 n *) + (* when ana.base.arrays.nullbytes is set *) + let string_op op (t_f1, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then - (A.map Val.invalidate_abstract_value t_f1, N.string_concat t_n1 t_n2 n) + (A.map Val.invalidate_abstract_value t_f1, op t_n1 t_n2 n) else (A.map Val.invalidate_abstract_value t_f1, N.top ()) + + let string_copy = string_op N.string_copy + let string_concat = string_op N.string_concat + let substring_extraction (_, t_n1) (_, t_n2) = if get_bool "ana.base.arrays.nullbytes" then N.substring_extraction t_n1 t_n2 From 5f622616ae767430516e6e5ac86ae45f6e7fb3e6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 22:14:10 +0100 Subject: [PATCH 062/233] Simplify `AttributeConfiguredAndNullByteArrayDomain` --- src/cdomains/arrayDomain.ml | 74 ++++++++++++++----------------------- 1 file changed, 28 insertions(+), 46 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index c20c85967e..166447ed1d 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1897,16 +1897,38 @@ struct | _ -> f_get else f_get - let set (ask:VDQ.t) (t_f, t_n) i v = + + let construct a n = if get_bool "ana.base.arrays.nullbytes" then - (A.set ask t_f i v, N.set ask t_n i v) + (a, n ()) else - (A.set ask t_f i v, N.top ()) - let make ?(varAttr=[]) ?(typAttr=[]) i v = + (a, N.top ()) + + let set (ask:VDQ.t) (t_f, t_n) i v = construct (A.set ask t_f i v) (fun () -> N.set ask t_n i v) + let make ?(varAttr=[]) ?(typAttr=[]) i v = construct (A.make ~varAttr ~typAttr i v) (fun () -> N.make ~varAttr ~typAttr i v) + let map f (t_f, t_n) = construct (A.map f t_f) (fun () -> N.map f t_n) + let update_length newl (t_f, t_n) = construct (A.update_length newl t_f) (fun () -> N.update_length newl t_n) + + let smart_binop op_a op_n x y (t_f1, t_n1) (t_f2, t_n2) = construct (op_a x y t_f1 t_f2) (fun () -> op_n x y t_n1 t_n2) + + let smart_join = smart_binop A.smart_join N.smart_join + let smart_widen = smart_binop A.smart_widen N.smart_widen + + let string_op op (t_f1, t_n1) (_, t_n2) n = construct (A.map Val.invalidate_abstract_value t_f1) (fun () -> op t_n1 t_n2 n) + let string_copy = string_op N.string_copy + let string_concat = string_op N.string_concat + + let extract op default (_, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then - (A.make ~varAttr ~typAttr i v, N.make i v) + op t_n1 t_n2 n else - (A.make ~varAttr ~typAttr i v, N.top ()) + (* Hidden behind unit, as constructing defaults may happen to early otherwise *) + (* e.g. for Idx.top_of IInt *) + default () + + let substring_extraction x y = extract (fun x y _ -> N.substring_extraction x y) (fun () -> IsMaybeSubstr) x y None + let string_comparison = extract N.string_comparison (fun () -> Idx.top_of IInt) + let length (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.length t_n @@ -1914,21 +1936,8 @@ struct A.length t_f let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (A.move_if_affected ~replace_with_const ask t_f v f, N.move_if_affected ~replace_with_const ask t_n v f) let get_vars_in_e (t_f, _) = A.get_vars_in_e t_f - let map f (t_f, t_n) = - if get_bool "ana.base.arrays.nullbytes" then - (A.map f t_f, N.map f t_n) - else - (A.map f t_f, N.top ()) let fold_left f acc (t_f, _) = A.fold_left f acc t_f - let smart_binop op_a op_n x y (t_f1, t_n1) (t_f2, t_n2) = - if get_bool "ana.base.arrays.nullbytes" then - (op_a x y t_f1 t_f2, op_n x y t_n1 t_n2) - else - (op_a x y t_f1 t_f2, N.top ()) - - let smart_join = smart_binop A.smart_join N.smart_join - let smart_widen = smart_binop A.smart_widen N.smart_widen let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then A.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 @@ -1946,33 +1955,6 @@ struct else Idx.top_of !Cil.kindOfSizeOf - (* invalidates the information in A, and applies op t_n1 t_n2 n *) - (* when ana.base.arrays.nullbytes is set *) - let string_op op (t_f1, t_n1) (_, t_n2) n = - if get_bool "ana.base.arrays.nullbytes" then - (A.map Val.invalidate_abstract_value t_f1, op t_n1 t_n2 n) - else - (A.map Val.invalidate_abstract_value t_f1, N.top ()) - - let string_copy = string_op N.string_copy - let string_concat = string_op N.string_concat - - let substring_extraction (_, t_n1) (_, t_n2) = - if get_bool "ana.base.arrays.nullbytes" then - N.substring_extraction t_n1 t_n2 - else - IsMaybeSubstr - let string_comparison (_, t_n1) (_, t_n2) n = - if get_bool "ana.base.arrays.nullbytes" then - N.string_comparison t_n1 t_n2 n - else - Idx.top_of IInt - - let update_length newl (t_f, t_n) = - if get_bool "ana.base.arrays.nullbytes" then - (A.update_length newl t_f, N.update_length newl t_n) - else - (A.update_length newl t_f, N.top ()) let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (A.project ~varAttr ~typAttr ask t_f, N.project ~varAttr ~typAttr ask t_n) let invariant ~value_invariant ~offset ~lval (t_f, _) = A.invariant ~value_invariant ~offset ~lval t_f end From a50b1b86ec1aed6a37b1e6093efb00f5d271e796 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 22:47:47 +0100 Subject: [PATCH 063/233] Steps towards simplifications --- src/cdomains/arrayDomain.ml | 147 +++++++++++------------------------- src/cdomains/nullByteSet.ml | 65 ++++++++++++++++ 2 files changed, 109 insertions(+), 103 deletions(-) create mode 100644 src/cdomains/nullByteSet.ml diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 166447ed1d..bb304af85e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -998,55 +998,8 @@ end module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = struct - module MustSet = struct - module M = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) - include M - - let compute_set len = - List.init (Z.to_int len) Z.of_int - |> of_list - - let remove i must_nulls_set min_size = - if M.is_bot must_nulls_set then - M.remove i (compute_set min_size) - else - M.remove i must_nulls_set - - let filter cond must_nulls_set min_size = - if M.is_bot must_nulls_set then - M.filter cond (compute_set min_size) - else - M.filter cond must_nulls_set - - let min_elt must_nulls_set = - if M.is_bot must_nulls_set then - Z.zero - else - M.min_elt must_nulls_set - end - - module MaySet = struct - module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) - include M - - let remove i may_nulls_set max_size = - if M.is_top may_nulls_set then - M.remove i (MustSet.compute_set max_size) - else - M.remove i may_nulls_set - - let filter cond may_nulls_set max_size = - if M.is_top may_nulls_set then - M.filter cond (MustSet.compute_set max_size) - else - M.filter cond may_nulls_set - - let min_elt may_nulls_set = - if M.is_top may_nulls_set then - Z.zero - else - M.min_elt may_nulls_set - end + module MustSet = NullByteSet.MustSet + module MaySet = NullByteSet.MaySet (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod3 (MustSet) (MaySet) (Idx) @@ -1058,26 +1011,14 @@ struct type ret = Null | NotNull | Top type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds + (* helper: returns Idx.maximal except for Overflows that are mapped to None *) let idx_maximal i = match Idx.maximal i with | Some i when Z.fits_int i -> Some i | _ -> None let get (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = - let all_indexes_must_null i max = - if MustSet.is_bot must_nulls_set then - true - else if Z.lt (Z.of_int (MustSet.cardinal must_nulls_set)) (Z.sub max i) then - false - else - let rec check_all_indexes i = - if Z.gt i max then - true - else if MustSet.mem i must_nulls_set then - check_all_indexes (Z.succ i) - else - false in - check_all_indexes i in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1098,7 +1039,7 @@ struct (* if there is no maximum size *) | Some max_i, None when Z.geq max_i Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && all_indexes_must_null min_i max_i then + if Z.lt max_i min_size && MustSet.interval_mem (min_i,max_i) must_nulls_set then Null (* ... return NotNull if no number in index interval is in may_nulls_set *) else if not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then @@ -1107,7 +1048,7 @@ struct Top | Some max_i, Some max_size when Z.geq max_i Z.zero -> (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && all_indexes_must_null min_i max_i then + if Z.lt max_i min_size && MustSet.interval_mem (min_i,max_i) must_nulls_set then Null (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) else if Z.lt max_i max_size && not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then @@ -1232,22 +1173,22 @@ struct let min_i, max_i = match Idx.minimal i, idx_maximal i with | Some min_i, Some max_i -> if Z.lt min_i Z.zero && Z.lt max_i Z.zero then - (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; + (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) else if Z.lt min_i Z.zero then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; + (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; Z.zero, Some max_i) else min_i, Some max_i | None, Some max_i -> if Z.lt max_i Z.zero then - (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Tries to create an array of negative size"; + (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) else Z.zero, Some max_i | Some min_i, None -> if Z.lt min_i Z.zero then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May try to create an array of negative size"; + (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; Z.zero, None) else min_i, None @@ -1302,11 +1243,11 @@ struct let to_string (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then - (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array access past end: buffer overflow"; + (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; (must_nulls_set, may_nulls_set, size)) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) else if MustSet.is_empty must_nulls_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end: potential buffer overflow"; + (M.warn ~category:ArrayOobMessage.past_end "May access array past end: potential buffer overflow"; (must_nulls_set, may_nulls_set, size)) else let min_must_null = MustSet.min_elt must_nulls_set in @@ -1363,20 +1304,20 @@ struct ((match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> if Z.gt (Z.of_int n) max_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" else if Z.gt (Z.of_int n) min_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | Some min_size, None -> if Z.gt (Z.of_int n) min_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | None, Some max_size -> if Z.gt (Z.of_int n) max_size then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" | None, None -> ()); (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + (M.warn ~category:ArrayOobMessage.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) @@ -1402,13 +1343,13 @@ struct let to_string_length (must_nulls_set, may_nulls_set, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then - (M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array doesn't contain a null byte: buffer overflow"; + (M.error ~category:ArrayOobMessage.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if MustSet.is_empty must_nulls_set then - (M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array might not contain a null byte: potential buffer overflow"; + (M.warn ~category:ArrayOobMessage.past_end "Array might not contain a null byte: potential buffer overflow"; Idx.starting !Cil.kindOfSizeOf (MaySet.min_elt may_nulls_set)) (* else return interval [minimal may null, minimal must null] *) else @@ -1420,9 +1361,9 @@ struct match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> (if Z.lt max_size1 min_len2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + M.error ~category:ArrayOobMessage.past_end "The length of string src is greater than the allocated size for dest" else if Z.lt min_size1 max_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 @@ -1442,7 +1383,7 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with | Some min_size2 -> min_size2 @@ -1456,9 +1397,9 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src is greater than the allocated size for dest" + M.error ~category:ArrayOobMessage.past_end "The length of string src is greater than the allocated size for dest" else if Z.lt min_size1 min_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with @@ -1474,7 +1415,7 @@ struct (must_nulls_set_result, may_nulls_set_result, size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The length of string src may be greater than the allocated size for dest"); + M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = match Idx.minimal size2' with @@ -1494,23 +1435,23 @@ struct (match Idx.minimal size1, idx_maximal size1, Idx.minimal size2, idx_maximal size2 with | Some min_size1, _, Some min_size2, _ when Z.lt min_size1 min_size2 -> if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + M.error ~category:ArrayOobMessage.past_end "src doesn't contain a null byte at an index smaller than the size of dest" else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" | Some min_size1, _, _, Some max_size2 when Z.lt min_size1 max_size2 -> if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + M.error ~category:ArrayOobMessage.past_end "src doesn't contain a null byte at an index smaller than the size of dest" else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" | Some min_size1, _, _, None -> if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" | _, Some max_size1, _, Some max_size2 when Z.lt max_size1 max_size2 -> if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" |_, Some max_size1, _, None -> if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "src may not contain a null byte at an index smaller than the size of dest" + M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" | _ -> ()) in match n with @@ -1531,10 +1472,10 @@ struct let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + M.error ~category:ArrayOobMessage.past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" else if (maxlen1_exists && maxlen2_exists && Z.leq min_size1 (Z.add maxlen1 maxlen2)) || not maxlen1_exists || not maxlen2_exists then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end + M.warn ~category:ArrayOobMessage.past_end "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set @@ -1702,13 +1643,13 @@ struct | None -> (* track any potential buffer overflow and issue warning if needed *) (if MustSet.is_empty must_nulls_set1 && MaySet.is_empty may_nulls_set1 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" + M.error ~category:ArrayOobMessage.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" else if MustSet.is_empty must_nulls_set1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); + M.warn ~category:ArrayOobMessage.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); (if MustSet.is_empty must_nulls_set2 && MaySet.is_empty may_nulls_set2 then - M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" + M.error ~category:ArrayOobMessage.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" else if MustSet.is_empty must_nulls_set2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); + M.warn ~category:ArrayOobMessage.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); (* compute abstract value for result of strcmp *) compare Z.zero false (* strncmp *) @@ -1723,21 +1664,21 @@ struct (match idx_maximal size1 with | Some max_size1 -> if Z.gt (Z.of_int n) max_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 is smaller than n bytes" + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 is smaller than n bytes" else if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes" + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes" | None -> if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 1 might be smaller than n bytes"); + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes"); (match idx_maximal size2 with | Some max_size2 -> if Z.gt (Z.of_int n) max_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 is smaller than n bytes" + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 is smaller than n bytes" else if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes" + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 might be smaller than n bytes" | None -> if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "The size of the array of string 2 might be smaller than n bytes"); + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 might be smaller than n bytes"); (* compute abstract value for result of strncmp *) compare (Z.of_int n) true | _ -> Idx.top_of IInt diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml new file mode 100644 index 0000000000..5977023b8e --- /dev/null +++ b/src/cdomains/nullByteSet.ml @@ -0,0 +1,65 @@ +module MustSet = struct + module M = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) + include M + + let compute_set len = + List.init (Z.to_int len) Z.of_int + |> of_list + + let remove i must_nulls_set min_size = + if M.is_bot must_nulls_set then + M.remove i (compute_set min_size) + else + M.remove i must_nulls_set + + let filter cond must_nulls_set min_size = + if M.is_bot must_nulls_set then + M.filter cond (compute_set min_size) + else + M.filter cond must_nulls_set + + let min_elt must_nulls_set = + if M.is_bot must_nulls_set then + Z.zero + else + M.min_elt must_nulls_set + + + let interval_mem (l,u) set = + if M.is_bot set then + true + else if Z.lt (Z.of_int (M.cardinal set)) (Z.sub u l) then + false + else + let rec check_all_indexes i = + if Z.gt i u then + true + else if M.mem i set then + check_all_indexes (Z.succ i) + else + false in + check_all_indexes l +end + +module MaySet = struct + module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) + include M + + let remove i may_nulls_set max_size = + if M.is_top may_nulls_set then + M.remove i (MustSet.compute_set max_size) + else + M.remove i may_nulls_set + + let filter cond may_nulls_set max_size = + if M.is_top may_nulls_set then + M.filter cond (MustSet.compute_set max_size) + else + M.filter cond may_nulls_set + + let min_elt may_nulls_set = + if M.is_top may_nulls_set then + Z.zero + else + M.min_elt may_nulls_set +end From 86b7c35bb981b5b7264ade4ef0073b226518b8fc Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 23:54:16 +0100 Subject: [PATCH 064/233] Attempts towards simplification --- src/cdomains/arrayDomain.ml | 89 ++++++++++++++++++++++--------------- src/cdomains/nullByteSet.ml | 32 ++++++++++++- 2 files changed, 84 insertions(+), 37 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index bb304af85e..741207c9e4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1000,6 +1000,7 @@ module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = struct module MustSet = NullByteSet.MustSet module MaySet = NullByteSet.MaySet + module Nulls = NullByteSet.MustMaySet (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod3 (MustSet) (MaySet) (Idx) @@ -1019,6 +1020,7 @@ struct | _ -> None let get (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = + let nulls = (must_nulls_set, may_nulls_set) in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1031,7 +1033,7 @@ struct (* if there is no maximum value in index interval *) | None, _ -> (* ... return NotNull if no i >= min_i in may_nulls_set *) - if not (MaySet.exists (Z.leq min_i) may_nulls_set) then + if not (Nulls.may_exist (Z.leq min_i) nulls) then NotNull (* ... else return Top *) else @@ -1039,26 +1041,29 @@ struct (* if there is no maximum size *) | Some max_i, None when Z.geq max_i Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && MustSet.interval_mem (min_i,max_i) must_nulls_set then + if Z.lt max_i min_size && Nulls.must_mem_interval (min_i,max_i) nulls then Null (* ... return NotNull if no number in index interval is in may_nulls_set *) - else if not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + else if not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then NotNull else Top | Some max_i, Some max_size when Z.geq max_i Z.zero -> (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && MustSet.interval_mem (min_i,max_i) must_nulls_set then + if Z.lt max_i min_size && Nulls.must_mem_interval (min_i, max_i) nulls then Null (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) - else if Z.lt max_i max_size && not (MaySet.exists (fun x -> Z.geq x min_i && Z.leq x max_i) may_nulls_set) then + else if Z.lt max_i max_size && not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then NotNull else Top (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top - let set (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) v = + let uf ((a,b),c) = (a,b,c) + + let set (ask: VDQ.t) ((must_nulls_set, may_nulls_set, size) as x) (e, i) v = + let nulls = (must_nulls_set, may_nulls_set) in let rec add_indexes i max may_nulls_set = if Z.gt i max then may_nulls_set @@ -1144,30 +1149,37 @@ struct (if Val.is_null v && idx_maximal size = None then match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> (must_nulls_set, MaySet.top (), size) + | None -> uf @@ (Nulls.forget_may nulls, size) (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set, size) + | Some max_size -> uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else if Val.is_not_null v then - (MustSet.filter (Z.gt min_i) must_nulls_set min_size, may_nulls_set, size) + uf @@ (Nulls.filter_musts (Z.gt min_i) min_size nulls, size) (*..., value unknown *) else match Idx.minimal size, idx_maximal size with (* ... and size unknown, modify both sets to top *) - | None, None -> (MustSet.top (), MaySet.top (), size) + | None, None -> uf @@ (Nulls.top (), size) (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) - | Some min_size, None -> (MustSet.filter (Z.gt min_size) must_nulls_set min_size, MaySet.top (), size) + | Some min_size, None -> + let nulls = Nulls.forget_may nulls in + uf @@ (Nulls.filter_musts (Z.gt min_size) min_size nulls, size) (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) - | None, Some max_size -> (MustSet.top (), add_indexes min_i (Z.pred max_size) may_nulls_set, size) + | None, Some max_size -> + let nulls = Nulls.forget_must nulls in + uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) - | Some min_size, Some max_size -> (MustSet.filter (Z.gt min_size) must_nulls_set min_size, add_indexes min_i (Z.pred max_size) may_nulls_set, size)) + | Some min_size, Some max_size -> + let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in + uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) + ) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then set_exact min_i else (set_interval_must min_i max_i, set_interval_may min_i max_i, size) (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) - | _ -> (must_nulls_set, may_nulls_set, size) + | _ -> x let make ?(varAttr=[]) ?(typAttr=[]) i v = let min_i, max_i = match Idx.minimal i, idx_maximal i with @@ -1240,20 +1252,21 @@ struct (set, set, Idx.of_int ILong (Z.succ last_null)) (** Returns an abstract value with at most one null byte marking the end of the string *) - let to_string (must_nulls_set, may_nulls_set, size) = + let to_string ((must_nulls_set, may_nulls_set, size) as x) = + let nulls = (must_nulls_set, may_nulls_set) in (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) - if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then - (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; - (must_nulls_set, may_nulls_set, size)) + if Nulls.must_be_empty nulls then + (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; x) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) - else if MustSet.is_empty must_nulls_set then - (M.warn ~category:ArrayOobMessage.past_end "May access array past end: potential buffer overflow"; - (must_nulls_set, may_nulls_set, size)) + else if Nulls.may_be_empty nulls then + (M.warn ~category:ArrayOobMessage.past_end "May access array past end: potential buffer overflow"; x) else - let min_must_null = MustSet.min_elt must_nulls_set in + let min_must_null = Nulls.min_must_elem nulls in + let min_may_null = Nulls.min_may_elem nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - if Z.equal min_must_null (MaySet.min_elt may_nulls_set) then - (MustSet.singleton min_must_null, MaySet.singleton min_must_null, Idx.of_int ILong (Z.succ min_must_null)) + if Z.equal min_must_null min_may_null then + let (must,may) = Nulls.precise_singleton min_must_null in + (must, may, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with @@ -1273,6 +1286,7 @@ struct * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) let to_n_string (must_nulls_set, may_nulls_set, size) n = + let nulls = (must_nulls_set, may_nulls_set) in let rec add_indexes i max set = if Z.geq i max then set @@ -1316,7 +1330,7 @@ struct | None, None -> ()); (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) - if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then + if Nulls.must_be_empty nulls then (M.warn ~category:ArrayOobMessage.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with @@ -1325,13 +1339,13 @@ struct | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) - else if MustSet.is_empty must_nulls_set then - let min_may_null = MaySet.min_elt may_nulls_set in + else if Nulls.may_be_empty nulls then + let min_may_null = Nulls.min_may_elem nulls in warn_no_null Z.zero false min_may_null; (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else - let min_must_null = MustSet.min_elt must_nulls_set in - let min_may_null = MaySet.min_elt may_nulls_set in + let min_must_null = Nulls.min_must_elem nulls in + let min_may_null = Nulls.min_may_elem nulls in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) @@ -1341,19 +1355,21 @@ struct (MustSet.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) let to_string_length (must_nulls_set, may_nulls_set, size) = + let nulls = (must_nulls_set, may_nulls_set) in (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) - if MustSet.is_empty must_nulls_set && MaySet.is_empty may_nulls_set then + (* TODO: check of must set really needed? *) + if Nulls.must_be_empty nulls then (M.error ~category:ArrayOobMessage.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) - else if MustSet.is_empty must_nulls_set then + else if Nulls.may_be_empty nulls then (M.warn ~category:ArrayOobMessage.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting !Cil.kindOfSizeOf (MaySet.min_elt may_nulls_set)) + Idx.starting !Cil.kindOfSizeOf (Nulls.min_may_elem nulls)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (MaySet.min_elt may_nulls_set, MustSet.min_elt must_nulls_set) + Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_may_elem nulls, Nulls.min_must_elem nulls) let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) @@ -1599,13 +1615,14 @@ struct compute_concat must_nulls_set2' may_nulls_set2' | _ -> (MustSet.top (), MaySet.top (), size1) - let substring_extraction haystack (must_nulls_set_needle, may_nulls_set_needle, size_needle) = + let substring_extraction haystack ((must_needle, may_needle, size_needle) as needle) = + let nulls_needle = (must_needle, may_needle) in (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) - if MustSet.mem Z.zero must_nulls_set_needle then + if Nulls.must_mem Z.zero nulls_needle then IsSubstrAtIndex0 else let haystack_len = to_string_length haystack in - let needle_len = to_string_length (must_nulls_set_needle, may_nulls_set_needle, size_needle) in + let needle_len = to_string_length needle in match idx_maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 5977023b8e..3fc3889ffc 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -24,7 +24,6 @@ module MustSet = struct else M.min_elt must_nulls_set - let interval_mem (l,u) set = if M.is_bot set then true @@ -63,3 +62,34 @@ module MaySet = struct else M.min_elt may_nulls_set end + +module MustMaySet = struct + include Lattice.Prod (MustSet) (MaySet) + + let must_mem i (musts, mays) = MustSet.mem i musts + let must_mem_interval (l,u) (musts, mays) = MustSet.interval_mem (l,u) musts + + let may_be_empty (musts, mays) = MustSet.is_empty musts + let must_be_empty (musts, mays) = MaySet.is_empty mays + + let min_may_elem (musts, mays) = MaySet.min_elt mays + let min_must_elem (musts, mays) = MustSet.min_elt musts + + let add_may_interval (l,u) (musts, mays) = + let rec add_indexes i max set = + if Z.gt i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) + in + (musts, add_indexes l u mays) + + let precise_singleton i = + (MustSet.singleton i, MaySet.singleton i) + + let may_exist f (musts, mays) = MaySet.exists f mays + + let forget_may (musts, mays) = (musts, MaySet.top ()) + let forget_must (musts, mays) = (MustSet.top (), mays) + let filter_musts f min_size (musts, mays) = (MustSet.filter f musts min_size, mays) +end \ No newline at end of file From a354e63052d0b80d37ff5cb29b953348411e5097 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 23:57:19 +0100 Subject: [PATCH 065/233] Simplify --- src/cdomains/arrayDomain.ml | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 741207c9e4..9b890980bf 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1600,17 +1600,11 @@ struct if not (MaySet.exists (Z.gt (Z.of_int n)) may_nulls_set2) then (MustSet.singleton (Z.of_int n), MaySet.singleton (Z.of_int n)) else if not (MustSet.exists (Z.gt (Z.of_int n)) must_nulls_set2) then - let max_size2 = match idx_maximal size2 with - | Some max_size2 -> max_size2 - | None -> Z.succ (Z.of_int n) in + let max_size2 = BatOption.default (Z.succ (Z.of_int n)) (idx_maximal size2) in (MustSet.empty (), MaySet.add (Z.of_int n) (MaySet.filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) else - let min_size2 = match Idx.minimal size2 with - | Some min_size2 -> min_size2 - | None -> Z.zero in - let max_size2 = match idx_maximal size2 with - | Some max_size2 -> max_size2 - | None -> Z.of_int n in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in + let max_size2 = BatOption.default (Z.of_int n) (idx_maximal size2) in (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in compute_concat must_nulls_set2' may_nulls_set2' | _ -> (MustSet.top (), MaySet.top (), size1) From 8933c0a0a31616232934dcd289889a6f2f46cd06 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 12:58:59 +0100 Subject: [PATCH 066/233] Simplify --- src/cdomains/arrayDomain.ml | 32 ++++++++++++++++---------------- src/cdomains/nullByteSet.ml | 29 +++++++++++++++++++++-------- 2 files changed, 37 insertions(+), 24 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 9b890980bf..02f9fe8d31 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1041,7 +1041,7 @@ struct (* if there is no maximum size *) | Some max_i, None when Z.geq max_i Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && Nulls.must_mem_interval (min_i,max_i) nulls then + if Z.lt max_i min_size && Nulls.interval_mem Definitely (min_i,max_i) nulls then Null (* ... return NotNull if no number in index interval is in may_nulls_set *) else if not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then @@ -1050,7 +1050,7 @@ struct Top | Some max_i, Some max_size when Z.geq max_i Z.zero -> (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && Nulls.must_mem_interval (min_i, max_i) nulls then + if Z.lt max_i min_size && Nulls.interval_mem Definitely (min_i, max_i) nulls then Null (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) else if Z.lt max_i max_size && not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then @@ -1255,14 +1255,14 @@ struct let to_string ((must_nulls_set, may_nulls_set, size) as x) = let nulls = (must_nulls_set, may_nulls_set) in (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) - if Nulls.must_be_empty nulls then + if Nulls.is_empty Definitely nulls then (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; x) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) - else if Nulls.may_be_empty nulls then + else if Nulls.is_empty Possibly nulls then (M.warn ~category:ArrayOobMessage.past_end "May access array past end: potential buffer overflow"; x) else - let min_must_null = Nulls.min_must_elem nulls in - let min_may_null = Nulls.min_may_elem nulls in + let min_must_null = Nulls.min_elem Definitely nulls in + let min_may_null = Nulls.min_elem Possibly nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) if Z.equal min_must_null min_may_null then let (must,may) = Nulls.precise_singleton min_must_null in @@ -1330,7 +1330,7 @@ struct | None, None -> ()); (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) - if Nulls.must_be_empty nulls then + if Nulls.is_empty Definitely nulls then (M.warn ~category:ArrayOobMessage.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with @@ -1339,13 +1339,13 @@ struct | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) - else if Nulls.may_be_empty nulls then - let min_may_null = Nulls.min_may_elem nulls in + else if Nulls.is_empty Possibly nulls then + let min_may_null = Nulls.min_elem Possibly nulls in warn_no_null Z.zero false min_may_null; (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) else - let min_must_null = Nulls.min_must_elem nulls in - let min_may_null = Nulls.min_may_elem nulls in + let min_must_null = Nulls.min_elem Definitely nulls in + let min_may_null = Nulls.min_elem Possibly nulls in (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) @@ -1358,18 +1358,18 @@ struct let nulls = (must_nulls_set, may_nulls_set) in (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) (* TODO: check of must set really needed? *) - if Nulls.must_be_empty nulls then + if Nulls.is_empty Definitely nulls then (M.error ~category:ArrayOobMessage.past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) - else if Nulls.may_be_empty nulls then + else if Nulls.is_empty Possibly nulls then (M.warn ~category:ArrayOobMessage.past_end "Array might not contain a null byte: potential buffer overflow"; - Idx.starting !Cil.kindOfSizeOf (Nulls.min_may_elem nulls)) + Idx.starting !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls)) (* else return interval [minimal may null, minimal must null] *) else - Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_may_elem nulls, Nulls.min_must_elem nulls) + Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) @@ -1612,7 +1612,7 @@ struct let substring_extraction haystack ((must_needle, may_needle, size_needle) as needle) = let nulls_needle = (must_needle, may_needle) in (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) - if Nulls.must_mem Z.zero nulls_needle then + if Nulls.mem Definitely Z.zero nulls_needle then IsSubstrAtIndex0 else let haystack_len = to_string_length haystack in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 3fc3889ffc..ea8f963ab0 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -66,14 +66,27 @@ end module MustMaySet = struct include Lattice.Prod (MustSet) (MaySet) - let must_mem i (musts, mays) = MustSet.mem i musts - let must_mem_interval (l,u) (musts, mays) = MustSet.interval_mem (l,u) musts - - let may_be_empty (musts, mays) = MustSet.is_empty musts - let must_be_empty (musts, mays) = MaySet.is_empty mays - - let min_may_elem (musts, mays) = MaySet.min_elt mays - let min_must_elem (musts, mays) = MustSet.min_elt musts + type mode = Definitely | Possibly + + let is_empty mode (musts, mays) = + match mode with + | Definitely -> MaySet.is_empty mays + | Possibly -> MustSet.is_empty musts + + let min_elem mode (musts, mays) = + match mode with + | Definitely -> MustSet.min_elt musts + | Possibly -> MaySet.min_elt mays + + let mem mode i (musts, mays) = + match mode with + | Definitely -> MustSet.mem i musts + | Possibly -> MaySet.mem i mays + + let interval_mem mode (l,u) (musts, mays) = + match mode with + | Definitely -> MustSet.interval_mem (l,u) musts + | Possibly -> failwith "not implemented" let add_may_interval (l,u) (musts, mays) = let rec add_indexes i max set = From 09c069d7168968b412bd1cbc3ac80643b67b52e8 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 13:17:57 +0100 Subject: [PATCH 067/233] Simplify --- src/cdomains/arrayDomain.ml | 51 ++++++++++++++++++++----------------- src/cdomains/nullByteSet.ml | 10 ++++++++ 2 files changed, 38 insertions(+), 23 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 02f9fe8d31..cfcc702bb4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1077,40 +1077,42 @@ struct let min_i = min i in let max_i = idx_maximal i in - let set_exact i = + let set_exact_nulls i = match idx_maximal size with (* if size has no upper limit *) | None -> (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) if Val.is_not_null v && not (MaySet.is_top may_nulls_set) then - (MustSet.remove i must_nulls_set min_size, MaySet.M.remove i may_nulls_set, size) + Nulls.remove Definitely i nulls min_size else if Val.is_not_null v then - (MustSet.remove i must_nulls_set min_size, may_nulls_set, size) + Nulls.remove Possibly i nulls min_size (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) else if Z.lt i min_size && Val.is_null v then - (MustSet.add i must_nulls_set, MaySet.add i may_nulls_set, size) + Nulls.add Definitely i nulls (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) else if Val.is_null v then - (must_nulls_set, MaySet.add i may_nulls_set, size) + Nulls.add Possibly i nulls (* ... and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else - (MustSet.remove i must_nulls_set min_size, MaySet.add i may_nulls_set, size) + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed | Some max_size -> (* if value <> null, remove i from must_nulls_set and may_nulls_set *) if Val.is_not_null v then - (MustSet.remove i must_nulls_set min_size, MaySet.remove i may_nulls_set max_size, size) + Nulls.remove Definitely i nulls min_size (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) else if Z.lt i min_size && Val.is_null v then - (MustSet.add i must_nulls_set, MaySet.add i may_nulls_set, size) + Nulls.add Definitely i nulls (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) else if Z.lt i max_size && Val.is_null v then - (must_nulls_set, MaySet.add i may_nulls_set, size) + Nulls.add Possibly i nulls (* if i < maximal size and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else if Z.lt i max_size then - (MustSet.remove i must_nulls_set min_size, MaySet.add i may_nulls_set, size) - (* if i >= maximal size, return tuple unmodified *) + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed else - (must_nulls_set, may_nulls_set, size) in + nulls + in let set_interval_must min_i max_i = (* if value = null, return must_nulls_set unmodified as not clear which index is set to null *) @@ -1142,44 +1144,47 @@ struct (* warn if index is (potentially) out of bounds *) array_oob_check (module Idx) (must_nulls_set, size) (e, i); - match max_i with + let nulls = match max_i with (* if no maximum number in index interval *) | None -> (* ..., value = null *) (if Val.is_null v && idx_maximal size = None then match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> uf @@ (Nulls.forget_may nulls, size) + | None -> Nulls.forget_may nulls (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) + | Some max_size -> Nulls.add_may_interval (min_i, Z.pred max_size) nulls (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else if Val.is_not_null v then - uf @@ (Nulls.filter_musts (Z.gt min_i) min_size nulls, size) + Nulls.filter_musts (Z.gt min_i) min_size nulls (*..., value unknown *) else match Idx.minimal size, idx_maximal size with (* ... and size unknown, modify both sets to top *) - | None, None -> uf @@ (Nulls.top (), size) + | None, None -> Nulls.top () (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) | Some min_size, None -> let nulls = Nulls.forget_may nulls in - uf @@ (Nulls.filter_musts (Z.gt min_size) min_size nulls, size) + Nulls.filter_musts (Z.gt min_size) min_size nulls (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) | None, Some max_size -> let nulls = Nulls.forget_must nulls in - uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) + Nulls.add_may_interval (min_i, Z.pred max_size) nulls (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) | Some min_size, Some max_size -> let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in - uf @@ (Nulls.add_may_interval (min_i, Z.pred max_size) nulls, size) + Nulls.add_may_interval (min_i, Z.pred max_size) nulls ) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then - set_exact min_i + set_exact_nulls min_i else - (set_interval_must min_i max_i, set_interval_may min_i max_i, size) + (set_interval_must min_i max_i, set_interval_may min_i max_i) (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) - | _ -> x + | _ -> nulls + in + uf @@ (nulls, size) + let make ?(varAttr=[]) ?(typAttr=[]) i v = let min_i, max_i = match Idx.minimal i, idx_maximal i with diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index ea8f963ab0..a21a4cb066 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -88,6 +88,16 @@ module MustMaySet = struct | Definitely -> MustSet.interval_mem (l,u) musts | Possibly -> failwith "not implemented" + let remove mode i (musts, mays) min_size = + match mode with + | Definitely -> (MustSet.remove i musts min_size, MaySet.remove i mays min_size) + | Possibly -> (MustSet.remove i musts min_size, mays) + + let add mode i (musts, mays) = + match mode with + | Definitely -> (MustSet.add i musts, MaySet.add i mays) + | Possibly -> (musts, MaySet.add i mays) + let add_may_interval (l,u) (musts, mays) = let rec add_indexes i max set = if Z.gt i max then From f8ee3d2738c2c0d4f407e832f14d2e2d6b12f81f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 13:31:03 +0100 Subject: [PATCH 068/233] simplify --- src/cdomains/arrayDomain.ml | 19 ++++++++++++++++++- src/cdomains/nullByteSet.ml | 12 ++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index cfcc702bb4..d462aca666 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1142,6 +1142,23 @@ struct else add_indexes min_i max_i may_nulls_set in + let set_interval min_i max_i = + if Val.is_null v then + match idx_maximal size with + (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) + | None -> Nulls.add_interval Possibly (min_i, max_i) nulls + | Some max_size -> + (* ... add all indexes < maximal size to may_nulls_set *) + if Z.equal min_i Z.zero && Z.geq max_i max_size then + (must_nulls_set, MaySet.top ()) + else if Z.geq max_i max_size then + (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set) + else + Nulls.add_interval Possibly (min_i, max_i) nulls + else + (set_interval_must min_i max_i, set_interval_may min_i max_i) + in + (* warn if index is (potentially) out of bounds *) array_oob_check (module Idx) (must_nulls_set, size) (e, i); let nulls = match max_i with @@ -1179,7 +1196,7 @@ struct if Z.equal min_i max_i then set_exact_nulls min_i else - (set_interval_must min_i max_i, set_interval_may min_i max_i) + set_interval min_i max_i (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) | _ -> nulls in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index a21a4cb066..cdeb481b07 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -98,6 +98,18 @@ module MustMaySet = struct | Definitely -> (MustSet.add i musts, MaySet.add i mays) | Possibly -> (musts, MaySet.add i mays) + let add_interval mode (l,u) (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> + let rec add_indexes i max set = + if Z.gt i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) + in + (musts, add_indexes l u mays) + let add_may_interval (l,u) (musts, mays) = let rec add_indexes i max set = if Z.gt i max then From 81c8b63d5698f9270db0b778831a4347be78a864 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:02:45 +0100 Subject: [PATCH 069/233] Cleanup --- src/cdomains/arrayDomain.ml | 10 +++++----- src/cdomains/nullByteSet.ml | 12 ++++-------- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d462aca666..4a0a9acb8d 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1150,9 +1150,9 @@ struct | Some max_size -> (* ... add all indexes < maximal size to may_nulls_set *) if Z.equal min_i Z.zero && Z.geq max_i max_size then - (must_nulls_set, MaySet.top ()) + Nulls.add_all Possibly nulls else if Z.geq max_i max_size then - (must_nulls_set, add_indexes min_i (Z.pred max_size) may_nulls_set) + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls else Nulls.add_interval Possibly (min_i, max_i) nulls else @@ -1170,7 +1170,7 @@ struct (* ... and there is no maximal size, modify may_nulls_set to top *) | None -> Nulls.forget_may nulls (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> Nulls.add_may_interval (min_i, Z.pred max_size) nulls + | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) else if Val.is_not_null v then Nulls.filter_musts (Z.gt min_i) min_size nulls @@ -1186,11 +1186,11 @@ struct (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) | None, Some max_size -> let nulls = Nulls.forget_must nulls in - Nulls.add_may_interval (min_i, Z.pred max_size) nulls + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) | Some min_size, Some max_size -> let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in - Nulls.add_may_interval (min_i, Z.pred max_size) nulls + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls ) | Some max_i when Z.geq max_i Z.zero -> if Z.equal min_i max_i then diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index cdeb481b07..5cf6445ac6 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -110,14 +110,10 @@ module MustMaySet = struct in (musts, add_indexes l u mays) - let add_may_interval (l,u) (musts, mays) = - let rec add_indexes i max set = - if Z.gt i max then - set - else - add_indexes (Z.succ i) max (MaySet.add i set) - in - (musts, add_indexes l u mays) + let add_all mode (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> (musts, MaySet.top ()) let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) From 8abc9c950013da5dd2d9ab5b78732a6e40ee5786 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:11:49 +0100 Subject: [PATCH 070/233] Progress --- src/cdomains/arrayDomain.ml | 5 +++++ src/cdomains/nullByteSet.ml | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 4a0a9acb8d..fbc859f282 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1155,6 +1155,11 @@ struct Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls else Nulls.add_interval Possibly (min_i, max_i) nulls + else if Val.is_not_null v then + if Z.equal min_i Z.zero && Z.geq max_i min_size then + Nulls.remove_all Possibly nulls + else + Nulls.filter_musts (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) min_size nulls else (set_interval_must min_i max_i, set_interval_may min_i max_i) in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 5cf6445ac6..7a4bf7c1d7 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -115,6 +115,11 @@ module MustMaySet = struct | Definitely -> failwith "todo" | Possibly -> (musts, MaySet.top ()) + let remove_all mode (musts, mays) = + match mode with + | Definitely -> (MustSet.top (), mays) + | Possibly -> failwith "todo" + let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) From f166671f9ab4bfd8e54d77206668db552e7c93b9 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:33:36 +0100 Subject: [PATCH 071/233] Simplify --- src/cdomains/arrayDomain.ml | 52 ++++++++++--------------------------- 1 file changed, 14 insertions(+), 38 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index fbc859f282..33817698e4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1064,11 +1064,6 @@ struct let set (ask: VDQ.t) ((must_nulls_set, may_nulls_set, size) as x) (e, i) v = let nulls = (must_nulls_set, may_nulls_set) in - let rec add_indexes i max may_nulls_set = - if Z.gt i max then - may_nulls_set - else - add_indexes (Z.succ i) max (MaySet.add i may_nulls_set) in let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1114,34 +1109,6 @@ struct nulls in - let set_interval_must min_i max_i = - (* if value = null, return must_nulls_set unmodified as not clear which index is set to null *) - if Val.is_null v then - must_nulls_set - (* if value <> null or unknown, only keep indexes must_i < minimal index and must_i > maximal index *) - else if Z.equal min_i Z.zero && Z.geq max_i min_size then - MustSet.top () - else - MustSet.filter (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) must_nulls_set min_size in - - let set_interval_may min_i max_i = - (* if value <> null, return may_nulls_set unmodified as not clear which index is set to value *) - if Val.is_not_null v then - may_nulls_set - (* if value = null or unknown *) - else - match idx_maximal size with - (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) - | None -> add_indexes min_i max_i may_nulls_set - | Some max_size -> - (* ... add all indexes < maximal size to may_nulls_set *) - if Z.equal min_i Z.zero && Z.geq max_i max_size then - MaySet.top () - else if Z.geq max_i max_size then - add_indexes min_i (Z.pred max_size) may_nulls_set - else - add_indexes min_i max_i may_nulls_set in - let set_interval min_i max_i = if Val.is_null v then match idx_maximal size with @@ -1151,17 +1118,26 @@ struct (* ... add all indexes < maximal size to may_nulls_set *) if Z.equal min_i Z.zero && Z.geq max_i max_size then Nulls.add_all Possibly nulls - else if Z.geq max_i max_size then - Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls - else - Nulls.add_interval Possibly (min_i, max_i) nulls + else + Nulls.add_interval Possibly (min_i, Z.min (Z.pred max_size) max_i) nulls else if Val.is_not_null v then if Z.equal min_i Z.zero && Z.geq max_i min_size then Nulls.remove_all Possibly nulls else Nulls.filter_musts (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) min_size nulls else - (set_interval_must min_i max_i, set_interval_may min_i max_i) + let nulls = match idx_maximal size with + (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) + | None -> Nulls.add_interval Possibly (min_i,max_i) nulls + | Some max_size when Z.equal min_i Z.zero && Z.geq max_i max_size -> + (* ... add all indexes < maximal size to may_nulls_set *) + Nulls.add_all Possibly nulls + | Some max_size -> Nulls.add_interval Possibly (min_i, Z.min (Z.pred max_size) max_i) nulls + in + if Z.equal min_i Z.zero && Z.geq max_i min_size then + Nulls.remove_all Possibly nulls + else + Nulls.filter_musts (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) min_size nulls in (* warn if index is (potentially) out of bounds *) From 404e505cb28237f4d6701fcfb28a4128740cd486 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:50:22 +0100 Subject: [PATCH 072/233] Simplify --- src/cdomains/arrayDomain.ml | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 33817698e4..52e3c8eb49 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1064,9 +1064,7 @@ struct let set (ask: VDQ.t) ((must_nulls_set, may_nulls_set, size) as x) (e, i) v = let nulls = (must_nulls_set, may_nulls_set) in - let min interval = match Idx.minimal interval with - | Some min_num when Z.geq min_num Z.zero -> min_num - | _ -> Z.zero in (* assume worst case minimal natural number *) + let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in let min_size = min size in let min_i = min i in @@ -1207,17 +1205,21 @@ struct Z.zero, None) else min_i, None - | None, None -> Z.zero, None in - match max_i, Val.is_null v, Val.is_not_null v with - (* if value = null, return (bot = all indexes up to minimal size - 1, top = all indexes up to maximal size - 1, size) *) - | Some max_i, true, _ -> (MustSet.bot (), MaySet.top (), Idx.of_interval ILong (min_i, max_i)) - | None, true, _ -> (MustSet.bot (), MaySet.top (), Idx.starting ILong min_i) - (* if value <> null, return (top = no indexes, bot = no indexes, size) *) - | Some max_i, false, true -> (MustSet.top (), MaySet.bot (), Idx.of_interval ILong (min_i, max_i)) - | None, false, true -> (MustSet.top (), MaySet.bot (), Idx.starting ILong min_i) - (* if value unknown, return (top = no indexes, top = all indexes up to maximal size - 1, size) *) - | Some max_i, false, false -> (MustSet.top (), MaySet.top (), Idx.of_interval ILong (min_i, max_i)) - | None, false, false -> (MustSet.top (), MaySet.top (), Idx.starting ILong min_i) + | None, None -> Z.zero, None + in + let size = match max_i with + | Some max_i -> Idx.of_interval ILong (min_i, max_i) + | None -> Idx.starting ILong min_i + in + let nulls = + if Val.is_null v then + Nulls.make_all_must () + else if Val.is_not_null v then + Nulls.make_none_may () + else + Nulls.top () + in + uf @@ (nulls, size) let length (_, _, size) = Some size From 97c6c08fb8827a46e72a12ea3fcbe70cdf98d91b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:57:48 +0100 Subject: [PATCH 073/233] Simplify --- src/cdomains/nullByteSet.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 7a4bf7c1d7..93e542c01f 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -123,6 +123,9 @@ module MustMaySet = struct let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) + let make_all_must () = (MustSet.bot (), MaySet.top ()) + let make_none_may () = (MustSet.top (), MaySet.bot ()) + let may_exist f (musts, mays) = MaySet.exists f mays let forget_may (musts, mays) = (musts, MaySet.top ()) From 92d25b0b48a2653a1499d0756ee822407e26b752 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 18:58:07 +0100 Subject: [PATCH 074/233] Simplify --- src/cdomains/arrayDomain.ml | 31 ++++++++++--------------------- 1 file changed, 10 insertions(+), 21 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 52e3c8eb49..a40cc79a20 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1223,18 +1223,19 @@ struct let length (_, _, size) = Some size - let move_if_affected ?(replace_with_const=false) _ sets_and_size _ _ = sets_and_size + let move_if_affected ?(replace_with_const=false) _ x _ _ = x let get_vars_in_e _ = [] let map f (must_nulls_set, may_nulls_set, size) = + let nulls = (must_nulls_set, may_nulls_set) in (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) if Val.is_null (f (Val.null ())) then - (must_nulls_set, MaySet.top (), size) + uf @@ (Nulls.forget_may nulls, size) (* else also return top for must_nulls_set *) else - (MustSet.top (), MaySet.top (), size) + uf @@ (Nulls.top (), size) let fold_left f acc _ = f acc (Val.top ()) @@ -1386,17 +1387,13 @@ struct else if Z.lt min_size1 max_len2 then M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = match Idx.minimal size2' with - | Some min_size2 -> min_size2 - | None -> Z.zero in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in (* get must nulls from src string < minimal size of dest *) MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 (* and keep indexes of dest >= maximal strlen of src *) |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = - let max_size2 = match idx_maximal size2' with - | Some max_size2 -> max_size2 - | None -> max_size1 in + let max_size2 = BatOption.default max_size1 (idx_maximal size2') in (* get may nulls from src string < maximal size of dest *) MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 (* and keep indexes of dest >= minimal strlen of src *) @@ -1406,9 +1403,7 @@ struct (if Z.lt min_size1 max_len2 then M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = match Idx.minimal size2' with - | Some min_size2 -> min_size2 - | None -> Z.zero in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = @@ -1423,14 +1418,10 @@ struct M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = match Idx.minimal size2' with - | Some min_size2 -> min_size2 - | None -> Z.zero in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = - let max_size2 = match idx_maximal size2' with - | Some max_size2 -> max_size2 - | None -> max_size1 in + let max_size2 = BatOption.default max_size1 (idx_maximal size2') in MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in (must_nulls_set_result, may_nulls_set_result, size1) @@ -1439,9 +1430,7 @@ struct M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = match Idx.minimal size2' with - | Some min_size2 -> min_size2 - | None -> Z.zero in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) From 8db296664ae475e726e87a7b9edfc4be638d2b94 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 19:24:32 +0100 Subject: [PATCH 075/233] Simplify --- src/cdomains/arrayDomain.ml | 81 ++++++++++++++++++++----------------- 1 file changed, 44 insertions(+), 37 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index a40cc79a20..82f616e3d7 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1292,63 +1292,68 @@ struct * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) let to_n_string (must_nulls_set, may_nulls_set, size) n = - let nulls = (must_nulls_set, may_nulls_set) in - let rec add_indexes i max set = - if Z.geq i max then - set - else - add_indexes (Z.succ i) max (MaySet.add i set) in - let update_must_indexes min_must_null must_nulls_set = - if Z.equal min_must_null Z.zero then - MustSet.bot () - else - (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) - add_indexes min_must_null (Z.of_int n) must_nulls_set - |> MustSet.M.filter (Z.gt (Z.of_int n)) in - let update_may_indexes min_may_null may_nulls_set = - if Z.equal min_may_null Z.zero then - MaySet.top () - else - (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) - add_indexes min_may_null (Z.of_int n) may_nulls_set - |> MaySet.M.filter (Z.gt (Z.of_int n)) in - let warn_no_null min_must_null exists_min_must_null min_may_null = - if Z.geq min_may_null (Z.of_int n) then - M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" - else if (exists_min_must_null && (Z.geq min_must_null (Z.of_int n)) || (Z.gt min_must_null min_may_null)) || not exists_min_must_null then - M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in - if n < 0 then - (MustSet.top (), MaySet.top (), Idx.top_of ILong) + uf @@ (Nulls.top (), Idx.top_of ILong) else + let n = Z.of_int n in + let nulls = (must_nulls_set, may_nulls_set) in + let rec add_indexes i max set = + if Z.geq i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) in + let update_must_indexes min_must_null must_nulls_set = + if Z.equal min_must_null Z.zero then + MustSet.bot () + else + (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) + add_indexes min_must_null n must_nulls_set + |> MustSet.M.filter (Z.gt n) in + let update_may_indexes min_may_null may_nulls_set = + if Z.equal min_may_null Z.zero then + MaySet.top () + else + (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) + add_indexes min_may_null n may_nulls_set + |> MaySet.M.filter (Z.gt n) in + let warn_no_null min_must_null exists_min_must_null min_may_null = + if Z.geq min_may_null n then + M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" + else if (exists_min_must_null && (Z.geq min_must_null n) || (Z.gt min_must_null min_may_null)) || not exists_min_must_null then + M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" + in ((match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> - if Z.gt (Z.of_int n) max_size then + if Z.gt n max_size then M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - else if Z.gt (Z.of_int n) min_size then + else if Z.gt n min_size then M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | Some min_size, None -> - if Z.gt (Z.of_int n) min_size then + if Z.gt n min_size then M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | None, Some max_size -> - if Z.gt (Z.of_int n) max_size then + if Z.gt n max_size then M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" | None, None -> ()); - + let nulls = (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if Nulls.is_empty Definitely nulls then (M.warn ~category:ArrayOobMessage.past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) - | Some max_size when Z.geq max_size Z.zero -> (must_nulls_set, add_indexes max_size (Z.of_int n) may_nulls_set, Idx.of_int ILong (Z.of_int n)) - | _ -> (must_nulls_set, may_nulls_set, Idx.of_int ILong (Z.of_int n))) + | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls + | _ -> nulls) (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) else if Nulls.is_empty Possibly nulls then let min_may_null = Nulls.min_elem Possibly nulls in warn_no_null Z.zero false min_may_null; - (must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) + if Z.equal min_may_null Z.zero then + Nulls.forget_may nulls + else + let (must, mays) = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + (must, mays |> MaySet.M.filter (Z.gt n)) (* TODO: this makes little sense *) else let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in @@ -1356,9 +1361,11 @@ struct warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) if Z.equal min_must_null min_may_null then - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n)) + (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set) else - (MustSet.top (), update_may_indexes min_may_null may_nulls_set, Idx.of_int ILong (Z.of_int n))) + (MustSet.top (), update_may_indexes min_may_null may_nulls_set) + in + uf @@ (nulls, Idx.of_int ILong n)) let to_string_length (must_nulls_set, may_nulls_set, size) = let nulls = (must_nulls_set, may_nulls_set) in From 8318ad8e1ff2d613a6aa259bacc2894743314d32 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 25 Nov 2023 20:21:37 +0100 Subject: [PATCH 076/233] Simplify --- src/cdomains/arrayDomain.ml | 34 ++++++++-------------------------- src/cdomains/nullByteSet.ml | 29 +++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 34 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 82f616e3d7..fed8be60b6 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1108,34 +1108,16 @@ struct in let set_interval min_i max_i = - if Val.is_null v then - match idx_maximal size with - (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) - | None -> Nulls.add_interval Possibly (min_i, max_i) nulls - | Some max_size -> - (* ... add all indexes < maximal size to may_nulls_set *) - if Z.equal min_i Z.zero && Z.geq max_i max_size then - Nulls.add_all Possibly nulls - else - Nulls.add_interval Possibly (min_i, Z.min (Z.pred max_size) max_i) nulls - else if Val.is_not_null v then - if Z.equal min_i Z.zero && Z.geq max_i min_size then - Nulls.remove_all Possibly nulls - else - Nulls.filter_musts (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) min_size nulls + (* Update max_i so it is capped at the maximum size *) + let max_i = BatOption.map_default (fun x -> Z.min max_i @@ Z.pred x) max_i (idx_maximal size) in + if Val.is_not_null v then + Nulls.remove_interval Possibly (min_i, max_i) min_size nulls else - let nulls = match idx_maximal size with - (* ... and size has no upper limit, add all indexes of interval to may_nulls_set *) - | None -> Nulls.add_interval Possibly (min_i,max_i) nulls - | Some max_size when Z.equal min_i Z.zero && Z.geq max_i max_size -> - (* ... add all indexes < maximal size to may_nulls_set *) - Nulls.add_all Possibly nulls - | Some max_size -> Nulls.add_interval Possibly (min_i, Z.min (Z.pred max_size) max_i) nulls - in - if Z.equal min_i Z.zero && Z.geq max_i min_size then - Nulls.remove_all Possibly nulls + let nulls = Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls in + if Val.is_null v then + nulls else - Nulls.filter_musts (fun x -> (Z.lt x min_i || Z.gt x max_i) && Z.lt x min_size) min_size nulls + Nulls.remove_interval Possibly (min_i, max_i) min_size nulls in (* warn if index is (potentially) out of bounds *) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 93e542c01f..349526d092 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -98,17 +98,30 @@ module MustMaySet = struct | Definitely -> (MustSet.add i musts, MaySet.add i mays) | Possibly -> (musts, MaySet.add i mays) - let add_interval mode (l,u) (musts, mays) = + let add_interval ?maxfull mode (l,u) (musts, mays) = match mode with | Definitely -> failwith "todo" | Possibly -> - let rec add_indexes i max set = - if Z.gt i max then - set + match maxfull with + | Some Some maxfull when Z.equal l Z.zero && Z.geq u maxfull -> + (musts, MaySet.top ()) + | _ -> + let rec add_indexes i max set = + if Z.gt i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) + in + (musts, add_indexes l u mays) + + let remove_interval mode (l,u) min_size (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> + if Z.equal l Z.zero && Z.geq u min_size then + (MustSet.top (), mays) else - add_indexes (Z.succ i) max (MaySet.add i set) - in - (musts, add_indexes l u mays) + (MustSet.filter (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts min_size, mays) let add_all mode (musts, mays) = match mode with @@ -131,4 +144,4 @@ module MustMaySet = struct let forget_may (musts, mays) = (musts, MaySet.top ()) let forget_must (musts, mays) = (MustSet.top (), mays) let filter_musts f min_size (musts, mays) = (MustSet.filter f musts min_size, mays) -end \ No newline at end of file +end From 86872a18b3faa890e06da45900dc165679dd266d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 11:49:11 +0100 Subject: [PATCH 077/233] Simplify --- src/cdomains/arrayDomain.ml | 65 +++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 31 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index fed8be60b6..d14d4ec5c8 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1010,6 +1010,18 @@ struct type value = Val.t type ret = Null | NotNull | Top + module Val = struct + include Val + + let is_null v = + if is_not_null v then + NotNull + else if is_null v then + Null + else + Top + end + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds @@ -1060,7 +1072,7 @@ struct (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top - let uf ((a,b),c) = (a,b,c) + let uf ((a,b),c) = (a,b,c) let set (ask: VDQ.t) ((must_nulls_set, may_nulls_set, size) as x) (e, i) v = let nulls = (must_nulls_set, may_nulls_set) in @@ -1074,30 +1086,26 @@ struct match idx_maximal size with (* if size has no upper limit *) | None -> - (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) - if Val.is_not_null v && not (MaySet.is_top may_nulls_set) then - Nulls.remove Definitely i nulls min_size - else if Val.is_not_null v then - Nulls.remove Possibly i nulls min_size - (* ..., i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - else if Z.lt i min_size && Val.is_null v then - Nulls.add Definitely i nulls - (* ..., i >= minimal size and value = null, add i only to may_nulls_set *) - else if Val.is_null v then - Nulls.add Possibly i nulls - (* ... and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) - else + (match Val.is_null v with + | NotNull -> + Nulls.remove (if MaySet.is_top may_nulls_set then Possibly else Definitely) i nulls min_size + (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) + | Null -> + Nulls.add (if Z.lt i min_size then Definitely else Possibly) i nulls + (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + (* i >= minimal size and value = null, add i only to may_nulls_set *) + | Top -> let removed = Nulls.remove Possibly i nulls min_size in - Nulls.add Possibly i removed + Nulls.add Possibly i removed) | Some max_size -> (* if value <> null, remove i from must_nulls_set and may_nulls_set *) if Val.is_not_null v then Nulls.remove Definitely i nulls min_size (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - else if Z.lt i min_size && Val.is_null v then + else if Z.lt i min_size && Val.is_null v = Null then Nulls.add Definitely i nulls (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) - else if Z.lt i max_size && Val.is_null v then + else if Z.lt i max_size && Val.is_null v = Null then Nulls.add Possibly i nulls (* if i < maximal size and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) else if Z.lt i max_size then @@ -1114,7 +1122,7 @@ struct Nulls.remove_interval Possibly (min_i, max_i) min_size nulls else let nulls = Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls in - if Val.is_null v then + if Val.is_null v = Null then nulls else Nulls.remove_interval Possibly (min_i, max_i) min_size nulls @@ -1126,7 +1134,7 @@ struct (* if no maximum number in index interval *) | None -> (* ..., value = null *) - (if Val.is_null v && idx_maximal size = None then + (if Val.is_null v = Null && idx_maximal size = None then match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) | None -> Nulls.forget_may nulls @@ -1193,13 +1201,10 @@ struct | Some max_i -> Idx.of_interval ILong (min_i, max_i) | None -> Idx.starting ILong min_i in - let nulls = - if Val.is_null v then - Nulls.make_all_must () - else if Val.is_not_null v then - Nulls.make_none_may () - else - Nulls.top () + let nulls = match Val.is_null v with + | Null -> Nulls.make_all_must () + | NotNull -> Nulls.make_none_may () + | Top -> Nulls.top () in uf @@ (nulls, size) @@ -1213,11 +1218,9 @@ struct let nulls = (must_nulls_set, may_nulls_set) in (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) - if Val.is_null (f (Val.null ())) then - uf @@ (Nulls.forget_may nulls, size) - (* else also return top for must_nulls_set *) - else - uf @@ (Nulls.top (), size) + match Val.is_null (f (Val.null ())) with + | Null -> uf @@ (Nulls.forget_may nulls, size) + | _ -> uf @@ (Nulls.top (), size) (* else also return top for must_nulls_set *) let fold_left f acc _ = f acc (Val.top ()) From 55d9a531a6a6a1566fa82b98b209a34f929647bf Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 12:02:13 +0100 Subject: [PATCH 078/233] Simplify --- src/cdomains/arrayDomain.ml | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d14d4ec5c8..bde4934994 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1098,21 +1098,19 @@ struct let removed = Nulls.remove Possibly i nulls min_size in Nulls.add Possibly i removed) | Some max_size -> - (* if value <> null, remove i from must_nulls_set and may_nulls_set *) - if Val.is_not_null v then - Nulls.remove Definitely i nulls min_size - (* if i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - else if Z.lt i min_size && Val.is_null v = Null then - Nulls.add Definitely i nulls - (* if minimal size <= i < maximal size and value = null, add i only to may_nulls_set *) - else if Z.lt i max_size && Val.is_null v = Null then - Nulls.add Possibly i nulls - (* if i < maximal size and value unknown, remove i from must_nulls_set and add it to may_nulls_set *) - else if Z.lt i max_size then - let removed = Nulls.remove Possibly i nulls min_size in - Nulls.add Possibly i removed - else - nulls + (match Val.is_null v with + | NotNull -> + Nulls.remove Definitely i nulls min_size + (* if value <> null, remove i from must_nulls_set and may_nulls_set *) + | Null when Z.lt i min_size -> + Nulls.add Definitely i nulls + | Null when Z.lt i max_size -> + Nulls.add Possibly i nulls + | NotNull when Z.lt i max_size -> + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed + | _ -> nulls + ) in let set_interval min_i max_i = From b4d8bdb9c0204583b18d83ba57a1c32c28d0184d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 12:04:14 +0100 Subject: [PATCH 079/233] simplify --- src/cdomains/arrayDomain.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index bde4934994..a3823dfcbb 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1116,14 +1116,12 @@ struct let set_interval min_i max_i = (* Update max_i so it is capped at the maximum size *) let max_i = BatOption.map_default (fun x -> Z.min max_i @@ Z.pred x) max_i (idx_maximal size) in - if Val.is_not_null v then - Nulls.remove_interval Possibly (min_i, max_i) min_size nulls - else + match Val.is_null v with + | NotNull -> Nulls.remove_interval Possibly (min_i, max_i) min_size nulls + | Null -> Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls + | Top -> let nulls = Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls in - if Val.is_null v = Null then - nulls - else - Nulls.remove_interval Possibly (min_i, max_i) min_size nulls + Nulls.remove_interval Possibly (min_i, max_i) min_size nulls in (* warn if index is (potentially) out of bounds *) From 998feb8c04faf2e667c8b7bb42a2488bfe97cd49 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 12:32:19 +0100 Subject: [PATCH 080/233] Simplify --- src/cdomains/arrayDomain.ml | 97 +++++++++++++++++++------------------ src/cdomains/nullByteSet.ml | 10 ++++ 2 files changed, 59 insertions(+), 48 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index a3823dfcbb..e42b062818 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1003,7 +1003,7 @@ struct module Nulls = NullByteSet.MustMaySet (* (Must Null Set, May Null Set, Array Size) *) - include Lattice.Prod3 (MustSet) (MaySet) (Idx) + include Lattice.Prod (Nulls) (Idx) let name () = "arrays containing null bytes" type idx = Idx.t @@ -1031,8 +1031,7 @@ struct | Some i when Z.fits_int i -> Some i | _ -> None - let get (ask: VDQ.t) (must_nulls_set, may_nulls_set, size) (e, i) = - let nulls = (must_nulls_set, may_nulls_set) in + let get (ask: VDQ.t) (nulls, size) (e, i) = let min interval = match Idx.minimal interval with | Some min_num when Z.geq min_num Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) @@ -1072,10 +1071,9 @@ struct (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top - let uf ((a,b),c) = (a,b,c) + let uf (a,c) = (a,c) - let set (ask: VDQ.t) ((must_nulls_set, may_nulls_set, size) as x) (e, i) v = - let nulls = (must_nulls_set, may_nulls_set) in + let set (ask: VDQ.t) ((nulls, size) as x) (e, i) v = let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in let min_size = min size in @@ -1088,7 +1086,7 @@ struct | None -> (match Val.is_null v with | NotNull -> - Nulls.remove (if MaySet.is_top may_nulls_set then Possibly else Definitely) i nulls min_size + Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) | Null -> Nulls.add (if Z.lt i min_size then Definitely else Possibly) i nulls @@ -1106,7 +1104,7 @@ struct Nulls.add Definitely i nulls | Null when Z.lt i max_size -> Nulls.add Possibly i nulls - | NotNull when Z.lt i max_size -> + | Top when Z.lt i max_size -> let removed = Nulls.remove Possibly i nulls min_size in Nulls.add Possibly i removed | _ -> nulls @@ -1125,7 +1123,7 @@ struct in (* warn if index is (potentially) out of bounds *) - array_oob_check (module Idx) (must_nulls_set, size) (e, i); + array_oob_check (module Idx) (Nulls.get_set Possibly, size) (e, i); let nulls = match max_i with (* if no maximum number in index interval *) | None -> @@ -1204,14 +1202,13 @@ struct in uf @@ (nulls, size) - let length (_, _, size) = Some size + let length (_, size) = Some size let move_if_affected ?(replace_with_const=false) _ x _ _ = x let get_vars_in_e _ = [] - let map f (must_nulls_set, may_nulls_set, size) = - let nulls = (must_nulls_set, may_nulls_set) in + let map f (nulls, size) = (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) match Val.is_null (f (Val.null ())) with @@ -1236,11 +1233,10 @@ struct | Some i -> build_set (i + 1) (MaySet.add (Z.of_int i) set) | None -> MaySet.add last_null set in let set = build_set 0 (MaySet.empty ()) in - (set, set, Idx.of_int ILong (Z.succ last_null)) + ((set, set), Idx.of_int ILong (Z.succ last_null)) (** Returns an abstract value with at most one null byte marking the end of the string *) - let to_string ((must_nulls_set, may_nulls_set, size) as x) = - let nulls = (must_nulls_set, may_nulls_set) in + let to_string ((nulls, size) as x:t):t = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if Nulls.is_empty Definitely nulls then (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; x) @@ -1252,27 +1248,28 @@ struct let min_may_null = Nulls.min_elem Possibly nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) if Z.equal min_must_null min_may_null then - let (must,may) = Nulls.precise_singleton min_must_null in - (must, may, Idx.of_int ILong (Z.succ min_must_null)) + let nulls = Nulls.precise_singleton min_must_null in + (nulls, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with - | Some max_size -> (MustSet.empty (), MaySet.filter (Z.geq min_must_null) may_nulls_set max_size, Idx.of_int ILong (Z.succ min_must_null)) + | Some max_size -> ((MustSet.empty (), MaySet.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls) max_size), Idx.of_int ILong (Z.succ min_must_null)) | None -> - if MaySet.is_top may_nulls_set then + if MaySet.is_top (Nulls.get_set Possibly nulls) then let rec add_indexes acc i = if Z.gt i min_must_null then acc else add_indexes (MaySet.add i acc) (Z.succ i) in - (MustSet.empty (), add_indexes (MaySet.empty ()) Z.zero, Idx.of_int ILong (Z.succ min_must_null)) + ((MustSet.empty (), add_indexes (MaySet.empty ()) Z.zero), Idx.of_int ILong (Z.succ min_must_null)) else - (MustSet.empty (), MaySet.M.filter (Z.geq min_must_null) may_nulls_set, Idx.of_int ILong (Z.succ min_must_null)) + ((MustSet.empty (), MaySet.M.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls)), Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) - let to_n_string (must_nulls_set, may_nulls_set, size) n = + let to_n_string (nulls, size) n:t = + let must_nulls_set, may_nulls_set = nulls in if n < 0 then uf @@ (Nulls.top (), Idx.top_of ILong) else @@ -1348,8 +1345,7 @@ struct in uf @@ (nulls, Idx.of_int ILong n)) - let to_string_length (must_nulls_set, may_nulls_set, size) = - let nulls = (must_nulls_set, may_nulls_set) in + let to_string_length (nulls, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) (* TODO: check of must set really needed? *) if Nulls.is_empty Definitely nulls then @@ -1365,7 +1361,9 @@ struct else Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) - let string_copy (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let string_copy (nulls1, size1) (nulls2, size2) n = + let must_nulls_set1, may_nulls_set1 = nulls1 in + let must_nulls_set2, may_nulls_set2 = nulls2 in (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) let update_sets must_nulls_set2' may_nulls_set2' size2' len2 = match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with @@ -1386,7 +1384,7 @@ struct MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 (* and keep indexes of dest >= minimal strlen of src *) |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in - (must_nulls_set_result, may_nulls_set_result, size1) + ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, None, Some min_len2, Some max_len2 -> (if Z.lt min_size1 max_len2 then M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); @@ -1398,7 +1396,7 @@ struct (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in - (must_nulls_set_result, may_nulls_set_result, size1) + ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, Some max_size1, Some min_len2, None -> (if Z.lt max_size1 min_len2 then M.error ~category:ArrayOobMessage.past_end "The length of string src is greater than the allocated size for dest" @@ -1412,7 +1410,7 @@ struct let max_size2 = BatOption.default max_size1 (idx_maximal size2') in MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in - (must_nulls_set_result, may_nulls_set_result, size1) + ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, None, Some min_len2, None -> (if Z.lt min_size1 min_len2 then M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); @@ -1424,9 +1422,9 @@ struct (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in - (must_nulls_set_result, may_nulls_set_result, size1) + ((must_nulls_set_result, may_nulls_set_result), size1) (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustSet.top (), MaySet.top (), size1) in + | _ -> ((MustSet.top (), MaySet.top ()), size1) in (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) let sizes_warning size2 = @@ -1456,17 +1454,19 @@ struct (* strcpy *) | None -> sizes_warning size2; - let must_nulls_set2', may_nulls_set2', size2' = to_string (must_nulls_set2, may_nulls_set2, size2) in - let strlen2 = to_string_length (must_nulls_set2, may_nulls_set2, size2) in + let (must_nulls_set2', may_nulls_set2'), size2' = to_string (nulls2, size2) in + let strlen2 = to_string_length (nulls2, size2) in update_sets must_nulls_set2' may_nulls_set2' size2' strlen2 (* strncpy = exactly n bytes from src are copied to dest *) | Some n when n >= 0 -> sizes_warning (Idx.of_int ILong (Z.of_int n)); - let must_nulls_set2', may_nulls_set2', size2' = to_n_string (must_nulls_set2, may_nulls_set2, size2) n in + let (must_nulls_set2', may_nulls_set2'), size2' = to_n_string (nulls2, size2) n in update_sets must_nulls_set2' may_nulls_set2' size2' (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - | _ -> (MustSet.top (), MaySet.top (), size1) + | _ -> (Nulls.top (), size1) - let string_concat (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let string_concat (nulls1, size1) (nulls2, size2) n = + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let (must_nulls_set2, may_nulls_set2) = nulls2 in let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then @@ -1498,7 +1498,7 @@ struct |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) else MaySet.top () in - (MustSet.top (), may_nulls_set_result, size1) + ((MustSet.top (), may_nulls_set_result), size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Z.equal (MustSet.min_elt must_nulls_set1) (MaySet.min_elt may_nulls_set1) && Z.equal (MustSet.min_elt must_nulls_set2') (MaySet.min_elt may_nulls_set2') then let min_i1 = MustSet.min_elt must_nulls_set1 in @@ -1515,7 +1515,7 @@ struct |> MaySet.M.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) else MaySet.top () in - (must_nulls_set_result, may_nulls_set_result, size1) + ((must_nulls_set_result, may_nulls_set_result), size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else let min_i2 = MustSet.min_elt must_nulls_set2' in @@ -1542,11 +1542,11 @@ struct |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) else MaySet.top () in - (must_nulls_set_result, may_nulls_set_result, size1) in + ((must_nulls_set_result, may_nulls_set_result), size1) in let compute_concat must_nulls_set2' may_nulls_set2' = - let strlen1 = to_string_length (must_nulls_set1, may_nulls_set1, size1) in - let strlen2 = to_string_length (must_nulls_set2', may_nulls_set2', size2) in + let strlen1 = to_string_length ((must_nulls_set1, may_nulls_set1), size1) in + let strlen2 = to_string_length ((must_nulls_set2', may_nulls_set2'), size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> begin match idx_maximal size1, idx_maximal strlen1, idx_maximal strlen2 with @@ -1567,18 +1567,18 @@ struct update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' end (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (MustSet.top (), MaySet.top (), size1) in + | _ -> (Nulls.top (), size1) in match n with (* strcat *) | None -> - let must_nulls_set2', may_nulls_set2', _ = to_string (must_nulls_set2, may_nulls_set2, size2) in + let (must_nulls_set2', may_nulls_set2'), _ = to_string ((must_nulls_set2, may_nulls_set2), size2) in compute_concat must_nulls_set2' may_nulls_set2' (* strncat *) | Some n when n >= 0 -> (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let must_nulls_set2', may_nulls_set2' = - let must_nulls_set2, may_nulls_set2, size2 = to_string (must_nulls_set2, may_nulls_set2, size2) in + let (must_nulls_set2, may_nulls_set2), size2 = to_string ((must_nulls_set2, may_nulls_set2), size2) in if not (MaySet.exists (Z.gt (Z.of_int n)) may_nulls_set2) then (MustSet.singleton (Z.of_int n), MaySet.singleton (Z.of_int n)) else if not (MustSet.exists (Z.gt (Z.of_int n)) must_nulls_set2) then @@ -1589,10 +1589,9 @@ struct let max_size2 = BatOption.default (Z.of_int n) (idx_maximal size2) in (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in compute_concat must_nulls_set2' may_nulls_set2' - | _ -> (MustSet.top (), MaySet.top (), size1) + | _ -> (Nulls.top (), size1) - let substring_extraction haystack ((must_needle, may_needle, size_needle) as needle) = - let nulls_needle = (must_needle, may_needle) in + let substring_extraction haystack ((nulls_needle, size_needle) as needle) = (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) if Nulls.mem Definitely Z.zero nulls_needle then IsSubstrAtIndex0 @@ -1608,7 +1607,9 @@ struct IsMaybeSubstr | _ -> IsMaybeSubstr - let string_comparison (must_nulls_set1, may_nulls_set1, size1) (must_nulls_set2, may_nulls_set2, size2) n = + let string_comparison (nulls1, size1) (nulls2, size2) n = + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let (must_nulls_set2, may_nulls_set2) = nulls2 in let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) if (MustSet.mem Z.zero must_nulls_set1 && (MustSet.mem Z.zero must_nulls_set2)) @@ -1676,7 +1677,7 @@ struct compare (Z.of_int n) true | _ -> Idx.top_of IInt - let update_length new_size (must_nulls_set, may_nulls_set, size) = (must_nulls_set, may_nulls_set, new_size) + let update_length new_size (nulls, size) = (nulls, new_size) let project ?(varAttr=[]) ?(typAttr=[]) _ t = t diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 349526d092..769b9cc485 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -133,6 +133,16 @@ module MustMaySet = struct | Definitely -> (MustSet.top (), mays) | Possibly -> failwith "todo" + let is_full_set mode (musts, mays) = + match mode with + | Definitely -> MustSet.is_bot musts + | Possibly -> MaySet.is_top mays + + let get_set mode (musts, mays) = + match mode with + | Definitely -> musts + | Possibly -> mays + let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) From 54682753e1e8353d8c559ed64a68fb1d478ae016 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 12:39:17 +0100 Subject: [PATCH 081/233] Simplify --- src/cdomains/arrayDomain.ml | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index e42b062818..6fceba963b 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1544,7 +1544,7 @@ struct MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) in - let compute_concat must_nulls_set2' may_nulls_set2' = + let compute_concat (must_nulls_set2',may_nulls_set2') = let strlen1 = to_string_length ((must_nulls_set1, may_nulls_set1), size1) in let strlen2 = to_string_length ((must_nulls_set2', may_nulls_set2'), size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with @@ -1572,12 +1572,12 @@ struct match n with (* strcat *) | None -> - let (must_nulls_set2', may_nulls_set2'), _ = to_string ((must_nulls_set2, may_nulls_set2), size2) in - compute_concat must_nulls_set2' may_nulls_set2' + let nulls2', _ = to_string ((must_nulls_set2, may_nulls_set2), size2) in + compute_concat nulls2' (* strncat *) | Some n when n >= 0 -> (* take at most n bytes from src; if no null byte among them, add null byte at index n *) - let must_nulls_set2', may_nulls_set2' = + let nulls2' = let (must_nulls_set2, may_nulls_set2), size2 = to_string ((must_nulls_set2, may_nulls_set2), size2) in if not (MaySet.exists (Z.gt (Z.of_int n)) may_nulls_set2) then (MustSet.singleton (Z.of_int n), MaySet.singleton (Z.of_int n)) @@ -1587,8 +1587,9 @@ struct else let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in let max_size2 = BatOption.default (Z.of_int n) (idx_maximal size2) in - (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) in - compute_concat must_nulls_set2' may_nulls_set2' + (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) + in + compute_concat nulls2' | _ -> (Nulls.top (), size1) let substring_extraction haystack ((nulls_needle, size_needle) as needle) = @@ -1648,12 +1649,8 @@ struct compare Z.zero false (* strncmp *) | Some n when n >= 0 -> - let min_size1 = match Idx.minimal size1 with - | Some min_size1 -> min_size1 - | None -> Z.zero in - let min_size2 = match Idx.minimal size2 with - | Some min_size2 -> min_size2 - | None -> Z.zero in + let min_size1 = BatOption.default Z.zero (Idx.minimal size1) in + let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in (* issue a warning if n is (potentially) smaller than array sizes *) (match idx_maximal size1 with | Some max_size1 -> From 23b6f7401e16ed4bb07194fd46221ac66278f62e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 12:47:55 +0100 Subject: [PATCH 082/233] SImplify --- src/cdomains/arrayDomain.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 6fceba963b..48105bd2cc 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1613,14 +1613,13 @@ struct let (must_nulls_set2, may_nulls_set2) = nulls2 in let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) - if (MustSet.mem Z.zero must_nulls_set1 && (MustSet.mem Z.zero must_nulls_set2)) - || (n_exists && Z.equal Z.zero n) then + if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (n_exists && Z.equal Z.zero n) then Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) - else if MustSet.mem Z.zero must_nulls_set1 && not (MaySet.mem Z.zero may_nulls_set2) then + else if Nulls.mem Definitely Z.zero nulls1 && not (Nulls.mem Possibly Z.zero nulls2) then Idx.ending IInt Z.minus_one (* if only s2 = empty string, return positive integer *) - else if MustSet.mem Z.zero must_nulls_set2 then + else if Nulls.mem Definitely Z.zero nulls2 then Idx.starting IInt Z.one else (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) @@ -1637,13 +1636,13 @@ struct (* strcmp *) | None -> (* track any potential buffer overflow and issue warning if needed *) - (if MustSet.is_empty must_nulls_set1 && MaySet.is_empty may_nulls_set1 then + (if Nulls.is_empty Definitely nulls1 && Nulls.is_empty Possibly nulls1 then M.error ~category:ArrayOobMessage.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" - else if MustSet.is_empty must_nulls_set1 then + else if Nulls.is_empty Possibly nulls1 then M.warn ~category:ArrayOobMessage.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); - (if MustSet.is_empty must_nulls_set2 && MaySet.is_empty may_nulls_set2 then + (if Nulls.is_empty Definitely nulls2 && Nulls.is_empty Possibly nulls2 then M.error ~category:ArrayOobMessage.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" - else if MustSet.is_empty must_nulls_set2 then + else if Nulls.is_empty Possibly nulls2 then M.warn ~category:ArrayOobMessage.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); (* compute abstract value for result of strcmp *) compare Z.zero false @@ -1660,7 +1659,8 @@ struct M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes" | None -> if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes"); + M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes" + ); (match idx_maximal size2 with | Some max_size2 -> if Z.gt (Z.of_int n) max_size2 then From 0858696c4d03294074bfdc523ce3ce557d6639f2 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 13:05:57 +0100 Subject: [PATCH 083/233] Progress --- src/cdomains/arrayDomain.ml | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 48105bd2cc..835d0d31ea 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1609,8 +1609,6 @@ struct | _ -> IsMaybeSubstr let string_comparison (nulls1, size1) (nulls2, size2) n = - let (must_nulls_set1, may_nulls_set1) = nulls1 in - let (must_nulls_set2, may_nulls_set2) = nulls2 in let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (n_exists && Z.equal Z.zero n) then @@ -1621,16 +1619,21 @@ struct (* if only s2 = empty string, return positive integer *) else if Nulls.mem Definitely Z.zero nulls2 then Idx.starting IInt Z.one - else - (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) - (try if Z.equal (MustSet.min_elt must_nulls_set1) (MaySet.min_elt may_nulls_set1) - && Z.equal (MustSet.min_elt must_nulls_set2) (MaySet.min_elt may_nulls_set2) - && (not n_exists || Z.lt (MustSet.min_elt must_nulls_set1) n || Z.lt (MustSet.min_elt must_nulls_set2) n ) - && not (Z.equal (MustSet.min_elt must_nulls_set1) (MustSet.min_elt must_nulls_set2)) then - Idx.of_excl_list IInt [Z.zero] - else + else + try + let min_must1 = Nulls.min_elem Definitely nulls1 in + let min_must2 = Nulls.min_elem Definitely nulls2 in + if not (Z.equal min_must1 min_must2) + && Z.equal min_must1 (Nulls.min_elem Possibly nulls1) + && Z.equal min_must2 (Nulls.min_elem Possibly nulls2) + && (not n_exists || Z.lt min_must1 n || Z.lt min_must2 n) + then + (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) + Idx.of_excl_list IInt [Z.zero] + else Idx.top_of IInt - with Not_found -> Idx.top_of IInt) in + with Not_found -> Idx.top_of IInt + in match n with (* strcmp *) From 74c7693715fb7b80fc12e30654d66486409a86a8 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 13:06:51 +0100 Subject: [PATCH 084/233] Simplify --- src/cdomains/arrayDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 835d0d31ea..1312a3eeaa 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1073,7 +1073,7 @@ struct let uf (a,c) = (a,c) - let set (ask: VDQ.t) ((nulls, size) as x) (e, i) v = + let set (ask: VDQ.t) (nulls, size) (e, i) v = let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in let min_size = min size in From cc9043194b8003ccd25891bf4f76d6f24b3a798f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 13:13:00 +0100 Subject: [PATCH 085/233] Simplify --- src/cdomains/arrayDomain.ml | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 1312a3eeaa..30771d6c23 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1071,8 +1071,6 @@ struct (* if maximum number in interval is invalid, i.e. negative, return Top of value *) | _ -> Top - let uf (a,c) = (a,c) - let set (ask: VDQ.t) (nulls, size) (e, i) v = let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in @@ -1163,7 +1161,7 @@ struct (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) | _ -> nulls in - uf @@ (nulls, size) + (nulls, size) let make ?(varAttr=[]) ?(typAttr=[]) i v = @@ -1191,16 +1189,13 @@ struct min_i, None | None, None -> Z.zero, None in - let size = match max_i with - | Some max_i -> Idx.of_interval ILong (min_i, max_i) - | None -> Idx.starting ILong min_i - in + let size = BatOption.map_default (fun x -> Idx.of_interval ILong (min_i, x)) (Idx.starting ILong min_i) max_i in let nulls = match Val.is_null v with | Null -> Nulls.make_all_must () | NotNull -> Nulls.make_none_may () | Top -> Nulls.top () in - uf @@ (nulls, size) + (nulls, size) let length (_, size) = Some size @@ -1212,8 +1207,8 @@ struct (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) match Val.is_null (f (Val.null ())) with - | Null -> uf @@ (Nulls.forget_may nulls, size) - | _ -> uf @@ (Nulls.top (), size) (* else also return top for must_nulls_set *) + | Null -> (Nulls.forget_may nulls, size) + | _ -> (Nulls.top (), size) (* else also return top for must_nulls_set *) let fold_left f acc _ = f acc (Val.top ()) @@ -1271,10 +1266,9 @@ struct let to_n_string (nulls, size) n:t = let must_nulls_set, may_nulls_set = nulls in if n < 0 then - uf @@ (Nulls.top (), Idx.top_of ILong) + (Nulls.top (), Idx.top_of ILong) else let n = Z.of_int n in - let nulls = (must_nulls_set, may_nulls_set) in let rec add_indexes i max set = if Z.geq i max then set @@ -1300,7 +1294,7 @@ struct else if (exists_min_must_null && (Z.geq min_must_null n) || (Z.gt min_must_null min_may_null)) || not exists_min_must_null then M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in - ((match Idx.minimal size, idx_maximal size with + (match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> if Z.gt n max_size then M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" @@ -1343,7 +1337,7 @@ struct else (MustSet.top (), update_may_indexes min_may_null may_nulls_set) in - uf @@ (nulls, Idx.of_int ILong n)) + (nulls, Idx.of_int ILong n) let to_string_length (nulls, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) From cee44cd3936c673ed584a9c9cd03ad104702c363 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 15:40:17 +0100 Subject: [PATCH 086/233] Simplify --- src/cdomains/arrayDomain.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 30771d6c23..14d077e707 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1460,7 +1460,6 @@ struct let string_concat (nulls1, size1) (nulls2, size2) n = let (must_nulls_set1, may_nulls_set1) = nulls1 in - let (must_nulls_set2, may_nulls_set2) = nulls2 in let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then @@ -1566,22 +1565,23 @@ struct match n with (* strcat *) | None -> - let nulls2', _ = to_string ((must_nulls_set2, may_nulls_set2), size2) in + let nulls2', _ = to_string (nulls2, size2) in compute_concat nulls2' (* strncat *) | Some n when n >= 0 -> + let n = Z.of_int n in (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let nulls2' = - let (must_nulls_set2, may_nulls_set2), size2 = to_string ((must_nulls_set2, may_nulls_set2), size2) in - if not (MaySet.exists (Z.gt (Z.of_int n)) may_nulls_set2) then - (MustSet.singleton (Z.of_int n), MaySet.singleton (Z.of_int n)) - else if not (MustSet.exists (Z.gt (Z.of_int n)) must_nulls_set2) then - let max_size2 = BatOption.default (Z.succ (Z.of_int n)) (idx_maximal size2) in - (MustSet.empty (), MaySet.add (Z.of_int n) (MaySet.filter (Z.geq (Z.of_int n)) may_nulls_set2 max_size2)) + let (must_nulls_set2, may_nulls_set2), size2 = to_string (nulls2, size2) in + if not (MaySet.exists (Z.gt n) may_nulls_set2) then + (Nulls.precise_singleton n) + else if not (MustSet.exists (Z.gt n) must_nulls_set2) then + let max_size2 = BatOption.default (Z.succ n) (idx_maximal size2) in + (MustSet.empty (), MaySet.add n (MaySet.filter (Z.geq n) may_nulls_set2 max_size2)) else let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in - let max_size2 = BatOption.default (Z.of_int n) (idx_maximal size2) in - (MustSet.filter (Z.gt (Z.of_int n)) must_nulls_set2 min_size2, MaySet.filter (Z.gt (Z.of_int n)) may_nulls_set2 max_size2) + let max_size2 = BatOption.default n (idx_maximal size2) in + (MustSet.filter (Z.gt n) must_nulls_set2 min_size2, MaySet.filter (Z.gt n) may_nulls_set2 max_size2) in compute_concat nulls2' | _ -> (Nulls.top (), size1) From 5951b2af2ce500ea9f575ff9f0e1c7605ce3d7f9 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 16:18:37 +0100 Subject: [PATCH 087/233] Introduce alias for Z, pull up warning function --- src/cdomains/arrayDomain.ml | 169 +++++++++++++++++++----------------- src/cdomains/nullByteSet.ml | 5 +- 2 files changed, 92 insertions(+), 82 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 14d077e707..920e97982a 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1002,6 +1002,11 @@ struct module MaySet = NullByteSet.MaySet module Nulls = NullByteSet.MustMaySet + let (<.) = Z.lt + let (<=.) = Z.leq + let (>.) = Z.gt + let (>=.) = Z.geq + (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod (Nulls) (Idx) @@ -1025,6 +1030,7 @@ struct type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds + let warn_past_end = M.error ~category:ArrayOobMessage.past_end (* helper: returns Idx.maximal except for Overflows that are mapped to None *) let idx_maximal i = match Idx.maximal i with @@ -1033,7 +1039,7 @@ struct let get (ask: VDQ.t) (nulls, size) (e, i) = let min interval = match Idx.minimal interval with - | Some min_num when Z.geq min_num Z.zero -> min_num + | Some min_num when min_num >=. Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) let min_i = min i in @@ -1044,27 +1050,27 @@ struct (* if there is no maximum value in index interval *) | None, _ -> (* ... return NotNull if no i >= min_i in may_nulls_set *) - if not (Nulls.may_exist (Z.leq min_i) nulls) then + if not (Nulls.exists Possibly ((<=.) min_i) nulls) then NotNull (* ... else return Top *) else Top (* if there is no maximum size *) - | Some max_i, None when Z.geq max_i Z.zero -> + | Some max_i, None when max_i >=. Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && Nulls.interval_mem Definitely (min_i,max_i) nulls then + if max_i <. min_size && Nulls.interval_mem Definitely (min_i,max_i) nulls then Null (* ... return NotNull if no number in index interval is in may_nulls_set *) - else if not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then + else if not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then NotNull else Top - | Some max_i, Some max_size when Z.geq max_i Z.zero -> + | Some max_i, Some max_size when max_i >=. Z.zero -> (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) - if Z.lt max_i min_size && Nulls.interval_mem Definitely (min_i, max_i) nulls then + if max_i <. min_size && Nulls.interval_mem Definitely (min_i, max_i) nulls then Null (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) - else if Z.lt max_i max_size && not (Nulls.may_exist (fun x -> Z.geq x min_i && Z.leq x max_i) nulls) then + else if max_i <. max_size && not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then NotNull else Top @@ -1087,7 +1093,7 @@ struct Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) | Null -> - Nulls.add (if Z.lt i min_size then Definitely else Possibly) i nulls + Nulls.add (if i <. min_size then Definitely else Possibly) i nulls (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) (* i >= minimal size and value = null, add i only to may_nulls_set *) | Top -> @@ -1098,11 +1104,11 @@ struct | NotNull -> Nulls.remove Definitely i nulls min_size (* if value <> null, remove i from must_nulls_set and may_nulls_set *) - | Null when Z.lt i min_size -> + | Null when i <. min_size -> Nulls.add Definitely i nulls - | Null when Z.lt i max_size -> + | Null when i <. max_size -> Nulls.add Possibly i nulls - | Top when Z.lt i max_size -> + | Top when i <. max_size -> let removed = Nulls.remove Possibly i nulls min_size in Nulls.add Possibly i removed | _ -> nulls @@ -1153,7 +1159,7 @@ struct let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls ) - | Some max_i when Z.geq max_i Z.zero -> + | Some max_i when max_i >=. Z.zero -> if Z.equal min_i max_i then set_exact_nulls min_i else @@ -1167,22 +1173,22 @@ struct let make ?(varAttr=[]) ?(typAttr=[]) i v = let min_i, max_i = match Idx.minimal i, idx_maximal i with | Some min_i, Some max_i -> - if Z.lt min_i Z.zero && Z.lt max_i Z.zero then + if min_i <. Z.zero && max_i <. Z.zero then (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) - else if Z.lt min_i Z.zero then + else if min_i <. Z.zero then (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; Z.zero, Some max_i) else min_i, Some max_i | None, Some max_i -> - if Z.lt max_i Z.zero then + if max_i <. Z.zero then (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; Z.zero, Some Z.zero) else Z.zero, Some max_i | Some min_i, None -> - if Z.lt min_i Z.zero then + if min_i <. Z.zero then (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; Z.zero, None) else @@ -1221,7 +1227,7 @@ struct let to_null_byte_domain s = let last_null = Z.of_int (String.length s) in let rec build_set i set = - if Z.geq (Z.of_int i) last_null then + if (Z.of_int i) >=. last_null then MaySet.add last_null set else match String.index_from_opt s i '\x00' with @@ -1234,10 +1240,10 @@ struct let to_string ((nulls, size) as x:t):t = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) if Nulls.is_empty Definitely nulls then - (M.error ~category:ArrayOobMessage.past_end "Array access past end: buffer overflow"; x) + (warn_past_end "Array access past end: buffer overflow"; x) (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) else if Nulls.is_empty Possibly nulls then - (M.warn ~category:ArrayOobMessage.past_end "May access array past end: potential buffer overflow"; x) + (warn_past_end "May access array past end: potential buffer overflow"; x) else let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in @@ -1252,7 +1258,7 @@ struct | None -> if MaySet.is_top (Nulls.get_set Possibly nulls) then let rec add_indexes acc i = - if Z.gt i min_must_null then + if i >. min_must_null then acc else add_indexes (MaySet.add i acc) (Z.succ i) in @@ -1291,26 +1297,26 @@ struct let warn_no_null min_must_null exists_min_must_null min_may_null = if Z.geq min_may_null n then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" - else if (exists_min_must_null && (Z.geq min_must_null n) || (Z.gt min_must_null min_may_null)) || not exists_min_must_null then + else if (exists_min_must_null && (min_must_null >=. n) || min_must_null >. min_may_null) || not exists_min_must_null then M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in (match Idx.minimal size, idx_maximal size with | Some min_size, Some max_size -> - if Z.gt n max_size then - M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" - else if Z.gt n min_size then - M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" + else if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | Some min_size, None -> - if Z.gt n min_size then - M.warn ~category:ArrayOobMessage.past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" | None, Some max_size -> - if Z.gt n max_size then - M.warn ~category:ArrayOobMessage.past_end "Array size is smaller than n bytes; can cause a buffer overflow" + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" | None, None -> ()); let nulls = (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if Nulls.is_empty Definitely nulls then - (M.warn ~category:ArrayOobMessage.past_end + (warn_past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) @@ -1343,13 +1349,13 @@ struct (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) (* TODO: check of must set really needed? *) if Nulls.is_empty Definitely nulls then - (M.error ~category:ArrayOobMessage.past_end "Array doesn't contain a null byte: buffer overflow"; + (warn_past_end "Array doesn't contain a null byte: buffer overflow"; match Idx.minimal size with | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if Nulls.is_empty Possibly nulls then - (M.warn ~category:ArrayOobMessage.past_end "Array might not contain a null byte: potential buffer overflow"; + (warn_past_end "Array might not contain a null byte: potential buffer overflow"; Idx.starting !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls)) (* else return interval [minimal may null, minimal must null] *) else @@ -1362,10 +1368,10 @@ struct let update_sets must_nulls_set2' may_nulls_set2' size2' len2 = match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> - (if Z.lt max_size1 min_len2 then - M.error ~category:ArrayOobMessage.past_end "The length of string src is greater than the allocated size for dest" - else if Z.lt min_size1 max_len2 then - M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); + (if max_size1 <. min_len2 then + warn_past_end "The length of string src is greater than the allocated size for dest" + else if min_size1 <. max_len2 then + warn_past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in (* get must nulls from src string < minimal size of dest *) @@ -1380,8 +1386,8 @@ struct |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, None, Some min_len2, Some max_len2 -> - (if Z.lt min_size1 max_len2 then - M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); + (if min_size1 <. max_len2 then + warn_past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 @@ -1392,10 +1398,10 @@ struct |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, Some max_size1, Some min_len2, None -> - (if Z.lt max_size1 min_len2 then - M.error ~category:ArrayOobMessage.past_end "The length of string src is greater than the allocated size for dest" - else if Z.lt min_size1 min_len2 then - M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); + (if max_size1 <. min_len2 then + warn_past_end "The length of string src is greater than the allocated size for dest" + else if min_size1 <. min_len2 then + warn_past_end"The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in @@ -1406,8 +1412,8 @@ struct |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in ((must_nulls_set_result, may_nulls_set_result), size1) | Some min_size1, None, Some min_len2, None -> - (if Z.lt min_size1 min_len2 then - M.warn ~category:ArrayOobMessage.past_end "The length of string src may be greater than the allocated size for dest"); + (if min_size1 <. min_len2 then + warn_past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in @@ -1418,30 +1424,30 @@ struct |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in ((must_nulls_set_result, may_nulls_set_result), size1) (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> ((MustSet.top (), MaySet.top ()), size1) in + | _ -> (Nulls.top (), size1) in (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) let sizes_warning size2 = (match Idx.minimal size1, idx_maximal size1, Idx.minimal size2, idx_maximal size2 with - | Some min_size1, _, Some min_size2, _ when Z.lt min_size1 min_size2 -> + | Some min_size1, _, Some min_size2, _ when min_size1 <. min_size2 -> if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then - M.error ~category:ArrayOobMessage.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" - | Some min_size1, _, _, Some max_size2 when Z.lt min_size1 max_size2 -> + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | Some min_size1, _, _, Some max_size2 when min_size1 <. max_size2 -> if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then - M.error ~category:ArrayOobMessage.past_end "src doesn't contain a null byte at an index smaller than the size of dest" + warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" | Some min_size1, _, _, None -> if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then - M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" - | _, Some max_size1, _, Some max_size2 when Z.lt max_size1 max_size2 -> + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | _, Some max_size1, _, Some max_size2 when max_size1 <. max_size2 -> if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then - M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" |_, Some max_size1, _, None -> if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then - M.warn ~category:ArrayOobMessage.past_end "src may not contain a null byte at an index smaller than the size of dest" + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" | _ -> ()) in match n with @@ -1463,10 +1469,10 @@ struct let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then - M.error ~category:ArrayOobMessage.past_end + warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" else if (maxlen1_exists && maxlen2_exists && Z.leq min_size1 (Z.add maxlen1 maxlen2)) || not maxlen1_exists || not maxlen2_exists then - M.warn ~category:ArrayOobMessage.past_end + warn_past_end "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set @@ -1505,7 +1511,7 @@ struct if max_size1_exists then MaySet.filter (Z.lt min_i) may_nulls_set1 max_size1 |> MaySet.add min_i - |> MaySet.M.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) @@ -1516,7 +1522,7 @@ struct match idx_maximal size2 with | Some max_size2 -> MaySet.filter (Z.geq min_i2) may_nulls_set2' max_size2 | None -> MaySet.filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in - let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.lt (Z.add maxlen1 maxlen2) x else false) must_nulls_set1 min_size1 in + let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then (Z.add maxlen1 maxlen2) <. x else false) must_nulls_set1 min_size1 in let may_nulls_set_result = if max_size1_exists then MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 @@ -1525,7 +1531,7 @@ struct |> List.map (fun (i1, i2) -> Z.add i1 i2) |> MaySet.of_list |> MaySet.union (MaySet.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) - |> MaySet.M.filter (fun x -> if max_size1_exists then Z.gt max_size1 x else true) + |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else if not (MaySet.is_top may_nulls_set1) then MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 |> MaySet.elements @@ -1538,7 +1544,7 @@ struct ((must_nulls_set_result, may_nulls_set_result), size1) in let compute_concat (must_nulls_set2',may_nulls_set2') = - let strlen1 = to_string_length ((must_nulls_set1, may_nulls_set1), size1) in + let strlen1 = to_string_length (nulls1, size1) in let strlen2 = to_string_length ((must_nulls_set2', may_nulls_set2'), size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> @@ -1596,7 +1602,7 @@ struct match idx_maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) - if Z.lt haystack_max needle_min then + if haystack_max <. needle_min then IsNotSubstr else IsMaybeSubstr @@ -1620,7 +1626,7 @@ struct if not (Z.equal min_must1 min_must2) && Z.equal min_must1 (Nulls.min_elem Possibly nulls1) && Z.equal min_must2 (Nulls.min_elem Possibly nulls2) - && (not n_exists || Z.lt min_must1 n || Z.lt min_must2 n) + && (not n_exists || min_must1 <. n || min_must2 <. n) then (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) Idx.of_excl_list IInt [Z.zero] @@ -1634,41 +1640,42 @@ struct | None -> (* track any potential buffer overflow and issue warning if needed *) (if Nulls.is_empty Definitely nulls1 && Nulls.is_empty Possibly nulls1 then - M.error ~category:ArrayOobMessage.past_end "Array of string 1 doesn't contain a null byte: buffer overflow" + warn_past_end "Array of string 1 doesn't contain a null byte: buffer overflow" else if Nulls.is_empty Possibly nulls1 then - M.warn ~category:ArrayOobMessage.past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); + warn_past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); (if Nulls.is_empty Definitely nulls2 && Nulls.is_empty Possibly nulls2 then - M.error ~category:ArrayOobMessage.past_end "Array of string 2 doesn't contain a null byte: buffer overflow" + warn_past_end "Array of string 2 doesn't contain a null byte: buffer overflow" else if Nulls.is_empty Possibly nulls2 then - M.warn ~category:ArrayOobMessage.past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); + warn_past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); (* compute abstract value for result of strcmp *) compare Z.zero false (* strncmp *) | Some n when n >= 0 -> + let n = Z.of_int n in let min_size1 = BatOption.default Z.zero (Idx.minimal size1) in let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in (* issue a warning if n is (potentially) smaller than array sizes *) (match idx_maximal size1 with | Some max_size1 -> - if Z.gt (Z.of_int n) max_size1 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 is smaller than n bytes" - else if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes" + if n >. max_size1 then + warn_past_end"The size of the array of string 1 is smaller than n bytes" + else if n >. min_size1 then + warn_past_end "The size of the array of string 1 might be smaller than n bytes" | None -> - if Z.gt (Z.of_int n) min_size1 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 1 might be smaller than n bytes" + if n >. min_size1 then + warn_past_end "The size of the array of string 1 might be smaller than n bytes" ); (match idx_maximal size2 with | Some max_size2 -> - if Z.gt (Z.of_int n) max_size2 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 is smaller than n bytes" - else if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 might be smaller than n bytes" + if n >. max_size2 then + warn_past_end "The size of the array of string 2 is smaller than n bytes" + else if n >. min_size2 then + warn_past_end "The size of the array of string 2 might be smaller than n bytes" | None -> - if Z.gt (Z.of_int n) min_size2 then - M.warn ~category:ArrayOobMessage.past_end "The size of the array of string 2 might be smaller than n bytes"); + if n >. min_size2 then + warn_past_end "The size of the array of string 2 might be smaller than n bytes"); (* compute abstract value for result of strncmp *) - compare (Z.of_int n) true + compare n true | _ -> Idx.top_of IInt let update_length new_size (nulls, size) = (nulls, new_size) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 769b9cc485..283b15306c 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -149,7 +149,10 @@ module MustMaySet = struct let make_all_must () = (MustSet.bot (), MaySet.top ()) let make_none_may () = (MustSet.top (), MaySet.bot ()) - let may_exist f (musts, mays) = MaySet.exists f mays + let exists mode f (musts, mays) = + match mode with + | Definitely -> MustSet.exists f musts + | Possibly -> MaySet.exists f mays let forget_may (musts, mays) = (musts, MaySet.top ()) let forget_must (musts, mays) = (MustSet.top (), mays) From cd57e1faa5a70c46e249c783edcdd58d0173ca82 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 17:38:15 +0100 Subject: [PATCH 088/233] Progress --- src/cdomains/arrayDomain.ml | 89 +++++++++++++++++++------------------ 1 file changed, 45 insertions(+), 44 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 920e97982a..ae6c35a6e0 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1361,42 +1361,44 @@ struct else Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) - let string_copy (nulls1, size1) (nulls2, size2) n = - let must_nulls_set1, may_nulls_set1 = nulls1 in - let must_nulls_set2, may_nulls_set2 = nulls2 in + let string_copy (dstnulls, dstsize) ((srcnulls, srcsize) as src) n = + let must_nulls_set1, may_nulls_set1 = dstnulls in (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) - let update_sets must_nulls_set2' may_nulls_set2' size2' len2 = - match Idx.minimal size1, idx_maximal size1, Idx.minimal len2, idx_maximal len2 with - | Some min_size1, Some max_size1, Some min_len2, Some max_len2 -> - (if max_size1 <. min_len2 then + let update_sets (truncatednulls, truncatedsize) len2 = + let must_nulls_set2',may_nulls_set2' = truncatednulls in + match Idx.minimal dstsize, idx_maximal dstsize, Idx.minimal len2, idx_maximal len2 with + | Some min_dstsize, Some max_dstsize, Some min_srclen, Some max_srclen -> + (if max_dstsize <. min_srclen then warn_past_end "The length of string src is greater than the allocated size for dest" - else if min_size1 <. max_len2 then + else if min_dstsize <. max_srclen then warn_past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in (* get must nulls from src string < minimal size of dest *) - MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 + MustSet.filter (Z.gt min_dstsize) must_nulls_set2' min_size2 (* and keep indexes of dest >= maximal strlen of src *) - |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in + |> MustSet.union (MustSet.filter (Z.leq max_srclen) must_nulls_set1 min_dstsize) in let may_nulls_set_result = - let max_size2 = BatOption.default max_size1 (idx_maximal size2') in + let max_size2 = BatOption.default max_dstsize (idx_maximal truncatedsize) in (* get may nulls from src string < maximal size of dest *) - MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 + MaySet.filter (Z.gt max_dstsize) may_nulls_set2' max_size2 (* and keep indexes of dest >= minimal strlen of src *) - |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in - ((must_nulls_set_result, may_nulls_set_result), size1) + |> MaySet.union (MaySet.filter (Z.leq min_srclen) may_nulls_set1 max_dstsize) in + ((must_nulls_set_result, may_nulls_set_result), dstsize) + + | Some min_size1, None, Some min_len2, Some max_len2 -> (if min_size1 <. max_len2 then warn_past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = - let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in - ((must_nulls_set_result, may_nulls_set_result), size1) + ((must_nulls_set_result, may_nulls_set_result), dstsize) | Some min_size1, Some max_size1, Some min_len2, None -> (if max_size1 <. min_len2 then warn_past_end "The length of string src is greater than the allocated size for dest" @@ -1404,65 +1406,64 @@ struct warn_past_end"The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = - let max_size2 = BatOption.default max_size1 (idx_maximal size2') in + let max_size2 = BatOption.default max_size1 (idx_maximal truncatedsize) in MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in - ((must_nulls_set_result, may_nulls_set_result), size1) + ((must_nulls_set_result, may_nulls_set_result), dstsize) | Some min_size1, None, Some min_len2, None -> (if min_size1 <. min_len2 then warn_past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = - let min_size2 = BatOption.default Z.zero (Idx.minimal size2') in + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in - ((must_nulls_set_result, may_nulls_set_result), size1) + ((must_nulls_set_result, may_nulls_set_result), dstsize) (* any other case shouldn't happen as minimal index is always >= 0 *) - | _ -> (Nulls.top (), size1) in + | _ -> (Nulls.top (), dstsize) in (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) - let sizes_warning size2 = - (match Idx.minimal size1, idx_maximal size1, Idx.minimal size2, idx_maximal size2 with - | Some min_size1, _, Some min_size2, _ when min_size1 <. min_size2 -> - if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then + let sizes_warning srcsize = + (match Idx.minimal dstsize, idx_maximal dstsize, Idx.minimal srcsize, idx_maximal srcsize with + | Some min_dstsize, _, Some min_srcsize, _ when min_dstsize <. min_srcsize -> + if not (Nulls.exists Possibly (Z.gt min_dstsize) srcnulls) then warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" - else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then + else if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then warn_past_end "src may not contain a null byte at an index smaller than the size of dest" - | Some min_size1, _, _, Some max_size2 when min_size1 <. max_size2 -> - if not (MaySet.exists (Z.gt min_size1) may_nulls_set2) then + | Some min_dstsize, _, _, Some max_srcsize when min_dstsize <. max_srcsize -> + if not (Nulls.exists Possibly (Z.gt min_dstsize) srcnulls) then warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" - else if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then + else if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then warn_past_end "src may not contain a null byte at an index smaller than the size of dest" - | Some min_size1, _, _, None -> - if not (MustSet.exists (Z.gt min_size1) must_nulls_set2) then + | Some min_dstsize, _, _, None -> + if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then warn_past_end "src may not contain a null byte at an index smaller than the size of dest" - | _, Some max_size1, _, Some max_size2 when max_size1 <. max_size2 -> - if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then + | _, Some mac_dstsize, _, Some max_srcsize when mac_dstsize <. max_srcsize -> + if not (Nulls.exists Definitely (Z.gt mac_dstsize) srcnulls) then warn_past_end "src may not contain a null byte at an index smaller than the size of dest" - |_, Some max_size1, _, None -> - if not (MustSet.exists (Z.gt max_size1) must_nulls_set2) then + |_, Some max_dstsize, _, None -> + if not (Nulls.exists Definitely (Z.gt max_dstsize) srcnulls) then warn_past_end "src may not contain a null byte at an index smaller than the size of dest" | _ -> ()) in match n with (* strcpy *) | None -> - sizes_warning size2; - let (must_nulls_set2', may_nulls_set2'), size2' = to_string (nulls2, size2) in - let strlen2 = to_string_length (nulls2, size2) in - update_sets must_nulls_set2' may_nulls_set2' size2' strlen2 + sizes_warning srcsize; + let truncated = to_string src in + update_sets truncated (to_string_length src) (* strncpy = exactly n bytes from src are copied to dest *) | Some n when n >= 0 -> sizes_warning (Idx.of_int ILong (Z.of_int n)); - let (must_nulls_set2', may_nulls_set2'), size2' = to_n_string (nulls2, size2) n in - update_sets must_nulls_set2' may_nulls_set2' size2' (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) - | _ -> (Nulls.top (), size1) + let truncated = to_n_string src n in + update_sets truncated (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + | _ -> (Nulls.top (), dstsize) let string_concat (nulls1, size1) (nulls2, size2) n = let (must_nulls_set1, may_nulls_set1) = nulls1 in From b85ed973887968ad5bacd2fab9f296c45e7205aa Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 18:08:12 +0100 Subject: [PATCH 089/233] Progress --- src/cdomains/arrayDomain.ml | 10 +++++----- src/cdomains/nullByteSet.ml | 2 ++ 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index ae6c35a6e0..3edfb4d207 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1234,7 +1234,7 @@ struct | Some i -> build_set (i + 1) (MaySet.add (Z.of_int i) set) | None -> MaySet.add last_null set in let set = build_set 0 (MaySet.empty ()) in - ((set, set), Idx.of_int ILong (Z.succ last_null)) + (Nulls.precise_set set, Idx.of_int ILong (Z.succ last_null)) (** Returns an abstract value with at most one null byte marking the end of the string *) let to_string ((nulls, size) as x:t):t = @@ -1579,10 +1579,10 @@ struct let n = Z.of_int n in (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let nulls2' = - let (must_nulls_set2, may_nulls_set2), size2 = to_string (nulls2, size2) in - if not (MaySet.exists (Z.gt n) may_nulls_set2) then - (Nulls.precise_singleton n) - else if not (MustSet.exists (Z.gt n) must_nulls_set2) then + let ((must_nulls_set2, may_nulls_set2) as nulls2), size2 = to_string (nulls2, size2) in + if not (Nulls.exists Possibly (Z.gt n) nulls2) then + Nulls.precise_singleton n + else if not (Nulls.exists Definitely (Z.gt n) nulls2) then let max_size2 = BatOption.default (Z.succ n) (idx_maximal size2) in (MustSet.empty (), MaySet.add n (MaySet.filter (Z.geq n) may_nulls_set2 max_size2)) else diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 283b15306c..320126b517 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -146,6 +146,8 @@ module MustMaySet = struct let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) + let precise_set s = (s,s) + let make_all_must () = (MustSet.bot (), MaySet.top ()) let make_none_may () = (MustSet.top (), MaySet.bot ()) From ef3f6872fe53ba04cad1f0aa19c776621bbb9fe0 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 18:38:17 +0100 Subject: [PATCH 090/233] Pull things together --- src/cdomains/arrayDomain.ml | 64 ++++++++++++++++++++----------------- src/cdomains/nullByteSet.ml | 5 ++- 2 files changed, 39 insertions(+), 30 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 3edfb4d207..f720e2cb9b 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1006,6 +1006,7 @@ struct let (<=.) = Z.leq let (>.) = Z.gt let (>=.) = Z.geq + let (=.) = Z.equal (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod (Nulls) (Idx) @@ -1160,7 +1161,7 @@ struct Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls ) | Some max_i when max_i >=. Z.zero -> - if Z.equal min_i max_i then + if min_i =. max_i then set_exact_nulls min_i else set_interval min_i max_i @@ -1195,13 +1196,12 @@ struct min_i, None | None, None -> Z.zero, None in - let size = BatOption.map_default (fun x -> Idx.of_interval ILong (min_i, x)) (Idx.starting ILong min_i) max_i in - let nulls = match Val.is_null v with - | Null -> Nulls.make_all_must () - | NotNull -> Nulls.make_none_may () - | Top -> Nulls.top () - in - (nulls, size) + let size = BatOption.map_default (fun max -> Idx.of_interval ILong (min_i, max)) (Idx.starting ILong min_i) max_i in + match Val.is_null v with + | Null -> (Nulls.make_all_must (), size) + | NotNull -> (Nulls.empty (), size) + | Top -> (Nulls.top (), size) + let length (_, size) = Some size @@ -1248,7 +1248,7 @@ struct let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - if Z.equal min_must_null min_may_null then + if min_must_null =. min_may_null then let nulls = Nulls.precise_singleton min_must_null in (nulls, Idx.of_int ILong (Z.succ min_must_null)) (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) @@ -1257,6 +1257,8 @@ struct | Some max_size -> ((MustSet.empty (), MaySet.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls) max_size), Idx.of_int ILong (Z.succ min_must_null)) | None -> if MaySet.is_top (Nulls.get_set Possibly nulls) then + let empty = Nulls.empty () in + let rec add_indexes acc i = if i >. min_must_null then acc @@ -1281,14 +1283,14 @@ struct else add_indexes (Z.succ i) max (MaySet.add i set) in let update_must_indexes min_must_null must_nulls_set = - if Z.equal min_must_null Z.zero then + if min_must_null =. Z.zero then MustSet.bot () else (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) add_indexes min_must_null n must_nulls_set |> MustSet.M.filter (Z.gt n) in let update_may_indexes min_may_null may_nulls_set = - if Z.equal min_may_null Z.zero then + if min_may_null =. Z.zero then MaySet.top () else (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) @@ -1327,7 +1329,7 @@ struct else if Nulls.is_empty Possibly nulls then let min_may_null = Nulls.min_elem Possibly nulls in warn_no_null Z.zero false min_may_null; - if Z.equal min_may_null Z.zero then + if min_may_null =. Z.zero then Nulls.forget_may nulls else let (must, mays) = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in @@ -1338,7 +1340,7 @@ struct (* warn if resulting array may not contain null byte *) warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) - if Z.equal min_must_null min_may_null then + if min_must_null =. min_may_null then (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set) else (MustSet.top (), update_may_indexes min_may_null may_nulls_set) @@ -1466,8 +1468,7 @@ struct | _ -> (Nulls.top (), dstsize) let string_concat (nulls1, size1) (nulls2, size2) n = - let (must_nulls_set1, may_nulls_set1) = nulls1 in - let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists must_nulls_set2' may_nulls_set2' = + let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists nulls2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then warn_past_end @@ -1478,7 +1479,9 @@ struct (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) - if MustSet.is_empty must_nulls_set1 || MustSet.is_empty must_nulls_set2' then + if Nulls.is_empty Possibly nulls1 || Nulls.is_empty Possibly nulls2 then + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let (must_nulls_set2', may_nulls_set2') = nulls2' in let may_nulls_set_result = if max_size1_exists then MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 @@ -1500,9 +1503,10 @@ struct MaySet.top () in ((MustSet.top (), may_nulls_set_result), size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) - else if Z.equal (MustSet.min_elt must_nulls_set1) (MaySet.min_elt may_nulls_set1) && Z.equal (MustSet.min_elt must_nulls_set2') (MaySet.min_elt may_nulls_set2') then - let min_i1 = MustSet.min_elt must_nulls_set1 in - let min_i2 = MustSet.min_elt must_nulls_set2' in + else if Nulls.min_elem_precise (nulls1) && Nulls.min_elem_precise nulls2' then + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let min_i1 = Nulls.min_elem Definitely nulls1 in + let min_i2 = Nulls.min_elem Definitely nulls2' in let min_i = Z.add min_i1 min_i2 in let must_nulls_set_result = MustSet.filter (Z.lt min_i) must_nulls_set1 min_size1 @@ -1518,6 +1522,8 @@ struct ((must_nulls_set_result, may_nulls_set_result), size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let (must_nulls_set2', may_nulls_set2') = nulls2' in let min_i2 = MustSet.min_elt must_nulls_set2' in let may_nulls_set2'_until_min_i2 = match idx_maximal size2 with @@ -1544,27 +1550,27 @@ struct MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) in - let compute_concat (must_nulls_set2',may_nulls_set2') = + let compute_concat nulls2' = let strlen1 = to_string_length (nulls1, size1) in - let strlen2 = to_string_length ((must_nulls_set2', may_nulls_set2'), size2) in + let strlen2 = to_string_length (nulls2', size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> begin match idx_maximal size1, idx_maximal strlen1, idx_maximal strlen2 with | Some max_size1, Some maxlen1, Some maxlen2 -> - update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true nulls2' (* no upper bound for length of concatenation *) | Some max_size1, None, Some _ | Some max_size1, Some _, None | Some max_size1, None, None -> - update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false nulls2' (* no upper bound for size of dest *) | None, Some maxlen1, Some maxlen2 -> - update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true must_nulls_set2' may_nulls_set2' + update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true nulls2' (* no upper bound for size of dest and length of concatenation *) | None, None, Some _ | None, Some _, None | None, None, None -> - update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false must_nulls_set2' may_nulls_set2' + update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false nulls2' end (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (Nulls.top (), size1) in @@ -1612,7 +1618,7 @@ struct let string_comparison (nulls1, size1) (nulls2, size2) n = let compare n n_exists = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) - if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (n_exists && Z.equal Z.zero n) then + if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (n_exists && n =. Z.zero) then Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) else if Nulls.mem Definitely Z.zero nulls1 && not (Nulls.mem Possibly Z.zero nulls2) then @@ -1624,9 +1630,9 @@ struct try let min_must1 = Nulls.min_elem Definitely nulls1 in let min_must2 = Nulls.min_elem Definitely nulls2 in - if not (Z.equal min_must1 min_must2) - && Z.equal min_must1 (Nulls.min_elem Possibly nulls1) - && Z.equal min_must2 (Nulls.min_elem Possibly nulls2) + if not (min_must1 =. min_must2) + && min_must1 =.(Nulls.min_elem Possibly nulls1) + && min_must2 =. (Nulls.min_elem Possibly nulls2) && (not n_exists || min_must1 <. n || min_must2 <. n) then (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 320126b517..b1580d5717 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -78,6 +78,9 @@ module MustMaySet = struct | Definitely -> MustSet.min_elt musts | Possibly -> MaySet.min_elt mays + let min_elem_precise x = + Z.equal (min_elem Definitely x) (min_elem Possibly x) + let mem mode i (musts, mays) = match mode with | Definitely -> MustSet.mem i musts @@ -149,7 +152,7 @@ module MustMaySet = struct let precise_set s = (s,s) let make_all_must () = (MustSet.bot (), MaySet.top ()) - let make_none_may () = (MustSet.top (), MaySet.bot ()) + let empty () = (MustSet.top (), MaySet.bot ()) let exists mode f (musts, mays) = match mode with From 984165f479fdf23be021f7b04d35190d89225ab7 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 18:47:46 +0100 Subject: [PATCH 091/233] Alias for Z.add --- src/cdomains/arrayDomain.ml | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index f720e2cb9b..17bdd50a3f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1007,6 +1007,7 @@ struct let (>.) = Z.gt let (>=.) = Z.geq let (=.) = Z.equal + let (+.) = Z.add (* (Must Null Set, May Null Set, Array Size) *) include Lattice.Prod (Nulls) (Idx) @@ -1470,10 +1471,10 @@ struct let string_concat (nulls1, size1) (nulls2, size2) n = let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists nulls2' = (* track any potential buffer overflow and issue warning if needed *) - (if max_size1_exists && Z.leq max_size1 (Z.add minlen1 minlen2) then + (if max_size1_exists && max_size1 <=. (minlen1 +. minlen2) then warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (maxlen1_exists && maxlen2_exists && Z.leq min_size1 (Z.add maxlen1 maxlen2)) || not maxlen1_exists || not maxlen2_exists then + else if (maxlen1_exists && maxlen2_exists && min_size1 <=. (maxlen1 +. maxlen2)) || not maxlen1_exists || not maxlen2_exists then warn_past_end "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; @@ -1484,30 +1485,30 @@ struct let (must_nulls_set2', may_nulls_set2') = nulls2' in let may_nulls_set_result = if max_size1_exists then - MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 max_size1 |> MaySet.elements (* if may_nulls_set2' is top, limit it to max_size1 *) |> BatList.cartesian_product (MaySet.elements (MaySet.filter (fun x -> true) may_nulls_set2' max_size1)) - |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MaySet.union (MaySet.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1 max_size1) |> MaySet.M.filter (Z.gt max_size1) else if not (MaySet.is_top may_nulls_set1) && not (MaySet.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then - MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2') - |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MaySet.union (MaySet.M.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1) else MaySet.top () in ((MustSet.top (), may_nulls_set_result), size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Nulls.min_elem_precise (nulls1) && Nulls.min_elem_precise nulls2' then - let (must_nulls_set1, may_nulls_set1) = nulls1 in let min_i1 = Nulls.min_elem Definitely nulls1 in let min_i2 = Nulls.min_elem Definitely nulls2' in - let min_i = Z.add min_i1 min_i2 in + let min_i = min_i1 +. min_i2 in + let (must_nulls_set1, may_nulls_set1) = nulls1 in let must_nulls_set_result = MustSet.filter (Z.lt min_i) must_nulls_set1 min_size1 |> MustSet.add min_i @@ -1522,30 +1523,30 @@ struct ((must_nulls_set_result, may_nulls_set_result), size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else + let min_i2 = Nulls.min_elem Definitely nulls2' in let (must_nulls_set1, may_nulls_set1) = nulls1 in let (must_nulls_set2', may_nulls_set2') = nulls2' in - let min_i2 = MustSet.min_elt must_nulls_set2' in let may_nulls_set2'_until_min_i2 = match idx_maximal size2 with | Some max_size2 -> MaySet.filter (Z.geq min_i2) may_nulls_set2' max_size2 | None -> MaySet.filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in - let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then (Z.add maxlen1 maxlen2) <. x else false) must_nulls_set1 min_size1 in + let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 min_size1 in let may_nulls_set_result = if max_size1_exists then - MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 max_size1 + MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 max_size1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) - |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1 max_size1) + |> MaySet.union (MaySet.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1 max_size1) |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else if not (MaySet.is_top may_nulls_set1) then - MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then Z.leq x (Z.add maxlen1 maxlen2) else true) may_nulls_set1 + MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) - |> List.map (fun (i1, i2) -> Z.add i1 i2) + |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.M.filter (Z.lt (Z.add minlen1 minlen2)) may_nulls_set1) + |> MaySet.union (MaySet.M.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1) else MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) in From 2135296baac27aeabc5b3d48796dc6e73fc0115d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 18:51:47 +0100 Subject: [PATCH 092/233] More reuse --- src/cdomains/arrayDomain.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 17bdd50a3f..7d37396ede 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1259,13 +1259,7 @@ struct | None -> if MaySet.is_top (Nulls.get_set Possibly nulls) then let empty = Nulls.empty () in - - let rec add_indexes acc i = - if i >. min_must_null then - acc - else - add_indexes (MaySet.add i acc) (Z.succ i) in - ((MustSet.empty (), add_indexes (MaySet.empty ()) Z.zero), Idx.of_int ILong (Z.succ min_must_null)) + (Nulls.add_interval Possibly (Z.zero, min_must_null) empty, Idx.of_int ILong (Z.succ min_must_null)) else ((MustSet.empty (), MaySet.M.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls)), Idx.of_int ILong (Z.succ min_must_null)) From 34d2e1cf8f4f6bfde663ee624eda08e6d6287ec9 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 19:59:54 +0100 Subject: [PATCH 093/233] `to_string` free of direct set manipulation --- src/cdomains/arrayDomain.ml | 76 +++++++++++++++++++------------------ src/cdomains/nullByteSet.ml | 30 +++++++++------ 2 files changed, 58 insertions(+), 48 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7d37396ede..813a69d47f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1137,7 +1137,7 @@ struct (if Val.is_null v = Null && idx_maximal size = None then match idx_maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> Nulls.forget_may nulls + | None -> Nulls.add_all Possibly nulls (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) @@ -1150,11 +1150,11 @@ struct | None, None -> Nulls.top () (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) | Some min_size, None -> - let nulls = Nulls.forget_may nulls in + let nulls = Nulls.add_all Possibly nulls in Nulls.filter_musts (Z.gt min_size) min_size nulls (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) | None, Some max_size -> - let nulls = Nulls.forget_must nulls in + let nulls = Nulls.remove_all Possibly nulls in Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) | Some min_size, Some max_size -> @@ -1214,7 +1214,7 @@ struct (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) match Val.is_null (f (Val.null ())) with - | Null -> (Nulls.forget_may nulls, size) + | Null -> (Nulls.add_all Possibly nulls, size) | _ -> (Nulls.top (), size) (* else also return top for must_nulls_set *) let fold_left f acc _ = f acc (Val.top ()) @@ -1252,16 +1252,18 @@ struct if min_must_null =. min_may_null then let nulls = Nulls.precise_singleton min_must_null in (nulls, Idx.of_int ILong (Z.succ min_must_null)) - (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with - | Some max_size -> ((MustSet.empty (), MaySet.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls) max_size), Idx.of_int ILong (Z.succ min_must_null)) - | None -> - if MaySet.is_top (Nulls.get_set Possibly nulls) then - let empty = Nulls.empty () in - (Nulls.add_interval Possibly (Z.zero, min_must_null) empty, Idx.of_int ILong (Z.succ min_must_null)) - else - ((MustSet.empty (), MaySet.M.filter (Z.geq min_must_null) (Nulls.get_set Possibly nulls)), Idx.of_int ILong (Z.succ min_must_null)) + | Some max_size -> + let nulls' = Nulls.remove_all Possibly nulls in + (Nulls.filter ~max_size (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) + | None when not (Nulls.may_can_benefit_from_filter nulls) -> + let empty = Nulls.empty () in + (Nulls.add_interval Possibly (Z.zero, min_must_null) empty, Idx.of_int ILong (Z.succ min_must_null)) + | None -> + let nulls' = Nulls.remove_all Possibly nulls in + (Nulls.filter (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain @@ -1325,7 +1327,7 @@ struct let min_may_null = Nulls.min_elem Possibly nulls in warn_no_null Z.zero false min_may_null; if min_may_null =. Z.zero then - Nulls.forget_may nulls + Nulls.add_all Possibly nulls else let (must, mays) = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in (must, mays |> MaySet.M.filter (Z.gt n)) (* TODO: this makes little sense *) @@ -1372,15 +1374,15 @@ struct let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in (* get must nulls from src string < minimal size of dest *) - MustSet.filter (Z.gt min_dstsize) must_nulls_set2' min_size2 + MustSet.filter ~min_size:min_size2 (Z.gt min_dstsize) must_nulls_set2' (* and keep indexes of dest >= maximal strlen of src *) - |> MustSet.union (MustSet.filter (Z.leq max_srclen) must_nulls_set1 min_dstsize) in + |> MustSet.union (MustSet.filter ~min_size:min_dstsize (Z.leq max_srclen) must_nulls_set1) in let may_nulls_set_result = let max_size2 = BatOption.default max_dstsize (idx_maximal truncatedsize) in (* get may nulls from src string < maximal size of dest *) - MaySet.filter (Z.gt max_dstsize) may_nulls_set2' max_size2 + MaySet.filter ~max_size: max_size2 (Z.gt max_dstsize) may_nulls_set2' (* and keep indexes of dest >= minimal strlen of src *) - |> MaySet.union (MaySet.filter (Z.leq min_srclen) may_nulls_set1 max_dstsize) in + |> MaySet.union (MaySet.filter ~max_size:max_dstsize (Z.leq min_srclen) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) @@ -1389,12 +1391,12 @@ struct warn_past_end "The length of string src may be greater than the allocated size for dest"); let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in - MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 - |> MustSet.union (MustSet.filter (Z.leq max_len2) must_nulls_set1 min_size1) in + MustSet.filter ~min_size: min_size2 (Z.gt min_size1) must_nulls_set2' + |> MustSet.union (MustSet.filter ~min_size:min_size1 (Z.leq max_len2) must_nulls_set1) in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' - |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) | Some min_size1, Some max_size1, Some min_len2, None -> (if max_size1 <. min_len2 then @@ -1404,11 +1406,11 @@ struct (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in - MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in + MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in let may_nulls_set_result = let max_size2 = BatOption.default max_size1 (idx_maximal truncatedsize) in - MaySet.filter (Z.gt max_size1) may_nulls_set2' max_size2 - |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 max_size1) in + MaySet.filter ~max_size:max_size2 (Z.gt max_size1) may_nulls_set2' + |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.leq min_len2) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) | Some min_size1, None, Some min_len2, None -> (if min_size1 <. min_len2 then @@ -1416,11 +1418,11 @@ struct (* do not keep any index of dest as no maximal strlen of src *) let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in - MustSet.filter (Z.gt min_size1) must_nulls_set2' min_size2 in + MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' - |> MaySet.union (MaySet.filter (Z.leq min_len2) may_nulls_set1 (Z.succ min_len2)) in + |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (Nulls.top (), dstsize) in @@ -1479,13 +1481,13 @@ struct let (must_nulls_set2', may_nulls_set2') = nulls2' in let may_nulls_set_result = if max_size1_exists then - MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 max_size1 + MaySet.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements (* if may_nulls_set2' is top, limit it to max_size1 *) - |> BatList.cartesian_product (MaySet.elements (MaySet.filter (fun x -> true) may_nulls_set2' max_size1)) + |> BatList.cartesian_product (MaySet.elements (MaySet.filter ~max_size:max_size1 (fun x -> true) may_nulls_set2')) |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1 max_size1) + |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) |> MaySet.M.filter (Z.gt max_size1) else if not (MaySet.is_top may_nulls_set1) && not (MaySet.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 @@ -1504,12 +1506,12 @@ struct let min_i = min_i1 +. min_i2 in let (must_nulls_set1, may_nulls_set1) = nulls1 in let must_nulls_set_result = - MustSet.filter (Z.lt min_i) must_nulls_set1 min_size1 + MustSet.filter ~min_size:min_size1 (Z.lt min_i) must_nulls_set1 |> MustSet.add min_i |> MustSet.M.filter (Z.gt min_size1) in let may_nulls_set_result = if max_size1_exists then - MaySet.filter (Z.lt min_i) may_nulls_set1 max_size1 + MaySet.filter ~max_size:max_size1 (Z.lt min_i) may_nulls_set1 |> MaySet.add min_i |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else @@ -1522,17 +1524,17 @@ struct let (must_nulls_set2', may_nulls_set2') = nulls2' in let may_nulls_set2'_until_min_i2 = match idx_maximal size2 with - | Some max_size2 -> MaySet.filter (Z.geq min_i2) may_nulls_set2' max_size2 - | None -> MaySet.filter (Z.geq min_i2) may_nulls_set2' (Z.succ min_i2) in - let must_nulls_set_result = MustSet.filter (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 min_size1 in + | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' + | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in + let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 in let may_nulls_set_result = if max_size1_exists then - MaySet.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 max_size1 + MaySet.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list - |> MaySet.union (MaySet.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1 max_size1) + |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else if not (MaySet.is_top may_nulls_set1) then MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 @@ -1585,11 +1587,11 @@ struct Nulls.precise_singleton n else if not (Nulls.exists Definitely (Z.gt n) nulls2) then let max_size2 = BatOption.default (Z.succ n) (idx_maximal size2) in - (MustSet.empty (), MaySet.add n (MaySet.filter (Z.geq n) may_nulls_set2 max_size2)) + (MustSet.empty (), MaySet.add n (MaySet.filter ~max_size:max_size2 (Z.geq n) may_nulls_set2)) else let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in let max_size2 = BatOption.default n (idx_maximal size2) in - (MustSet.filter (Z.gt n) must_nulls_set2 min_size2, MaySet.filter (Z.gt n) may_nulls_set2 max_size2) + (MustSet.filter ~min_size: min_size2 (Z.gt n) must_nulls_set2, MaySet.filter ~max_size:max_size2 (Z.gt n) may_nulls_set2) in compute_concat nulls2' | _ -> (Nulls.top (), size1) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index b1580d5717..b704b9fee0 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -12,9 +12,11 @@ module MustSet = struct else M.remove i must_nulls_set - let filter cond must_nulls_set min_size = + let filter ?min_size cond must_nulls_set = if M.is_bot must_nulls_set then - M.filter cond (compute_set min_size) + match min_size with + | Some min_size -> M.filter cond (compute_set min_size) + | _ -> M.empty () else M.filter cond must_nulls_set @@ -50,9 +52,11 @@ module MaySet = struct else M.remove i may_nulls_set - let filter cond may_nulls_set max_size = + let filter ?max_size cond may_nulls_set = if M.is_top may_nulls_set then - M.filter cond (MustSet.compute_set max_size) + match max_size with + | Some max_size -> M.filter cond (MustSet.compute_set max_size) + | _ -> may_nulls_set else M.filter cond may_nulls_set @@ -68,6 +72,8 @@ module MustMaySet = struct type mode = Definitely | Possibly + let empty () = (MustSet.top (), MaySet.bot ()) + let is_empty mode (musts, mays) = match mode with | Definitely -> MaySet.is_empty mays @@ -124,7 +130,7 @@ module MustMaySet = struct if Z.equal l Z.zero && Z.geq u min_size then (MustSet.top (), mays) else - (MustSet.filter (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts min_size, mays) + (MustSet.filter ~min_size (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts, mays) let add_all mode (musts, mays) = match mode with @@ -133,8 +139,8 @@ module MustMaySet = struct let remove_all mode (musts, mays) = match mode with - | Definitely -> (MustSet.top (), mays) - | Possibly -> failwith "todo" + | Possibly -> (MustSet.top (), mays) + | Definitely -> empty () let is_full_set mode (musts, mays) = match mode with @@ -152,14 +158,16 @@ module MustMaySet = struct let precise_set s = (s,s) let make_all_must () = (MustSet.bot (), MaySet.top ()) - let empty () = (MustSet.top (), MaySet.bot ()) + + let may_can_benefit_from_filter (musts, mays) = not (MaySet.is_top mays) let exists mode f (musts, mays) = match mode with | Definitely -> MustSet.exists f musts | Possibly -> MaySet.exists f mays - let forget_may (musts, mays) = (musts, MaySet.top ()) - let forget_must (musts, mays) = (MustSet.top (), mays) - let filter_musts f min_size (musts, mays) = (MustSet.filter f musts min_size, mays) + let filter ?min_size ?max_size f (must, mays):t = + (MustSet.filter ?min_size f must, MaySet.filter ?max_size f mays) + + let filter_musts f min_size (musts, mays) = (MustSet.filter ~min_size f musts, mays) end From df10ad6dc5c03b547c743ee81dc91808863895e2 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 26 Nov 2023 21:01:38 +0100 Subject: [PATCH 094/233] Move to operations on Nulls --- src/cdomains/arrayDomain.ml | 48 +++++++++++++++++++++---------------- src/cdomains/nullByteSet.ml | 19 +++++++++++++++ 2 files changed, 46 insertions(+), 21 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 813a69d47f..8f966d0fad 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1380,7 +1380,7 @@ struct let may_nulls_set_result = let max_size2 = BatOption.default max_dstsize (idx_maximal truncatedsize) in (* get may nulls from src string < maximal size of dest *) - MaySet.filter ~max_size: max_size2 (Z.gt max_dstsize) may_nulls_set2' + MaySet.filter ~max_size:max_size2 (Z.gt max_dstsize) may_nulls_set2' (* and keep indexes of dest >= minimal strlen of src *) |> MaySet.union (MaySet.filter ~max_size:max_dstsize (Z.leq min_srclen) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) @@ -1477,28 +1477,34 @@ struct * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) if Nulls.is_empty Possibly nulls1 || Nulls.is_empty Possibly nulls2 then - let (must_nulls_set1, may_nulls_set1) = nulls1 in - let (must_nulls_set2', may_nulls_set2') = nulls2' in - let may_nulls_set_result = - if max_size1_exists then - MaySet.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 - |> MaySet.elements - (* if may_nulls_set2' is top, limit it to max_size1 *) - |> BatList.cartesian_product (MaySet.elements (MaySet.filter ~max_size:max_size1 (fun x -> true) may_nulls_set2')) + if max_size1_exists then + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) + |> Nulls.elements ~max_size:max_size1 Possibly + |> BatList.cartesian_product (Nulls.elements ~max_size:max_size1 Possibly nulls2') |> List.map (fun (i1, i2) -> i1 +. i2) - |> MaySet.of_list - |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) - |> MaySet.M.filter (Z.gt max_size1) - else if not (MaySet.is_top may_nulls_set1) && not (MaySet.is_top may_nulls_set2') && maxlen1_exists && maxlen2_exists then - MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 - |> MaySet.elements - |> BatList.cartesian_product (MaySet.elements may_nulls_set2') + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + |> Nulls.filter (Z.gt max_size1) + in + (r, size1) + else if Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 && maxlen1_exists && maxlen2_exists then + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) + |> Nulls.elements Possibly + |> BatList.cartesian_product (Nulls.elements Possibly nulls2') |> List.map (fun (i1, i2) -> i1 +. i2) - |> MaySet.of_list - |> MaySet.union (MaySet.M.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1) - else - MaySet.top () in - ((MustSet.top (), may_nulls_set_result), size1) + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + in + (r, size1) + else + (Nulls.top (), size1) + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Nulls.min_elem_precise (nulls1) && Nulls.min_elem_precise nulls2' then let min_i1 = Nulls.min_elem Definitely nulls1 in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index b704b9fee0..54284f6ab5 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -46,6 +46,14 @@ module MaySet = struct module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) include M + let elements ?max_size may_nulls_set = + if M.is_top may_nulls_set then + match max_size with + | Some max_size -> M.elements @@ MustSet.compute_set max_size + | _ -> failwith "top and no max size supplied" + else + M.elements may_nulls_set + let remove i may_nulls_set max_size = if M.is_top may_nulls_set then M.remove i (MustSet.compute_set max_size) @@ -107,6 +115,11 @@ module MustMaySet = struct | Definitely -> (MustSet.add i musts, MaySet.add i mays) | Possibly -> (musts, MaySet.add i mays) + let add_list mode l (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> (musts, MaySet.union (MaySet.of_list l) mays) + let add_interval ?maxfull mode (l,u) (musts, mays) = match mode with | Definitely -> failwith "todo" @@ -152,6 +165,12 @@ module MustMaySet = struct | Definitely -> musts | Possibly -> mays + let elements ?max_size ?min_size mode (musts, mays) = + match mode with + | Definitely ->failwith "todo" + | Possibly -> MaySet.elements ?max_size mays + + let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) From 0e64a8f2abff122c78e5fbea2d3f338ee73db7fe Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:36:24 +0200 Subject: [PATCH 095/233] Fix old indentation in YamlWitness --- src/witness/yamlWitness.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 635ba4ad72..253ee5eecd 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -136,9 +136,9 @@ struct let precondition_loop_invariant_certificate ~target ~(certification): Entry.t = { entry_type = PreconditionLoopInvariantCertificate { - target; - certification; - }; + target; + certification; + }; metadata = metadata (); } end From 778d8838b2ae77a4673869c430b77eb764895ac8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:36:32 +0200 Subject: [PATCH 096/233] Fix indentation in MemLeak --- src/analyses/memLeak.ml | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 05e18e2e39..1253cd6763 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -205,12 +205,12 @@ struct | Malloc _ | Calloc _ | Realloc _ -> - (ctx.sideg () true; + ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> ToppedVarInfoSet.add var state | _ -> state - end) + end | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with | ad when (not (Queries.AD.is_top ad)) && Queries.AD.cardinal ad = 1 -> @@ -233,16 +233,15 @@ struct | a when Queries.ID.is_bot a -> M.warn ~category:Assert "assert expression %a is bottom" d_exp exp | a -> begin match Queries.ID.to_bool a with - | Some b -> ( + | Some b -> (* If we know for sure that the expression in "assert" is false => need to check for memory leaks *) - if b = false then ( - warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx - ) - else ()) + if b = false then ( + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx + ) | None -> - (warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp)) + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) end in warn_for_assert_exp; From 00e1685c0af89cf5f6c3a968211e1d1d4bb3081d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 13:12:21 +0200 Subject: [PATCH 097/233] Generalize abs invariant in base --- src/analyses/baseInvariant.ml | 36 ++++++++--------------------------- 1 file changed, 8 insertions(+), 28 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f391231628..0e02d38f6f 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -726,9 +726,16 @@ struct | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Islessequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Le, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Islessgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (LOr, (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))), (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))), (TInt (IBool, [])))) st + | `Lifted (Abs (_ik, xInt)) -> + inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) + | _ -> update_lval c x c' ID.pretty + end + | None -> + begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + | `Lifted (Abs (_ik, xInt)) -> + inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) | _ -> update_lval c x c' ID.pretty end - | None -> update_lval c x c' ID.pretty end | _ -> update_lval c x c' ID.pretty end @@ -821,31 +828,4 @@ struct FD.top_of fk in inv_exp (Float ftv) exp st - - let invariant ctx a gs st exp tv: D.t = - let refine0 = invariant ctx a gs st exp tv in - (* bodge for abs(...); To be removed once we have a clean solution *) - let refineAbs op absargexp valexp = - let flip op = match op with | Le -> Ge | Lt -> Gt | _ -> failwith "impossible" in - (* e.g. |arg| <= 40 *) - (* arg <= e (arg <= 40) *) - let le = BinOp (op, absargexp, valexp, intType) in - (* arg >= -e (arg >= -40) *) - let gt = BinOp(flip op, absargexp, UnOp (Neg, valexp, Cilfacade.typeOf valexp), intType) in - let one = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global refine0 le tv in - invariant ctx (Analyses.ask_of_ctx ctx) ctx.global one gt tv - in - match exp with - | BinOp ((Lt|Le) as op, CastE(t, Lval (Var v, NoOffset)), e,_) when tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil NoOffset)) with - | `Lifted (Abs (ik, arg)) -> refineAbs op (CastE (t, arg)) e - | _ -> refine0 - end - | BinOp ((Lt|Le) as op, Lval (Var v, NoOffset), e, _) when tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil NoOffset)) with - | `Lifted (Abs (ik, arg)) -> refineAbs op arg e - | _ -> refine0 - end - | _ -> refine0 - end From d3b73fa4d1bed6574227007b1cd54778368daa6b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 13:28:19 +0200 Subject: [PATCH 098/233] Deduplicate Abs cases in BaseInvariant --- src/analyses/baseInvariant.ml | 40 +++++++++++++++++------------------ 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 0e02d38f6f..974439d826 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -714,27 +714,25 @@ struct begin match x with | ((Var v), offs) -> if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - let tv_opt = ID.to_bool c in - begin match tv_opt with - | Some tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with - | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st - | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st - (* should be correct according to C99 standard*) - | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Islessequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Le, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Islessgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (LOr, (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))), (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))), (TInt (IBool, [])))) st - | `Lifted (Abs (_ik, xInt)) -> - inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) - | _ -> update_lval c x c' ID.pretty - end - | None -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with - | `Lifted (Abs (_ik, xInt)) -> - inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) - | _ -> update_lval c x c' ID.pretty + begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + | `Lifted (Abs (_ik, xInt)) -> + inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) + | tmpSpecial -> + let tv_opt = ID.to_bool c in (* TODO: simplify *) + begin match tv_opt with + | Some tv -> + begin match tmpSpecial with + | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st + | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st + (* should be correct according to C99 standard*) + | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Islessequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Le, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Islessgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (LOr, (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))), (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))), (TInt (IBool, [])))) st + | _ -> update_lval c x c' ID.pretty + end + | None -> update_lval c x c' ID.pretty end end | _ -> update_lval c x c' ID.pretty From a82266729858c7e67c16348d8798ff0a35c3ee31 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 13:32:14 +0200 Subject: [PATCH 099/233] Reduce tmpSpecial nested matching in BaseInvariant --- src/analyses/baseInvariant.ml | 76 ++++++++++++++++------------------- 1 file changed, 34 insertions(+), 42 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 974439d826..dc4dff540a 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -709,35 +709,31 @@ struct | _ -> Int c in (* handle special calls *) - begin match t with - | TInt (ik, _) -> - begin match x with - | ((Var v), offs) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with - | `Lifted (Abs (_ik, xInt)) -> - inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) - | tmpSpecial -> - let tv_opt = ID.to_bool c in (* TODO: simplify *) - begin match tv_opt with - | Some tv -> - begin match tmpSpecial with - | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st - | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st - (* should be correct according to C99 standard*) - | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Islessequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Le, xFloat, yFloat, (typeOf xFloat))) st - | `Lifted (Islessgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (LOr, (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))), (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))), (TInt (IBool, [])))) st - | _ -> update_lval c x c' ID.pretty - end - | None -> update_lval c x c' ID.pretty + begin match x, t with + | (Var v, offs), TInt (ik, _) -> + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); + begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + | `Lifted (Abs (_ik, xInt)) -> + inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) + | tmpSpecial -> + let tv_opt = ID.to_bool c in (* TODO: simplify *) + begin match tv_opt with + | Some tv -> + begin match tmpSpecial with + | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st + | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st + (* should be correct according to C99 standard*) + | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Islessequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Le, xFloat, yFloat, (typeOf xFloat))) st + | `Lifted (Islessgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (LOr, (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))), (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))), (TInt (IBool, [])))) st + | _ -> update_lval c x c' ID.pretty end + | None -> update_lval c x c' ID.pretty end - | _ -> update_lval c x c' ID.pretty end - | _ -> update_lval c x c' ID.pretty + | _, _ -> update_lval c x c' ID.pretty end | Float c -> let c' = match t with @@ -749,22 +745,18 @@ struct | _ -> Float c in (* handle special calls *) - begin match t with - | TFloat (fk, _) -> - begin match x with - | ((Var v), offs) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with - | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st - | `Lifted (Floor (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_floor (FD.cast_to ret_fk c))) xFloat st - | `Lifted (Fabs (ret_fk, xFloat)) -> - let inv = FD.inv_fabs (FD.cast_to ret_fk c) in - if FD.is_bot inv then - raise Analyses.Deadcode - else - inv_exp (Float inv) xFloat st - | _ -> update_lval c x c' FD.pretty - end + begin match x, t with + | (Var v, offs), TFloat (fk, _) -> + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); + begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st + | `Lifted (Floor (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_floor (FD.cast_to ret_fk c))) xFloat st + | `Lifted (Fabs (ret_fk, xFloat)) -> + let inv = FD.inv_fabs (FD.cast_to ret_fk c) in + if FD.is_bot inv then + raise Analyses.Deadcode + else + inv_exp (Float inv) xFloat st | _ -> update_lval c x c' FD.pretty end | _ -> update_lval c x c' FD.pretty From b2d65f11380f023f73e7af0a0349e9c1d176a99b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 13:34:07 +0200 Subject: [PATCH 100/233] Deduplicate TmpSpecial query in BaseInvariant --- src/analyses/baseInvariant.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index dc4dff540a..0d79aa8969 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -711,8 +711,9 @@ struct (* handle special calls *) begin match x, t with | (Var v, offs), TInt (ik, _) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty tmpSpecial; + begin match tmpSpecial with | `Lifted (Abs (_ik, xInt)) -> inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) | tmpSpecial -> @@ -747,8 +748,9 @@ struct (* handle special calls *) begin match x, t with | (Var v, offs), TFloat (fk, _) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty tmpSpecial; + begin match tmpSpecial with | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st | `Lifted (Floor (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_floor (FD.cast_to ret_fk c))) xFloat st | `Lifted (Fabs (ret_fk, xFloat)) -> From 1730aa71eaa6ba4dfcf6492f3bdf79eeb677f54b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 14:03:50 +0200 Subject: [PATCH 101/233] Remove BaseInvariant tmpSpecial TODOs --- src/analyses/baseInvariant.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 0d79aa8969..304d3e55ad 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -714,16 +714,17 @@ struct let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty tmpSpecial; begin match tmpSpecial with - | `Lifted (Abs (_ik, xInt)) -> - inv_exp (Int (ID.join c (ID.neg c))) xInt st (* TODO: deduplicate *) + | `Lifted (Abs (ik, xInt)) -> + let c' = ID.cast_to ik c in (* different ik! *) + inv_exp (Int (ID.join c' (ID.neg c'))) xInt st | tmpSpecial -> - let tv_opt = ID.to_bool c in (* TODO: simplify *) - begin match tv_opt with + begin match ID.to_bool c with | Some tv -> begin match tmpSpecial with | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st (* should be correct according to C99 standard*) + (* The following do to_bool and of_bool to convert Not{0} into 1 for downstream float inversions *) | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st From 209a5607204f960a0de6d6d7f81c754354306211 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 27 Nov 2023 15:18:49 +0100 Subject: [PATCH 102/233] Reduce activated analsyses and add test --- tests/regression/74-invalid_deref/31-multithreaded.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/regression/74-invalid_deref/31-multithreaded.c b/tests/regression/74-invalid_deref/31-multithreaded.c index e0dc146ba8..8a0c12350b 100644 --- a/tests/regression/74-invalid_deref/31-multithreaded.c +++ b/tests/regression/74-invalid_deref/31-multithreaded.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.activated[+] useAfterFree --set ana.activated[+] threadJoins --set ana.path_sens[+] threadflag --set ana.activated[+] memOutOfBounds --enable ana.int.interval --set ana.base.arrays.domain partitioned --set ana.base.privatization mutex-meet-tid +//PARAM: --set ana.path_sens[+] threadflag --set ana.activated[+] memOutOfBounds --set ana.base.privatization mutex-meet-tid #include int data; @@ -15,7 +15,7 @@ int main() { pthread_create(&id, ((void *)0), t_fun, ((void *)0)); q = p; pthread_mutex_lock(&mutex); - *q = 8; + *q = 8; //NOWARN pthread_mutex_unlock(&mutex); return 0; } From 6b1dce9ab0faf763cf3f2d12e4de8bc0a27f2aa1 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 28 Nov 2023 11:11:39 +0200 Subject: [PATCH 103/233] Fix tracing call in base --- src/analyses/base.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index bdae887b4a..7c741e227e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1486,7 +1486,7 @@ struct Priv.read_global a priv_getg st x in let new_value = update_offset old_value in - M.tracel "hgh" "update_offset %a -> %a\n" VD.pretty old_value VD.pretty new_value; + if M.tracing then M.tracel "set" "update_offset %a -> %a\n" VD.pretty old_value VD.pretty new_value; let r = Priv.write_global ~invariant a priv_getg (priv_sideg ctx.sideg) st x new_value in if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: updated a global var '%s' \nstate:%a\n\n" x.vname D.pretty r; r From cdf0dee88bccfbb623a914e37e5fd9264de8bef3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 28 Nov 2023 11:16:21 +0200 Subject: [PATCH 104/233] Add test for general abs refinement --- tests/regression/39-signed-overflows/06-abs.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/regression/39-signed-overflows/06-abs.c b/tests/regression/39-signed-overflows/06-abs.c index e56cc9ff7d..1323434cbc 100644 --- a/tests/regression/39-signed-overflows/06-abs.c +++ b/tests/regression/39-signed-overflows/06-abs.c @@ -17,6 +17,13 @@ int main() { __goblint_check(-100 <= data); int result = data * data; //NOWARN } + + if(abs(data) - 1 <= 99) + { + __goblint_check(data <= 100); + __goblint_check(-100 <= data); + int result = data * data; //NOWARN + } } return 8; } \ No newline at end of file From deb12f492905a3d849fe746ca203f78c4610a0dc Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 28 Nov 2023 13:01:48 +0200 Subject: [PATCH 105/233] Suppress no-cmx-file warning --- src/build-info/dune | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/build-info/dune b/src/build-info/dune index c1de250263..ff8d68671b 100644 --- a/src/build-info/dune +++ b/src/build-info/dune @@ -27,3 +27,6 @@ (mode (promote (until-clean) (only configOcaml.ml))) ; replace existing file in source tree, even if releasing (only overrides) (action (write-file %{target} "(* Automatically regenerated, changes do not persist! *)\nlet flambda = \"%{ocaml-config:flambda}\""))) +(env + (_ + (flags (:standard -w -no-cmx-file)))) ; suppress warning from flambda compiler bug: https://github.com/ocaml/dune/issues/3277 From 1a0fdb98421a8712ccd51256ec8f116c467db51b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 17:09:33 +0100 Subject: [PATCH 106/233] Annotate faialing test as TODO --- tests/regression/73-strings/09-malloc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/regression/73-strings/09-malloc.c b/tests/regression/73-strings/09-malloc.c index 913ec821c0..a050032885 100644 --- a/tests/regression/73-strings/09-malloc.c +++ b/tests/regression/73-strings/09-malloc.c @@ -11,6 +11,6 @@ int main () { s2[0] = 'a'; // Use size_t to avoid integer warnings hiding the lack of string warnings - size_t len1 = strlen(s1); //WARN + size_t len1 = strlen(s1); //TODO size_t len2 = strlen(s2); //WARN } From 2b8e3faaddde24ab8e767d097f133d0dfde38344 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 18:18:49 +0100 Subject: [PATCH 107/233] Simplify --- src/cdomains/arrayDomain.ml | 149 ++++++++++++++++------------------- src/cdomains/arrayDomain.mli | 24 +++--- src/cdomains/valueDomain.ml | 14 ++-- 3 files changed, 87 insertions(+), 100 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 8f966d0fad..00d9107211 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -74,7 +74,7 @@ module type Str = sig include S0 - type ret = Null | NotNull | Top + type ret = Null | NotNull | Maybe type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret @@ -95,7 +95,7 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end -module type LatticeWithInvalidate = +module type LatticeWithInvalidate = sig include Lattice.S val invalidate_abstract_value: t -> t @@ -112,10 +112,10 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps + type retnull = Null | NotNull | Maybe val null: unit -> t - val is_null: t -> bool - val is_not_null: t -> bool + val is_null: t -> retnull val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t @@ -1016,18 +1016,7 @@ struct type idx = Idx.t type value = Val.t - type ret = Null | NotNull | Top - module Val = struct - include Val - - let is_null v = - if is_not_null v then - NotNull - else if is_null v then - Null - else - Top - end + type ret = Null | NotNull | Maybe type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr @@ -1056,7 +1045,7 @@ struct NotNull (* ... else return Top *) else - Top + Maybe (* if there is no maximum size *) | Some max_i, None when max_i >=. Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) @@ -1066,7 +1055,7 @@ struct else if not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then NotNull else - Top + Maybe | Some max_i, Some max_size when max_i >=. Z.zero -> (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) if max_i <. min_size && Nulls.interval_mem Definitely (min_i, max_i) nulls then @@ -1075,9 +1064,9 @@ struct else if max_i <. max_size && not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then NotNull else - Top + Maybe (* if maximum number in interval is invalid, i.e. negative, return Top of value *) - | _ -> Top + | _ -> Maybe let set (ask: VDQ.t) (nulls, size) (e, i) v = let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in @@ -1089,7 +1078,7 @@ struct let set_exact_nulls i = match idx_maximal size with (* if size has no upper limit *) - | None -> + | None -> (match Val.is_null v with | NotNull -> Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size @@ -1098,7 +1087,7 @@ struct Nulls.add (if i <. min_size then Definitely else Possibly) i nulls (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) (* i >= minimal size and value = null, add i only to may_nulls_set *) - | Top -> + | Maybe -> let removed = Nulls.remove Possibly i nulls min_size in Nulls.add Possibly i removed) | Some max_size -> @@ -1110,7 +1099,7 @@ struct Nulls.add Definitely i nulls | Null when i <. max_size -> Nulls.add Possibly i nulls - | Top when i <. max_size -> + | Maybe when i <. max_size -> let removed = Nulls.remove Possibly i nulls min_size in Nulls.add Possibly i removed | _ -> nulls @@ -1123,9 +1112,9 @@ struct match Val.is_null v with | NotNull -> Nulls.remove_interval Possibly (min_i, max_i) min_size nulls | Null -> Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls - | Top -> + | Maybe -> let nulls = Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls in - Nulls.remove_interval Possibly (min_i, max_i) min_size nulls + Nulls.remove_interval Possibly (min_i, max_i) min_size nulls in (* warn if index is (potentially) out of bounds *) @@ -1141,7 +1130,7 @@ struct (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) - else if Val.is_not_null v then + else if Val.is_null v = NotNull then Nulls.filter_musts (Z.gt min_i) min_size nulls (*..., value unknown *) else @@ -1149,15 +1138,15 @@ struct (* ... and size unknown, modify both sets to top *) | None, None -> Nulls.top () (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) - | Some min_size, None -> + | Some min_size, None -> let nulls = Nulls.add_all Possibly nulls in Nulls.filter_musts (Z.gt min_size) min_size nulls (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) - | None, Some max_size -> + | None, Some max_size -> let nulls = Nulls.remove_all Possibly nulls in Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) - | Some min_size, Some max_size -> + | Some min_size, Some max_size -> let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls ) @@ -1169,7 +1158,7 @@ struct (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) | _ -> nulls in - (nulls, size) + (nulls, size) let make ?(varAttr=[]) ?(typAttr=[]) i v = @@ -1195,13 +1184,13 @@ struct Z.zero, None) else min_i, None - | None, None -> Z.zero, None + | None, None -> Z.zero, None in let size = BatOption.map_default (fun max -> Idx.of_interval ILong (min_i, max)) (Idx.starting ILong min_i) max_i in match Val.is_null v with | Null -> (Nulls.make_all_must (), size) | NotNull -> (Nulls.empty (), size) - | Top -> (Nulls.top (), size) + | Maybe -> (Nulls.top (), size) let length (_, size) = Some size @@ -1211,7 +1200,7 @@ struct let get_vars_in_e _ = [] let map f (nulls, size) = - (* if f(null) = null, all values in must_nulls_set still are surely null; + (* if f(null) = null, all values in must_nulls_set still are surely null; * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) match Val.is_null (f (Val.null ())) with | Null -> (Nulls.add_all Possibly nulls, size) @@ -1227,7 +1216,7 @@ struct let to_null_byte_domain s = let last_null = Z.of_int (String.length s) in - let rec build_set i set = + let rec build_set i set = if (Z.of_int i) >=. last_null then MaySet.add last_null set else @@ -1255,7 +1244,7 @@ struct (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match idx_maximal size with - | Some max_size -> + | Some max_size -> let nulls' = Nulls.remove_all Possibly nulls in (Nulls.filter ~max_size (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) | None when not (Nulls.may_can_benefit_from_filter nulls) -> @@ -1266,7 +1255,7 @@ struct (Nulls.filter (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) (** [to_n_string index_set n] returns an abstract value with a potential null byte - * marking the end of the string and if needed followed by further null bytes to obtain + * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) let to_n_string (nulls, size) n:t = let must_nulls_set, may_nulls_set = nulls in @@ -1312,16 +1301,16 @@ struct if n >. max_size then warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" | None, None -> ()); - let nulls = + let nulls = (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) if Nulls.is_empty Definitely nulls then - (warn_past_end + (warn_past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; match idx_maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls | _ -> nulls) - (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; + (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; * warn as in any case, resulting array not guaranteed to contain null byte *) else if Nulls.is_empty Possibly nulls then let min_may_null = Nulls.min_elem Possibly nulls in @@ -1367,44 +1356,44 @@ struct let must_nulls_set2',may_nulls_set2' = truncatednulls in match Idx.minimal dstsize, idx_maximal dstsize, Idx.minimal len2, idx_maximal len2 with | Some min_dstsize, Some max_dstsize, Some min_srclen, Some max_srclen -> - (if max_dstsize <. min_srclen then - warn_past_end "The length of string src is greater than the allocated size for dest" + (if max_dstsize <. min_srclen then + warn_past_end "The length of string src is greater than the allocated size for dest" else if min_dstsize <. max_srclen then warn_past_end "The length of string src may be greater than the allocated size for dest"); - let must_nulls_set_result = + let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in (* get must nulls from src string < minimal size of dest *) MustSet.filter ~min_size:min_size2 (Z.gt min_dstsize) must_nulls_set2' (* and keep indexes of dest >= maximal strlen of src *) |> MustSet.union (MustSet.filter ~min_size:min_dstsize (Z.leq max_srclen) must_nulls_set1) in - let may_nulls_set_result = + let may_nulls_set_result = let max_size2 = BatOption.default max_dstsize (idx_maximal truncatedsize) in (* get may nulls from src string < maximal size of dest *) MaySet.filter ~max_size:max_size2 (Z.gt max_dstsize) may_nulls_set2' (* and keep indexes of dest >= minimal strlen of src *) |> MaySet.union (MaySet.filter ~max_size:max_dstsize (Z.leq min_srclen) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) - + | Some min_size1, None, Some min_len2, Some max_len2 -> (if min_size1 <. max_len2 then warn_past_end "The length of string src may be greater than the allocated size for dest"); - let must_nulls_set_result = + let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter ~min_size: min_size2 (Z.gt min_size1) must_nulls_set2' |> MustSet.union (MustSet.filter ~min_size:min_size1 (Z.leq max_len2) must_nulls_set1) in - let may_nulls_set_result = + let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) | Some min_size1, Some max_size1, Some min_len2, None -> - (if max_size1 <. min_len2 then - warn_past_end "The length of string src is greater than the allocated size for dest" + (if max_size1 <. min_len2 then + warn_past_end "The length of string src is greater than the allocated size for dest" else if min_size1 <. min_len2 then warn_past_end"The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) - let must_nulls_set_result = + let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in let may_nulls_set_result = @@ -1416,10 +1405,10 @@ struct (if min_size1 <. min_len2 then warn_past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) - let must_nulls_set_result = + let must_nulls_set_result = let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in - let may_nulls_set_result = + let may_nulls_set_result = (* get all may nulls from src string as no maximal size of dest *) may_nulls_set2' |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in @@ -1465,21 +1454,21 @@ struct | _ -> (Nulls.top (), dstsize) let string_concat (nulls1, size1) (nulls2, size2) n = - let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists nulls2' = + let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists nulls2' = (* track any potential buffer overflow and issue warning if needed *) (if max_size1_exists && max_size1 <=. (minlen1 +. minlen2) then warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" else if (maxlen1_exists && maxlen2_exists && min_size1 <=. (maxlen1 +. maxlen2)) || not maxlen1_exists || not maxlen2_exists then - warn_past_end + warn_past_end "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); - (* if any must_nulls_set empty, result must_nulls_set also empty; + (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) if Nulls.is_empty Possibly nulls1 || Nulls.is_empty Possibly nulls2 then if max_size1_exists then let nulls1_no_must = Nulls.remove_all Possibly nulls1 in - let r = + let r = nulls1_no_must (* filter ensures we have the concete representation *) |> Nulls.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) @@ -1488,11 +1477,11 @@ struct |> List.map (fun (i1, i2) -> i1 +. i2) |> (fun x -> Nulls.add_list Possibly x (Nulls.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) |> Nulls.filter (Z.gt max_size1) - in + in (r, size1) else if Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 && maxlen1_exists && maxlen2_exists then let nulls1_no_must = Nulls.remove_all Possibly nulls1 in - let r = + let r = nulls1_no_must (* filter ensures we have the concete representation *) |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) @@ -1500,7 +1489,7 @@ struct |> BatList.cartesian_product (Nulls.elements Possibly nulls2') |> List.map (fun (i1, i2) -> i1 +. i2) |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) - in + in (r, size1) else (Nulls.top (), size1) @@ -1511,15 +1500,15 @@ struct let min_i2 = Nulls.min_elem Definitely nulls2' in let min_i = min_i1 +. min_i2 in let (must_nulls_set1, may_nulls_set1) = nulls1 in - let must_nulls_set_result = + let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (Z.lt min_i) must_nulls_set1 |> MustSet.add min_i |> MustSet.M.filter (Z.gt min_size1) in - let may_nulls_set_result = + let may_nulls_set_result = if max_size1_exists then MaySet.filter ~max_size:max_size1 (Z.lt min_i) may_nulls_set1 |> MaySet.add min_i - |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) + |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) @@ -1528,12 +1517,12 @@ struct let min_i2 = Nulls.min_elem Definitely nulls2' in let (must_nulls_set1, may_nulls_set1) = nulls1 in let (must_nulls_set2', may_nulls_set2') = nulls2' in - let may_nulls_set2'_until_min_i2 = + let may_nulls_set2'_until_min_i2 = match idx_maximal size2 with | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 in - let may_nulls_set_result = + let may_nulls_set_result = if max_size1_exists then MaySet.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements @@ -1541,7 +1530,7 @@ struct |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) - |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) + |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) else if not (MaySet.is_top may_nulls_set1) then MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 |> MaySet.elements @@ -1557,14 +1546,14 @@ struct let strlen1 = to_string_length (nulls1, size1) in let strlen2 = to_string_length (nulls2', size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with - | Some min_size1, Some minlen1, Some minlen2 -> + | Some min_size1, Some minlen1, Some minlen2 -> begin match idx_maximal size1, idx_maximal strlen1, idx_maximal strlen2 with | Some max_size1, Some maxlen1, Some maxlen2 -> update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true nulls2' (* no upper bound for length of concatenation *) | Some max_size1, None, Some _ | Some max_size1, Some _, None - | Some max_size1, None, None -> + | Some max_size1, None, None -> update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false nulls2' (* no upper bound for size of dest *) | None, Some maxlen1, Some maxlen2 -> @@ -1584,7 +1573,7 @@ struct let nulls2', _ = to_string (nulls2, size2) in compute_concat nulls2' (* strncat *) - | Some n when n >= 0 -> + | Some n when n >= 0 -> let n = Z.of_int n in (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let nulls2' = @@ -1597,7 +1586,7 @@ struct else let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in let max_size2 = BatOption.default n (idx_maximal size2) in - (MustSet.filter ~min_size: min_size2 (Z.gt n) must_nulls_set2, MaySet.filter ~max_size:max_size2 (Z.gt n) may_nulls_set2) + (MustSet.filter ~min_size: min_size2 (Z.gt n) must_nulls_set2, MaySet.filter ~max_size:max_size2 (Z.gt n) may_nulls_set2) in compute_concat nulls2' | _ -> (Nulls.top (), size1) @@ -1608,7 +1597,7 @@ struct IsSubstrAtIndex0 else let haystack_len = to_string_length haystack in - let needle_len = to_string_length needle in + let needle_len = to_string_length needle in match idx_maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) @@ -1630,15 +1619,15 @@ struct else if Nulls.mem Definitely Z.zero nulls2 then Idx.starting IInt Z.one else - try + try let min_must1 = Nulls.min_elem Definitely nulls1 in let min_must2 = Nulls.min_elem Definitely nulls2 in - if not (min_must1 =. min_must2) + if not (min_must1 =. min_must2) && min_must1 =.(Nulls.min_elem Possibly nulls1) && min_must2 =. (Nulls.min_elem Possibly nulls2) && (not n_exists || min_must1 <. n || min_must2 <. n) then - (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) + (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) Idx.of_excl_list IInt [Z.zero] else Idx.top_of IInt @@ -1828,12 +1817,12 @@ struct type idx = Idx.t type value = Val.t - type ret = Null | NotNull | Top + type ret = Null | NotNull | Maybe type substr = N.substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr let domain_of_t (t_f, _) = A.domain_of_t t_f - let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = + let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = let f_get = A.get ~checkBounds ask t_f i in if get_bool "ana.base.arrays.nullbytes" then let n_get = N.get ask t_n i in @@ -1864,7 +1853,7 @@ struct let string_copy = string_op N.string_copy let string_concat = string_op N.string_concat - let extract op default (_, t_n1) (_, t_n2) n = + let extract op default (_, t_n1) (_, t_n2) n = if get_bool "ana.base.arrays.nullbytes" then op t_n1 t_n2 n else @@ -1873,9 +1862,9 @@ struct default () let substring_extraction x y = extract (fun x y _ -> N.substring_extraction x y) (fun () -> IsMaybeSubstr) x y None - let string_comparison = extract N.string_comparison (fun () -> Idx.top_of IInt) + let string_comparison = extract N.string_comparison (fun () -> Idx.top_of IInt) - let length (t_f, t_n) = + let length (t_f, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.length t_n else @@ -1884,18 +1873,18 @@ struct let get_vars_in_e (t_f, _) = A.get_vars_in_e t_f let fold_left f acc (t_f, _) = A.fold_left f acc t_f - let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = + let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = if get_bool "ana.base.arrays.nullbytes" then A.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 else A.smart_leq x y t_f1 t_f2 - let to_null_byte_domain s = + let to_null_byte_domain s = if get_bool "ana.base.arrays.nullbytes" then (A.make (Idx.top_of ILong) (Val.meet (Val.not_zero_of_ikind IChar) (Val.zero_of_ikind IChar)), N.to_null_byte_domain s) else (A.top (), N.top ()) - let to_string_length (_, t_n) = + let to_string_length (_, t_n) = if get_bool "ana.base.arrays.nullbytes" then N.to_string_length t_n else diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index fef063f765..0fe08f2cfb 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -71,7 +71,7 @@ module type Str = sig include S0 - type ret = Null | NotNull | Top + type ret = Null | NotNull | Maybe type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret @@ -88,17 +88,17 @@ sig * into array [dest], taking at most [n] bytes of [src] if present *) val string_concat: t -> t -> int option -> t - (** [string_concat s1 s2 n] returns a new abstract value representing the string + (** [string_concat s1 s2 n] returns a new abstract value representing the string * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of * [s2] if present *) val substring_extraction: t -> t -> substr - (** [substring_extraction haystack needle] returns [IsNotSubstr] if the string represented by - * the abstract value [needle] surely isn't a substring of [haystack], [IsSubstrAtIndex0] if + (** [substring_extraction haystack needle] returns [IsNotSubstr] if the string represented by + * the abstract value [needle] surely isn't a substring of [haystack], [IsSubstrAtIndex0] if * [needle] is the empty string, else [Unknown] *) val string_comparison: t -> t -> int option -> idx - (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string + (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string * represented by [s1] is less / greater than the one by [s2] or zero if they are equal; * only compares the first [n] bytes if present *) end @@ -112,7 +112,7 @@ sig val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value end -module type LatticeWithInvalidate = +module type LatticeWithInvalidate = sig include Lattice.S val invalidate_abstract_value: t -> t @@ -129,10 +129,10 @@ end module type LatticeWithNull = sig include LatticeWithSmartOps + type retnull = Null | NotNull | Maybe val null: unit -> t - val is_null: t -> bool - val is_not_null: t -> bool + val is_null: t -> retnull val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t @@ -162,8 +162,8 @@ module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S wit module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t (** This functor creates an array representation by the indexes of all null bytes * the array must and may contain. This is useful to analyze strings, i.e. null- - * terminated char arrays, and particularly to determine if operations on strings - * could lead to a buffer overflow. Concrete values from Val are not interesting + * terminated char arrays, and particularly to determine if operations on strings + * could lead to a buffer overflow. Concrete values from Val are not interesting * for this domain. It additionally tracks the array size. *) @@ -171,6 +171,6 @@ module AttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: IntDomain (** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) module AttributeConfiguredAndNullByteArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t -(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte - * in parallel if flag "ana.base.arrays.nullbytes" is set. +(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte + * in parallel if flag "ana.base.arrays.nullbytes" is set. *) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 985d7cca8b..9dfc65a1f1 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -39,9 +39,9 @@ sig val is_top_value: t -> typ -> bool val zero_init_value: ?varAttr:attributes -> typ -> t + type retnull = Null | NotNull | Maybe val null: unit -> t - val is_null: t -> bool - val is_not_null: t -> bool + val is_null: t -> retnull val get_ikind: t -> Cil.ikind option val zero_of_ikind: Cil.ikind -> t @@ -276,15 +276,13 @@ struct let null () = Int (ID.of_int IChar Z.zero) + type retnull = Null | NotNull | Maybe let is_null = function - | Int n -> GobOption.exists (Z.equal Z.zero) (ID.to_int n) - | _ -> false - - let is_not_null = function + | Int n when GobOption.exists (Z.equal Z.zero) (ID.to_int n) -> Null | Int n -> let zero_ik = ID.of_int (ID.ikind n) Z.zero in - ID.to_bool (ID.ne n zero_ik) = Some true - | _ -> false (* we don't know anything *) + if ID.to_bool (ID.ne n zero_ik) = Some true then NotNull else Maybe + | _ -> Maybe let get_ikind = function | Int n -> Some (ID.ikind n) From f51d60f306b40b69a497a872d6b6c35b48722ead Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 18:34:20 +0100 Subject: [PATCH 108/233] Simplify --- src/cdomains/arrayDomain.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 00d9107211..d2d1d80c7d 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1335,17 +1335,15 @@ struct let to_string_length (nulls, size) = (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) - (* TODO: check of must set really needed? *) if Nulls.is_empty Definitely nulls then (warn_past_end "Array doesn't contain a null byte: buffer overflow"; - match Idx.minimal size with - | Some min_size -> Idx.starting !Cil.kindOfSizeOf min_size - | None -> Idx.starting !Cil.kindOfSizeOf Z.zero) - (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) + Idx.starting !Cil.kindOfSizeOf (BatOption.default Z.zero (Idx.minimal size)) + ) + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if Nulls.is_empty Possibly nulls then (warn_past_end "Array might not contain a null byte: potential buffer overflow"; Idx.starting !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls)) - (* else return interval [minimal may null, minimal must null] *) + (* else return interval [minimal may null, minimal must null] *) else Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) From 0a47ea24c19a87740a67ec50b55c7adcd14218dd Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 18:43:09 +0100 Subject: [PATCH 109/233] Simplify --- src/cdomains/arrayDomain.ml | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d2d1d80c7d..6fe801fd79 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1236,23 +1236,25 @@ struct (warn_past_end "May access array past end: potential buffer overflow"; x) else let min_must_null = Nulls.min_elem Definitely nulls in + let new_size = Idx.of_int ILong (Z.succ min_must_null) in let min_may_null = Nulls.min_elem Possibly nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - if min_must_null =. min_may_null then - let nulls = Nulls.precise_singleton min_must_null in - (nulls, Idx.of_int ILong (Z.succ min_must_null)) - (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) - else - match idx_maximal size with - | Some max_size -> - let nulls' = Nulls.remove_all Possibly nulls in - (Nulls.filter ~max_size (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) - | None when not (Nulls.may_can_benefit_from_filter nulls) -> - let empty = Nulls.empty () in - (Nulls.add_interval Possibly (Z.zero, min_must_null) empty, Idx.of_int ILong (Z.succ min_must_null)) - | None -> - let nulls' = Nulls.remove_all Possibly nulls in - (Nulls.filter (Z.leq min_must_null) nulls', Idx.of_int ILong (Z.succ min_must_null)) + let nulls = + if min_must_null =. min_may_null then + Nulls.precise_singleton min_must_null + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + else + match idx_maximal size with + | Some max_size -> + let nulls' = Nulls.remove_all Possibly nulls in + Nulls.filter ~max_size (Z.leq min_must_null) nulls' + | None when not (Nulls.may_can_benefit_from_filter nulls) -> + Nulls.add_interval Possibly (Z.zero, min_must_null) (Nulls.empty ()) + | None -> + let nulls' = Nulls.remove_all Possibly nulls in + Nulls.filter (Z.leq min_must_null) nulls' + in + (nulls, new_size) (** [to_n_string index_set n] returns an abstract value with a potential null byte * marking the end of the string and if needed followed by further null bytes to obtain From 272e496cd69151c88c79eb356c83a455e6a48c36 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 18:50:03 +0100 Subject: [PATCH 110/233] Simplify --- src/cdomains/arrayDomain.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 6fe801fd79..08bdcc6224 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1039,13 +1039,12 @@ struct match max_i, idx_maximal size with (* if there is no maximum value in index interval *) - | None, _ -> + | None, _ when not (Nulls.exists Possibly ((<=.) min_i) nulls) -> (* ... return NotNull if no i >= min_i in may_nulls_set *) - if not (Nulls.exists Possibly ((<=.) min_i) nulls) then - NotNull - (* ... else return Top *) - else - Maybe + NotNull + | None, _ -> + (* ... else return Top *) + Maybe (* if there is no maximum size *) | Some max_i, None when max_i >=. Z.zero -> (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) From 3ebc74da421cc1160c123726b0188fd49b5abd33 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:08:14 +0100 Subject: [PATCH 111/233] Remove `idx_maximal` hack --- src/cdomains/arrayDomain.ml | 55 +++++++++----------- tests/regression/73-strings/05-char_arrays.c | 2 +- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 08bdcc6224..4eae0a2747 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1023,21 +1023,16 @@ struct module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds let warn_past_end = M.error ~category:ArrayOobMessage.past_end - (* helper: returns Idx.maximal except for Overflows that are mapped to None *) - let idx_maximal i = match Idx.maximal i with - | Some i when Z.fits_int i -> Some i - | _ -> None - let get (ask: VDQ.t) (nulls, size) (e, i) = let min interval = match Idx.minimal interval with | Some min_num when min_num >=. Z.zero -> min_num | _ -> Z.zero in (* assume worst case minimal natural number *) let min_i = min i in - let max_i = idx_maximal i in + let max_i = Idx.maximal i in let min_size = min size in - match max_i, idx_maximal size with + match max_i, Idx.maximal size with (* if there is no maximum value in index interval *) | None, _ when not (Nulls.exists Possibly ((<=.) min_i) nulls) -> (* ... return NotNull if no i >= min_i in may_nulls_set *) @@ -1072,10 +1067,10 @@ struct let min_size = min size in let min_i = min i in - let max_i = idx_maximal i in + let max_i = Idx.maximal i in let set_exact_nulls i = - match idx_maximal size with + match Idx.maximal size with (* if size has no upper limit *) | None -> (match Val.is_null v with @@ -1107,12 +1102,12 @@ struct let set_interval min_i max_i = (* Update max_i so it is capped at the maximum size *) - let max_i = BatOption.map_default (fun x -> Z.min max_i @@ Z.pred x) max_i (idx_maximal size) in + let max_i = BatOption.map_default (fun x -> Z.min max_i @@ Z.pred x) max_i (Idx.maximal size) in match Val.is_null v with | NotNull -> Nulls.remove_interval Possibly (min_i, max_i) min_size nulls - | Null -> Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls + | Null -> Nulls.add_interval ~maxfull:(Idx.maximal size) Possibly (min_i, max_i) nulls | Maybe -> - let nulls = Nulls.add_interval ~maxfull:(idx_maximal size) Possibly (min_i, max_i) nulls in + let nulls = Nulls.add_interval ~maxfull:(Idx.maximal size) Possibly (min_i, max_i) nulls in Nulls.remove_interval Possibly (min_i, max_i) min_size nulls in @@ -1122,8 +1117,8 @@ struct (* if no maximum number in index interval *) | None -> (* ..., value = null *) - (if Val.is_null v = Null && idx_maximal size = None then - match idx_maximal size with + (if Val.is_null v = Null && Idx.maximal size = None then + match Idx.maximal size with (* ... and there is no maximal size, modify may_nulls_set to top *) | None -> Nulls.add_all Possibly nulls (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) @@ -1133,7 +1128,7 @@ struct Nulls.filter_musts (Z.gt min_i) min_size nulls (*..., value unknown *) else - match Idx.minimal size, idx_maximal size with + match Idx.minimal size, Idx.maximal size with (* ... and size unknown, modify both sets to top *) | None, None -> Nulls.top () (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) @@ -1161,7 +1156,7 @@ struct let make ?(varAttr=[]) ?(typAttr=[]) i v = - let min_i, max_i = match Idx.minimal i, idx_maximal i with + let min_i, max_i = match Idx.minimal i, Idx.maximal i with | Some min_i, Some max_i -> if min_i <. Z.zero && max_i <. Z.zero then (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; @@ -1243,7 +1238,7 @@ struct Nulls.precise_singleton min_must_null (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else - match idx_maximal size with + match Idx.maximal size with | Some max_size -> let nulls' = Nulls.remove_all Possibly nulls in Nulls.filter ~max_size (Z.leq min_must_null) nulls' @@ -1289,7 +1284,7 @@ struct else if (exists_min_must_null && (min_must_null >=. n) || min_must_null >. min_may_null) || not exists_min_must_null then M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" in - (match Idx.minimal size, idx_maximal size with + (match Idx.minimal size, Idx.maximal size with | Some min_size, Some max_size -> if n >. max_size then warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" @@ -1307,7 +1302,7 @@ struct if Nulls.is_empty Definitely nulls then (warn_past_end "Resulting string might not be null-terminated because src doesn't contain a null byte"; - match idx_maximal size with + match Idx.maximal size with (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls | _ -> nulls) @@ -1353,7 +1348,7 @@ struct (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) let update_sets (truncatednulls, truncatedsize) len2 = let must_nulls_set2',may_nulls_set2' = truncatednulls in - match Idx.minimal dstsize, idx_maximal dstsize, Idx.minimal len2, idx_maximal len2 with + match Idx.minimal dstsize, Idx.maximal dstsize, Idx.minimal len2, Idx.maximal len2 with | Some min_dstsize, Some max_dstsize, Some min_srclen, Some max_srclen -> (if max_dstsize <. min_srclen then warn_past_end "The length of string src is greater than the allocated size for dest" @@ -1366,7 +1361,7 @@ struct (* and keep indexes of dest >= maximal strlen of src *) |> MustSet.union (MustSet.filter ~min_size:min_dstsize (Z.leq max_srclen) must_nulls_set1) in let may_nulls_set_result = - let max_size2 = BatOption.default max_dstsize (idx_maximal truncatedsize) in + let max_size2 = BatOption.default max_dstsize (Idx.maximal truncatedsize) in (* get may nulls from src string < maximal size of dest *) MaySet.filter ~max_size:max_size2 (Z.gt max_dstsize) may_nulls_set2' (* and keep indexes of dest >= minimal strlen of src *) @@ -1396,7 +1391,7 @@ struct let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in let may_nulls_set_result = - let max_size2 = BatOption.default max_size1 (idx_maximal truncatedsize) in + let max_size2 = BatOption.default max_size1 (Idx.maximal truncatedsize) in MaySet.filter ~max_size:max_size2 (Z.gt max_size1) may_nulls_set2' |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.leq min_len2) may_nulls_set1) in ((must_nulls_set_result, may_nulls_set_result), dstsize) @@ -1417,7 +1412,7 @@ struct (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) let sizes_warning srcsize = - (match Idx.minimal dstsize, idx_maximal dstsize, Idx.minimal srcsize, idx_maximal srcsize with + (match Idx.minimal dstsize, Idx.maximal dstsize, Idx.minimal srcsize, Idx.maximal srcsize with | Some min_dstsize, _, Some min_srcsize, _ when min_dstsize <. min_srcsize -> if not (Nulls.exists Possibly (Z.gt min_dstsize) srcnulls) then warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" @@ -1517,7 +1512,7 @@ struct let (must_nulls_set1, may_nulls_set1) = nulls1 in let (must_nulls_set2', may_nulls_set2') = nulls2' in let may_nulls_set2'_until_min_i2 = - match idx_maximal size2 with + match Idx.maximal size2 with | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 in @@ -1546,7 +1541,7 @@ struct let strlen2 = to_string_length (nulls2', size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> - begin match idx_maximal size1, idx_maximal strlen1, idx_maximal strlen2 with + begin match Idx.maximal size1, Idx.maximal strlen1, Idx.maximal strlen2 with | Some max_size1, Some maxlen1, Some maxlen2 -> update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true nulls2' (* no upper bound for length of concatenation *) @@ -1580,11 +1575,11 @@ struct if not (Nulls.exists Possibly (Z.gt n) nulls2) then Nulls.precise_singleton n else if not (Nulls.exists Definitely (Z.gt n) nulls2) then - let max_size2 = BatOption.default (Z.succ n) (idx_maximal size2) in + let max_size2 = BatOption.default (Z.succ n) (Idx.maximal size2) in (MustSet.empty (), MaySet.add n (MaySet.filter ~max_size:max_size2 (Z.geq n) may_nulls_set2)) else let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in - let max_size2 = BatOption.default n (idx_maximal size2) in + let max_size2 = BatOption.default n (Idx.maximal size2) in (MustSet.filter ~min_size: min_size2 (Z.gt n) must_nulls_set2, MaySet.filter ~max_size:max_size2 (Z.gt n) may_nulls_set2) in compute_concat nulls2' @@ -1597,7 +1592,7 @@ struct else let haystack_len = to_string_length haystack in let needle_len = to_string_length needle in - match idx_maximal haystack_len, Idx.minimal needle_len with + match Idx.maximal haystack_len, Idx.minimal needle_len with | Some haystack_max, Some needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) if haystack_max <. needle_min then @@ -1653,7 +1648,7 @@ struct let min_size1 = BatOption.default Z.zero (Idx.minimal size1) in let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in (* issue a warning if n is (potentially) smaller than array sizes *) - (match idx_maximal size1 with + (match Idx.maximal size1 with | Some max_size1 -> if n >. max_size1 then warn_past_end"The size of the array of string 1 is smaller than n bytes" @@ -1663,7 +1658,7 @@ struct if n >. min_size1 then warn_past_end "The size of the array of string 1 might be smaller than n bytes" ); - (match idx_maximal size2 with + (match Idx.maximal size2 with | Some max_size2 -> if n >. max_size2 then warn_past_end "The size of the array of string 2 is smaller than n bytes" diff --git a/tests/regression/73-strings/05-char_arrays.c b/tests/regression/73-strings/05-char_arrays.c index e5c7596063..cbf1916ca9 100644 --- a/tests/regression/73-strings/05-char_arrays.c +++ b/tests/regression/73-strings/05-char_arrays.c @@ -337,7 +337,7 @@ example16() { if (rand()) i = 3; else - i = 1/0; + i = 4; char s[5] = "abab"; __goblint_check(s[i] != '\0'); // UNKNOWN From 63bd31a0c31342fdf638b24ce86bb653fdb476eb Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:17:07 +0100 Subject: [PATCH 112/233] Simplify --- src/cdomains/arrayDomain.ml | 35 +++++++++++++---------------------- 1 file changed, 13 insertions(+), 22 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 4eae0a2747..ffb567209f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1645,28 +1645,19 @@ struct (* strncmp *) | Some n when n >= 0 -> let n = Z.of_int n in - let min_size1 = BatOption.default Z.zero (Idx.minimal size1) in - let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in - (* issue a warning if n is (potentially) smaller than array sizes *) - (match Idx.maximal size1 with - | Some max_size1 -> - if n >. max_size1 then - warn_past_end"The size of the array of string 1 is smaller than n bytes" - else if n >. min_size1 then - warn_past_end "The size of the array of string 1 might be smaller than n bytes" - | None -> - if n >. min_size1 then - warn_past_end "The size of the array of string 1 might be smaller than n bytes" - ); - (match Idx.maximal size2 with - | Some max_size2 -> - if n >. max_size2 then - warn_past_end "The size of the array of string 2 is smaller than n bytes" - else if n >. min_size2 then - warn_past_end "The size of the array of string 2 might be smaller than n bytes" - | None -> - if n >. min_size2 then - warn_past_end "The size of the array of string 2 might be smaller than n bytes"); + let warn_size size name = + let min = BatOption.default Z.zero (Idx.minimal size) in + match Idx.maximal size with + | Some max when n >. max -> + warn_past_end "The size of the array of string %s is smaller than n bytes" name + | Some max when n >. min -> + warn_past_end "The size of the array of string %s might be smaller than n bytes" name + | None when n >. min -> + warn_past_end "The size of the array of string %s might be smaller than n bytes" name + | _ -> () + in + warn_size size1 "1"; + warn_size size2 "2"; (* compute abstract value for result of strncmp *) compare n true | _ -> Idx.top_of IInt From 71bce3cf316f99b71565533ea49b67da697bbebc Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:20:06 +0100 Subject: [PATCH 113/233] Simplify --- src/cdomains/arrayDomain.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index ffb567209f..974da1bf6f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1632,14 +1632,14 @@ struct (* strcmp *) | None -> (* track any potential buffer overflow and issue warning if needed *) - (if Nulls.is_empty Definitely nulls1 && Nulls.is_empty Possibly nulls1 then - warn_past_end "Array of string 1 doesn't contain a null byte: buffer overflow" - else if Nulls.is_empty Possibly nulls1 then - warn_past_end "Array of string 1 might not contain a null byte: potential buffer overflow"); - (if Nulls.is_empty Definitely nulls2 && Nulls.is_empty Possibly nulls2 then - warn_past_end "Array of string 2 doesn't contain a null byte: buffer overflow" - else if Nulls.is_empty Possibly nulls2 then - warn_past_end "Array of string 2 might not contain a null byte: potential buffer overflow"); + let warn_missing_nulls nulls name = + if Nulls.is_empty Definitely nulls then + warn_past_end "Array of string %s doesn't contain a null byte: buffer overflow" name + else if Nulls.is_empty Possibly nulls then + warn_past_end "Array of string %s might not contain a null byte: potential buffer overflow" name + in + warn_missing_nulls nulls1 "1"; + warn_missing_nulls nulls2 "2"; (* compute abstract value for result of strcmp *) compare Z.zero false (* strncmp *) From 0b3ff1545b40092d4b4f7bfec61e81d0c151a73c Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:30:04 +0100 Subject: [PATCH 114/233] Remove `n_exists` construction --- src/cdomains/arrayDomain.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 974da1bf6f..d1ffa46ca8 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1602,9 +1602,9 @@ struct | _ -> IsMaybeSubstr let string_comparison (nulls1, size1) (nulls2, size2) n = - let compare n n_exists = + let cmp n = (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) - if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (n_exists && n =. Z.zero) then + if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (BatOption.map_default (Z.equal Z.zero) false n) then Idx.of_int IInt Z.zero (* if only s1 = empty string, return negative integer *) else if Nulls.mem Definitely Z.zero nulls1 && not (Nulls.mem Possibly Z.zero nulls2) then @@ -1619,7 +1619,7 @@ struct if not (min_must1 =. min_must2) && min_must1 =.(Nulls.min_elem Possibly nulls1) && min_must2 =. (Nulls.min_elem Possibly nulls2) - && (not n_exists || min_must1 <. n || min_must2 <. n) + && (BatOption.map_default (fun x -> min_must1 <. x || min_must2 <. x) true n) then (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) Idx.of_excl_list IInt [Z.zero] @@ -1641,7 +1641,7 @@ struct warn_missing_nulls nulls1 "1"; warn_missing_nulls nulls2 "2"; (* compute abstract value for result of strcmp *) - compare Z.zero false + cmp None (* strncmp *) | Some n when n >= 0 -> let n = Z.of_int n in @@ -1659,7 +1659,7 @@ struct warn_size size1 "1"; warn_size size2 "2"; (* compute abstract value for result of strncmp *) - compare n true + cmp (Some n) | _ -> Idx.top_of IInt let update_length new_size (nulls, size) = (nulls, new_size) From 320cc90a3e6c4d932ce22b1185615fe612be45b1 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:33:46 +0100 Subject: [PATCH 115/233] Simplify --- src/cdomains/arrayDomain.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d1ffa46ca8..5f4c917df2 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1593,12 +1593,9 @@ struct let haystack_len = to_string_length haystack in let needle_len = to_string_length needle in match Idx.maximal haystack_len, Idx.minimal needle_len with - | Some haystack_max, Some needle_min -> + | Some haystack_max, Some needle_min when haystack_max <. needle_min -> (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) - if haystack_max <. needle_min then - IsNotSubstr - else - IsMaybeSubstr + IsNotSubstr | _ -> IsMaybeSubstr let string_comparison (nulls1, size1) (nulls2, size2) n = From b4bb3c1827a2fdaa29114ea71cef41bf902d24ea Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 19:42:14 +0100 Subject: [PATCH 116/233] Steps towards removing ops on raw sets --- src/cdomains/arrayDomain.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 5f4c917df2..508bbcd50d 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1571,16 +1571,18 @@ struct let n = Z.of_int n in (* take at most n bytes from src; if no null byte among them, add null byte at index n *) let nulls2' = - let ((must_nulls_set2, may_nulls_set2) as nulls2), size2 = to_string (nulls2, size2) in + let (nulls2, size2) = to_string (nulls2, size2) in if not (Nulls.exists Possibly (Z.gt n) nulls2) then Nulls.precise_singleton n else if not (Nulls.exists Definitely (Z.gt n) nulls2) then - let max_size2 = BatOption.default (Z.succ n) (Idx.maximal size2) in - (MustSet.empty (), MaySet.add n (MaySet.filter ~max_size:max_size2 (Z.geq n) may_nulls_set2)) + let max_size = BatOption.default (Z.succ n) (Idx.maximal size2) in + let nulls2 = Nulls.remove_all Possibly nulls2 in + let nulls2 = Nulls.filter ~max_size (Z.geq n) nulls2 in + Nulls.add Possibly n nulls2 else - let min_size2 = BatOption.default Z.zero (Idx.minimal size2) in - let max_size2 = BatOption.default n (Idx.maximal size2) in - (MustSet.filter ~min_size: min_size2 (Z.gt n) must_nulls_set2, MaySet.filter ~max_size:max_size2 (Z.gt n) may_nulls_set2) + let min_size = BatOption.default Z.zero (Idx.minimal size2) in + let max_size = BatOption.default n (Idx.maximal size2) in + Nulls.filter ~max_size ~min_size (Z.gt n) nulls2 in compute_concat nulls2' | _ -> (Nulls.top (), size1) From 55a0dd4e603087ff472bc856e3e2c6906c3bc168 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 20:11:10 +0100 Subject: [PATCH 117/233] Replace exists types with options --- src/cdomains/arrayDomain.ml | 76 +++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 36 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 508bbcd50d..f81c3096c4 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1448,24 +1448,25 @@ struct | _ -> (Nulls.top (), dstsize) let string_concat (nulls1, size1) (nulls2, size2) n = - let update_sets min_size1 max_size1 max_size1_exists minlen1 maxlen1 maxlen1_exists minlen2 maxlen2 maxlen2_exists nulls2' = + let update_sets min_size1 max_size1 minlen1 (maxlen1: Z.t option) minlen2 maxlen2 maxlen2_exists nulls2' = (* track any potential buffer overflow and issue warning if needed *) - (if max_size1_exists && max_size1 <=. (minlen1 +. minlen2) then + (if GobOption.exists (fun x -> x <=. (minlen1 +. minlen2)) max_size1 then warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (maxlen1_exists && maxlen2_exists && min_size1 <=. (maxlen1 +. maxlen2)) || not maxlen1_exists || not maxlen2_exists then + else if (GobOption.for_all (fun x -> min_size1 <=. (x +. maxlen2)) maxlen1) && maxlen2_exists || not maxlen2_exists then warn_past_end "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) if Nulls.is_empty Possibly nulls1 || Nulls.is_empty Possibly nulls2 then - if max_size1_exists then + match max_size1 with + | Some max_size1 -> let nulls1_no_must = Nulls.remove_all Possibly nulls1 in let r = nulls1_no_must (* filter ensures we have the concete representation *) - |> Nulls.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) + |> Nulls.filter ~max_size:max_size1 (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) |> Nulls.elements ~max_size:max_size1 Possibly |> BatList.cartesian_product (Nulls.elements ~max_size:max_size1 Possibly nulls2') |> List.map (fun (i1, i2) -> i1 +. i2) @@ -1473,22 +1474,23 @@ struct |> Nulls.filter (Z.gt max_size1) in (r, size1) - else if Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 && maxlen1_exists && maxlen2_exists then - let nulls1_no_must = Nulls.remove_all Possibly nulls1 in - let r = - nulls1_no_must - (* filter ensures we have the concete representation *) - |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) - |> Nulls.elements Possibly - |> BatList.cartesian_product (Nulls.elements Possibly nulls2') - |> List.map (fun (i1, i2) -> i1 +. i2) - |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) - in - (r, size1) - else - (Nulls.top (), size1) - - (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) + | None when Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 -> + (match maxlen1, Some maxlen2 with + | Some maxlen1, Some maxlen2 when maxlen2_exists -> + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) + |> Nulls.elements Possibly + |> BatList.cartesian_product (Nulls.elements Possibly nulls2') + |> List.map (fun (i1, i2) -> i1 +. i2) + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + in + (r, size1) + | _ -> (Nulls.top (), size1)) + | _ -> (Nulls.top (), size1) + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Nulls.min_elem_precise (nulls1) && Nulls.min_elem_precise nulls2' then let min_i1 = Nulls.min_elem Definitely nulls1 in let min_i2 = Nulls.min_elem Definitely nulls2' in @@ -1499,12 +1501,13 @@ struct |> MustSet.add min_i |> MustSet.M.filter (Z.gt min_size1) in let may_nulls_set_result = - if max_size1_exists then + match max_size1 with + | Some max_size1 -> MaySet.filter ~max_size:max_size1 (Z.lt min_i) may_nulls_set1 |> MaySet.add min_i - |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) - else - MaySet.top () in + |> MaySet.M.filter (fun x -> max_size1 >. x) + | _ -> MaySet.top () + in ((must_nulls_set_result, may_nulls_set_result), size1) (* else only add all may nulls together <= strlen(dest) + strlen(src) *) else @@ -1515,24 +1518,25 @@ struct match Idx.maximal size2 with | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in - let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> if maxlen1_exists && maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) must_nulls_set1 in + let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> GobOption.exists (fun maxlen1 -> if maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) maxlen1) must_nulls_set1 in let may_nulls_set_result = - if max_size1_exists then - MaySet.filter ~max_size:max_size1 (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 + match max_size1 with + | Some max_size1 -> + MaySet.filter ~max_size:max_size1 (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) - |> MaySet.M.filter (fun x -> if max_size1_exists then max_size1 >. x else true) - else if not (MaySet.is_top may_nulls_set1) then - MaySet.M.filter (fun x -> if maxlen1_exists && maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) may_nulls_set1 + |> MaySet.M.filter (fun x -> max_size1 >. x) + | None when not (MaySet.is_top may_nulls_set1) -> + MaySet.M.filter (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> i1 +. i2) |> MaySet.of_list |> MaySet.union (MaySet.M.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1) - else + | _ -> MaySet.top () in ((must_nulls_set_result, may_nulls_set_result), size1) in @@ -1543,20 +1547,20 @@ struct | Some min_size1, Some minlen1, Some minlen2 -> begin match Idx.maximal size1, Idx.maximal strlen1, Idx.maximal strlen2 with | Some max_size1, Some maxlen1, Some maxlen2 -> - update_sets min_size1 max_size1 true minlen1 maxlen1 true minlen2 maxlen2 true nulls2' + update_sets min_size1 (Some max_size1) minlen1 (Some maxlen1) minlen2 maxlen2 true nulls2' (* no upper bound for length of concatenation *) | Some max_size1, None, Some _ | Some max_size1, Some _, None | Some max_size1, None, None -> - update_sets min_size1 max_size1 true minlen1 Z.zero false minlen2 Z.zero false nulls2' + update_sets min_size1 (Some max_size1) minlen1 None minlen2 Z.zero false nulls2' (* no upper bound for size of dest *) | None, Some maxlen1, Some maxlen2 -> - update_sets min_size1 Z.zero false minlen1 maxlen1 true minlen2 maxlen2 true nulls2' + update_sets min_size1 None minlen1 (Some maxlen1) minlen2 maxlen2 true nulls2' (* no upper bound for size of dest and length of concatenation *) | None, None, Some _ | None, Some _, None | None, None, None -> - update_sets min_size1 Z.zero false minlen1 Z.zero false minlen2 Z.zero false nulls2' + update_sets min_size1 None minlen1 None minlen2 Z.zero false nulls2' end (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (Nulls.top (), size1) in From 7a2e9bad75a494c33f50b74198151647523fd9be Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 20:36:40 +0100 Subject: [PATCH 118/233] Make types in `string_concat` make sense --- src/cdomains/arrayDomain.ml | 58 ++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 26 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index f81c3096c4..cbb6e145c5 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1448,14 +1448,17 @@ struct | _ -> (Nulls.top (), dstsize) let string_concat (nulls1, size1) (nulls2, size2) n = - let update_sets min_size1 max_size1 minlen1 (maxlen1: Z.t option) minlen2 maxlen2 maxlen2_exists nulls2' = + let update_sets min_size1 max_size1 minlen1 maxlen1 minlen2 (maxlen2: Z.t option) nulls2' = (* track any potential buffer overflow and issue warning if needed *) (if GobOption.exists (fun x -> x <=. (minlen1 +. minlen2)) max_size1 then warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else if (GobOption.for_all (fun x -> min_size1 <=. (x +. maxlen2)) maxlen1) && maxlen2_exists || not maxlen2_exists then - warn_past_end - "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest"); + else + (match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 when min_size1 >. (maxlen1 +. maxlen2) -> () + | _ -> warn_past_end + "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest") + ); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) @@ -1463,10 +1466,14 @@ struct match max_size1 with | Some max_size1 -> let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | _ -> (fun _ -> true) + in let r = nulls1_no_must (* filter ensures we have the concete representation *) - |> Nulls.filter ~max_size:max_size1 (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) + |> Nulls.filter ~max_size:max_size1 pred |> Nulls.elements ~max_size:max_size1 Possibly |> BatList.cartesian_product (Nulls.elements ~max_size:max_size1 Possibly nulls2') |> List.map (fun (i1, i2) -> i1 +. i2) @@ -1475,8 +1482,8 @@ struct in (r, size1) | None when Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 -> - (match maxlen1, Some maxlen2 with - | Some maxlen1, Some maxlen2 when maxlen2_exists -> + (match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2-> let nulls1_no_must = Nulls.remove_all Possibly nulls1 in let r = nulls1_no_must @@ -1518,11 +1525,21 @@ struct match Idx.maximal size2 with | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in - let must_nulls_set_result = MustSet.filter ~min_size:min_size1 (fun x -> GobOption.exists (fun maxlen1 -> if maxlen2_exists then (maxlen1 +. maxlen2) <. x else false) maxlen1) must_nulls_set1 in + let must_nulls_set_result = + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> (maxlen1 +. maxlen2) <. x) + | _ -> (fun _ -> false) + in + MustSet.filter ~min_size:min_size1 pred must_nulls_set1 + in let may_nulls_set_result = + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | _ -> (fun _ -> true) + in match max_size1 with | Some max_size1 -> - MaySet.filter ~max_size:max_size1 (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) may_nulls_set1 + MaySet.filter ~max_size:max_size1 pred may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> i1 +. i2) @@ -1530,7 +1547,7 @@ struct |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) |> MaySet.M.filter (fun x -> max_size1 >. x) | None when not (MaySet.is_top may_nulls_set1) -> - MaySet.M.filter (fun x -> GobOption.for_all (fun maxlen1 -> if maxlen2_exists then x <=. (maxlen1 +. maxlen2) else true) maxlen1) may_nulls_set1 + MaySet.M.filter pred may_nulls_set1 |> MaySet.elements |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) |> List.map (fun (i1, i2) -> i1 +. i2) @@ -1545,22 +1562,11 @@ struct let strlen2 = to_string_length (nulls2', size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> - begin match Idx.maximal size1, Idx.maximal strlen1, Idx.maximal strlen2 with - | Some max_size1, Some maxlen1, Some maxlen2 -> - update_sets min_size1 (Some max_size1) minlen1 (Some maxlen1) minlen2 maxlen2 true nulls2' - (* no upper bound for length of concatenation *) - | Some max_size1, None, Some _ - | Some max_size1, Some _, None - | Some max_size1, None, None -> - update_sets min_size1 (Some max_size1) minlen1 None minlen2 Z.zero false nulls2' - (* no upper bound for size of dest *) - | None, Some maxlen1, Some maxlen2 -> - update_sets min_size1 None minlen1 (Some maxlen1) minlen2 maxlen2 true nulls2' - (* no upper bound for size of dest and length of concatenation *) - | None, None, Some _ - | None, Some _, None - | None, None, None -> - update_sets min_size1 None minlen1 None minlen2 Z.zero false nulls2' + begin + let f = update_sets min_size1 (Idx.maximal size1) minlen1 in + match Idx.maximal strlen1, Idx.maximal strlen2 with + | (Some _ as maxlen1), (Some _ as maxlen2) -> f maxlen1 minlen2 maxlen2 nulls2' + | _ -> f None minlen2 None nulls2' end (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (Nulls.top (), size1) in From 1282af3e507083a65c2854e3ca16627c6e1b563d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 20:40:52 +0100 Subject: [PATCH 119/233] Simplify --- src/cdomains/arrayDomain.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index cbb6e145c5..8ee47e44ba 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1024,9 +1024,7 @@ struct let warn_past_end = M.error ~category:ArrayOobMessage.past_end let get (ask: VDQ.t) (nulls, size) (e, i) = - let min interval = match Idx.minimal interval with - | Some min_num when min_num >=. Z.zero -> min_num - | _ -> Z.zero in (* assume worst case minimal natural number *) + let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in let min_i = min i in let max_i = Idx.maximal i in From c85bad9038fd490cfe615b08c5b62e5ce50fd113 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 20:45:55 +0100 Subject: [PATCH 120/233] Pull out helper --- src/cdomains/arrayDomain.ml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 8ee47e44ba..7cadd66c19 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1023,12 +1023,12 @@ struct module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds let warn_past_end = M.error ~category:ArrayOobMessage.past_end - let get (ask: VDQ.t) (nulls, size) (e, i) = - let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in + let min_nat_of_idx i = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal i)) - let min_i = min i in + let get (ask: VDQ.t) (nulls, size) (e, i) = + let min_i = min_nat_of_idx i in let max_i = Idx.maximal i in - let min_size = min size in + let min_size = min_nat_of_idx size in match max_i, Idx.maximal size with (* if there is no maximum value in index interval *) @@ -1061,10 +1061,8 @@ struct | _ -> Maybe let set (ask: VDQ.t) (nulls, size) (e, i) v = - let min interval = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal interval)) in - - let min_size = min size in - let min_i = min i in + let min_size = min_nat_of_idx size in + let min_i = min_nat_of_idx i in let max_i = Idx.maximal i in let set_exact_nulls i = @@ -1653,7 +1651,7 @@ struct | Some n when n >= 0 -> let n = Z.of_int n in let warn_size size name = - let min = BatOption.default Z.zero (Idx.minimal size) in + let min = min_nat_of_idx size in match Idx.maximal size with | Some max when n >. max -> warn_past_end "The size of the array of string %s is smaller than n bytes" name From 20ee375f30ee5072fdfd1f7340fc4dd85358ebe6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:05:29 +0100 Subject: [PATCH 121/233] One less May/MustSet --- src/cdomains/arrayDomain.ml | 13 +++++-------- src/cdomains/nullByteSet.ml | 2 ++ 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7cadd66c19..7818f5ac85 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1395,14 +1395,11 @@ struct (if min_size1 <. min_len2 then warn_past_end "The length of string src may be greater than the allocated size for dest"); (* do not keep any index of dest as no maximal strlen of src *) - let must_nulls_set_result = - let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in - MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in - let may_nulls_set_result = - (* get all may nulls from src string as no maximal size of dest *) - may_nulls_set2' - |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in - ((must_nulls_set_result, may_nulls_set_result), dstsize) + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in + let truncatednulls = Nulls.remove_interval Possibly (Z.zero, min_size1) min_size2 truncatednulls in + let filtered_dst = Nulls.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) dstnulls in + (* get all may nulls from src string as no maximal size of dest *) + (Nulls.union_mays truncatednulls filtered_dst, dstsize) (* any other case shouldn't happen as minimal index is always >= 0 *) | _ -> (Nulls.top (), dstsize) in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 54284f6ab5..53196bb43c 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -170,6 +170,8 @@ module MustMaySet = struct | Definitely ->failwith "todo" | Possibly -> MaySet.elements ?max_size mays + let union_mays (must,mays) (_,mays2) = (must, MaySet.join mays mays2) + let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) From d995cc9ebb96833209b1b68b83acd5597509ebe4 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:16:15 +0100 Subject: [PATCH 122/233] Decouple concrete sets from MaySet --- src/cdomains/arrayDomain.ml | 8 ++++---- src/cdomains/nullByteSet.ml | 4 +++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 7818f5ac85..a7b139a740 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1208,12 +1208,12 @@ struct let last_null = Z.of_int (String.length s) in let rec build_set i set = if (Z.of_int i) >=. last_null then - MaySet.add last_null set + Nulls.Set.add last_null set else match String.index_from_opt s i '\x00' with - | Some i -> build_set (i + 1) (MaySet.add (Z.of_int i) set) - | None -> MaySet.add last_null set in - let set = build_set 0 (MaySet.empty ()) in + | Some i -> build_set (i + 1) (Nulls.Set.add (Z.of_int i) set) + | None -> Nulls.Set.add last_null set in + let set = build_set 0 (Nulls.Set.empty ()) in (Nulls.precise_set set, Idx.of_int ILong (Z.succ last_null)) (** Returns an abstract value with at most one null byte marking the end of the string *) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 53196bb43c..a7f889ee5a 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -78,6 +78,8 @@ end module MustMaySet = struct include Lattice.Prod (MustSet) (MaySet) + module Set = SetDomain.Make (IntDomain.BigInt) + type mode = Definitely | Possibly let empty () = (MustSet.top (), MaySet.bot ()) @@ -176,7 +178,7 @@ module MustMaySet = struct let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) - let precise_set s = (s,s) + let precise_set (s:Set.t):t = (`Lifted s,`Lifted s) let make_all_must () = (MustSet.bot (), MaySet.top ()) From 72476fbb1208600b2ff9bdd3bb417f89c6bb48d6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:36:52 +0100 Subject: [PATCH 123/233] Simplify --- src/cdomains/arrayDomain.ml | 16 +++++++--------- src/cdomains/nullByteSet.ml | 28 ++++++++++++++++------------ 2 files changed, 23 insertions(+), 21 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index a7b139a740..37d28fc206 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1260,13 +1260,6 @@ struct set else add_indexes (Z.succ i) max (MaySet.add i set) in - let update_must_indexes min_must_null must_nulls_set = - if min_must_null =. Z.zero then - MustSet.bot () - else - (* if strlen < n, every byte starting from min_must_null is surely also transformed to null *) - add_indexes min_must_null n must_nulls_set - |> MustSet.M.filter (Z.gt n) in let update_may_indexes min_may_null may_nulls_set = if min_may_null =. Z.zero then MaySet.top () @@ -1311,7 +1304,7 @@ struct Nulls.add_all Possibly nulls else let (must, mays) = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in - (must, mays |> MaySet.M.filter (Z.gt n)) (* TODO: this makes little sense *) + (must, mays |> MaySet.M.filter (fun x -> x <. n)) (* TODO: this makes little sense *) else let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in @@ -1319,7 +1312,12 @@ struct warn_no_null min_must_null true min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) if min_must_null =. min_may_null then - (update_must_indexes min_must_null must_nulls_set, update_may_indexes min_may_null may_nulls_set) + (if min_must_null =. Z.zero then + Nulls.full_set () + else + let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls) else (MustSet.top (), update_may_indexes min_may_null may_nulls_set) in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index a7f889ee5a..38fe5cbda9 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -84,6 +84,8 @@ module MustMaySet = struct let empty () = (MustSet.top (), MaySet.bot ()) + let full_set () = (MustSet.bot (), MaySet.top ()) + let is_empty mode (musts, mays) = match mode with | Definitely -> MaySet.is_empty mays @@ -123,21 +125,23 @@ module MustMaySet = struct | Possibly -> (musts, MaySet.union (MaySet.of_list l) mays) let add_interval ?maxfull mode (l,u) (musts, mays) = - match mode with - | Definitely -> failwith "todo" - | Possibly -> + let rec add_indexes i max set = + if Z.gt i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) + in + let mays = match maxfull with | Some Some maxfull when Z.equal l Z.zero && Z.geq u maxfull -> - (musts, MaySet.top ()) + MaySet.top () | _ -> - let rec add_indexes i max set = - if Z.gt i max then - set - else - add_indexes (Z.succ i) max (MaySet.add i set) - in - (musts, add_indexes l u mays) - + add_indexes l u mays + in + match mode with + | Definitely -> (add_indexes l u musts, mays) + | Possibly -> (musts, mays) + let remove_interval mode (l,u) min_size (musts, mays) = match mode with | Definitely -> failwith "todo" From a73c28d426a33d59202b500baba52e317415ca84 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:43:44 +0100 Subject: [PATCH 124/233] Lift one more transfer function to work on MustMay --- src/cdomains/arrayDomain.ml | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 37d28fc206..1e75d9f31e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1250,23 +1250,10 @@ struct * marking the end of the string and if needed followed by further null bytes to obtain * an n bytes string. *) let to_n_string (nulls, size) n:t = - let must_nulls_set, may_nulls_set = nulls in if n < 0 then (Nulls.top (), Idx.top_of ILong) else let n = Z.of_int n in - let rec add_indexes i max set = - if Z.geq i max then - set - else - add_indexes (Z.succ i) max (MaySet.add i set) in - let update_may_indexes min_may_null may_nulls_set = - if min_may_null =. Z.zero then - MaySet.top () - else - (* if minimal strlen < n, every byte starting from minimal may null index may be transformed to null *) - add_indexes min_may_null n may_nulls_set - |> MaySet.M.filter (Z.gt n) in let warn_no_null min_must_null exists_min_must_null min_may_null = if Z.geq min_may_null n then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" @@ -1303,8 +1290,8 @@ struct if min_may_null =. Z.zero then Nulls.add_all Possibly nulls else - let (must, mays) = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in - (must, mays |> MaySet.M.filter (fun x -> x <. n)) (* TODO: this makes little sense *) + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls else let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in @@ -1318,8 +1305,12 @@ struct let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in Nulls.filter (fun x -> x <. n) nulls) - else - (MustSet.top (), update_may_indexes min_may_null may_nulls_set) + else if min_may_null =. Z.zero then + Nulls.top () + else + let nulls = Nulls.remove_all Possibly nulls in + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls in (nulls, Idx.of_int ILong n) From c15ca04f04062425a06d23aca75a5f1b7be2077f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:50:15 +0100 Subject: [PATCH 125/233] Use option type --- src/cdomains/arrayDomain.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 1e75d9f31e..954bf757d1 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1254,11 +1254,15 @@ struct (Nulls.top (), Idx.top_of ILong) else let n = Z.of_int n in - let warn_no_null min_must_null exists_min_must_null min_may_null = + let warn_no_null min_must_null min_may_null = if Z.geq min_may_null n then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" - else if (exists_min_must_null && (min_must_null >=. n) || min_must_null >. min_may_null) || not exists_min_must_null then - M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" + else + (match min_must_null with + | Some min_must_null when not (min_must_null >=. n || min_must_null >. min_may_null) -> () + | _ -> + M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" + ) in (match Idx.minimal size, Idx.maximal size with | Some min_size, Some max_size -> @@ -1286,7 +1290,7 @@ struct * warn as in any case, resulting array not guaranteed to contain null byte *) else if Nulls.is_empty Possibly nulls then let min_may_null = Nulls.min_elem Possibly nulls in - warn_no_null Z.zero false min_may_null; + warn_no_null None min_may_null; if min_may_null =. Z.zero then Nulls.add_all Possibly nulls else @@ -1296,15 +1300,15 @@ struct let min_must_null = Nulls.min_elem Definitely nulls in let min_may_null = Nulls.min_elem Possibly nulls in (* warn if resulting array may not contain null byte *) - warn_no_null min_must_null true min_may_null; + warn_no_null (Some min_must_null) min_may_null; (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) if min_must_null =. min_may_null then - (if min_must_null =. Z.zero then + if min_must_null =. Z.zero then Nulls.full_set () else let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in - Nulls.filter (fun x -> x <. n) nulls) + Nulls.filter (fun x -> x <. n) nulls else if min_may_null =. Z.zero then Nulls.top () else From 1a9ce2c4c16f5feed5d4450ba06c305db99ba446 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 28 Nov 2023 21:56:12 +0100 Subject: [PATCH 126/233] Strange parens --- src/cdomains/arrayDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 954bf757d1..d197928f3e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1484,7 +1484,7 @@ struct | _ -> (Nulls.top (), size1)) | _ -> (Nulls.top (), size1) (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) - else if Nulls.min_elem_precise (nulls1) && Nulls.min_elem_precise nulls2' then + else if Nulls.min_elem_precise nulls1 && Nulls.min_elem_precise nulls2' then let min_i1 = Nulls.min_elem Definitely nulls1 in let min_i2 = Nulls.min_elem Definitely nulls2' in let min_i = min_i1 +. min_i2 in From 30daf274c92d7bd178920aa4ff089a4d08c077df Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 10:25:53 +0200 Subject: [PATCH 127/233] Simplify match in MemLeak Co-authored-by: Michael Schwarz --- src/analyses/memLeak.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 1253cd6763..8fc2cc663a 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -233,12 +233,11 @@ struct | a when Queries.ID.is_bot a -> M.warn ~category:Assert "assert expression %a is bottom" d_exp exp | a -> begin match Queries.ID.to_bool a with - | Some b -> + | Some true -> () + | Some false -> (* If we know for sure that the expression in "assert" is false => need to check for memory leaks *) - if b = false then ( - warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx - ) + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx | None -> warn_for_multi_threaded_due_to_abort ctx; check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) From 7fa7bfd222d464da93db98d10a5377baeb261ce0 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 10:27:34 +0200 Subject: [PATCH 128/233] Remove unit statement from MemLeak --- src/analyses/memLeak.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 8fc2cc663a..456d434be7 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -228,8 +228,7 @@ struct warn_for_multi_threaded_due_to_abort ctx; state | Assert { exp; _ } -> - let warn_for_assert_exp = - match ctx.ask (Queries.EvalInt exp) with + begin match ctx.ask (Queries.EvalInt exp) with | a when Queries.ID.is_bot a -> M.warn ~category:Assert "assert expression %a is bottom" d_exp exp | a -> begin match Queries.ID.to_bool a with @@ -242,8 +241,7 @@ struct warn_for_multi_threaded_due_to_abort ctx; check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) end - in - warn_for_assert_exp; + end; state | ThreadExit _ -> begin match ctx.ask (Queries.CurrentThreadId) with From df60d5262da0d5dde855c7af5a3b849804604645 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 10:49:12 +0200 Subject: [PATCH 129/233] Deduplicate ArrayDomain.StrWithDomain declarations --- src/cdomains/arrayDomain.ml | 4 +--- src/cdomains/arrayDomain.mli | 5 +---- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index d197928f3e..142b0dfb93 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -90,9 +90,7 @@ end module type StrWithDomain = sig include Str - - val domain_of_t: t -> domain - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value + include S with type t := t and type idx := idx end module type LatticeWithInvalidate = diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 0fe08f2cfb..2578d961ce 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -106,10 +106,7 @@ end module type StrWithDomain = sig include Str - - val domain_of_t: t -> domain - (* Returns the domain used for the array *) - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value + include S with type t := t and type idx := idx end module type LatticeWithInvalidate = From 309f000815ab3be1f0fea30d2a57a4cca0142eff Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 10:49:20 +0200 Subject: [PATCH 130/233] Remove trailing whitespace in ArrayDomain --- src/cdomains/arrayDomain.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 142b0dfb93..f10a55ce9e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1227,7 +1227,7 @@ struct let new_size = Idx.of_int ILong (Z.succ min_must_null) in let min_may_null = Nulls.min_elem Possibly nulls in (* if smallest index in sets coincides, only this null byte is kept in both sets *) - let nulls = + let nulls = if min_must_null =. min_may_null then Nulls.precise_singleton min_must_null (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) @@ -1255,7 +1255,7 @@ struct let warn_no_null min_must_null min_may_null = if Z.geq min_may_null n then M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" - else + else (match min_must_null with | Some min_must_null when not (min_must_null >=. n || min_must_null >. min_may_null) -> () | _ -> @@ -1309,7 +1309,7 @@ struct Nulls.filter (fun x -> x <. n) nulls else if min_may_null =. Z.zero then Nulls.top () - else + else let nulls = Nulls.remove_all Possibly nulls in let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in Nulls.filter (fun x -> x <. n) nulls @@ -1437,7 +1437,7 @@ struct (if GobOption.exists (fun x -> x <=. (minlen1 +. minlen2)) max_size1 then warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" - else + else (match maxlen1, maxlen2 with | Some maxlen1, Some maxlen2 when min_size1 >. (maxlen1 +. maxlen2) -> () | _ -> warn_past_end @@ -1451,7 +1451,7 @@ struct | Some max_size1 -> let nulls1_no_must = Nulls.remove_all Possibly nulls1 in let pred = match maxlen1, maxlen2 with - | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) | _ -> (fun _ -> true) in let r = @@ -1509,16 +1509,16 @@ struct match Idx.maximal size2 with | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in - let must_nulls_set_result = + let must_nulls_set_result = let pred = match maxlen1, maxlen2 with - | Some maxlen1, Some maxlen2 -> (fun x -> (maxlen1 +. maxlen2) <. x) + | Some maxlen1, Some maxlen2 -> (fun x -> (maxlen1 +. maxlen2) <. x) | _ -> (fun _ -> false) in - MustSet.filter ~min_size:min_size1 pred must_nulls_set1 + MustSet.filter ~min_size:min_size1 pred must_nulls_set1 in let may_nulls_set_result = let pred = match maxlen1, maxlen2 with - | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) | _ -> (fun _ -> true) in match max_size1 with @@ -1546,7 +1546,7 @@ struct let strlen2 = to_string_length (nulls2', size2) in match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with | Some min_size1, Some minlen1, Some minlen2 -> - begin + begin let f = update_sets min_size1 (Idx.maximal size1) minlen1 in match Idx.maximal strlen1, Idx.maximal strlen2 with | (Some _ as maxlen1), (Some _ as maxlen2) -> f maxlen1 minlen2 maxlen2 nulls2' From 44705f4ad8e987ce92a078a06f31eb394ee8b6ae Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 10:51:20 +0200 Subject: [PATCH 131/233] Use ocamldoc references in ArrayDomain.Str --- src/cdomains/arrayDomain.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index 2578d961ce..e7db47a708 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -93,9 +93,9 @@ sig * [s2] if present *) val substring_extraction: t -> t -> substr - (** [substring_extraction haystack needle] returns [IsNotSubstr] if the string represented by - * the abstract value [needle] surely isn't a substring of [haystack], [IsSubstrAtIndex0] if - * [needle] is the empty string, else [Unknown] *) + (** [substring_extraction haystack needle] returns {!IsNotSubstr} if the string represented by + * the abstract value [needle] surely isn't a substring of [haystack], {!IsSubstrAtIndex0} if + * [needle] is the empty string, else {!IsMaybeSubstr} *) val string_comparison: t -> t -> int option -> idx (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string From 80c2694db222710e0e908389ed9e69905350ec64 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 29 Nov 2023 11:00:30 +0200 Subject: [PATCH 132/233] Deduplicate Null declarations --- src/cdomains/arrayDomain.ml | 10 ++++++++-- src/cdomains/arrayDomain.mli | 10 ++++++++-- src/cdomains/valueDomain.ml | 8 +------- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index f10a55ce9e..6c47f1e87a 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -107,9 +107,9 @@ sig val smart_leq: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> bool end -module type LatticeWithNull = +module type Null = sig - include LatticeWithSmartOps + type t type retnull = Null | NotNull | Maybe val null: unit -> t @@ -120,6 +120,12 @@ sig val not_zero_of_ikind: Cil.ikind -> t end +module type LatticeWithNull = +sig + include LatticeWithSmartOps + include Null with type t := t +end + module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = struct include Val diff --git a/src/cdomains/arrayDomain.mli b/src/cdomains/arrayDomain.mli index e7db47a708..9b5a713859 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomains/arrayDomain.mli @@ -123,9 +123,9 @@ sig val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool end -module type LatticeWithNull = +module type Null = sig - include LatticeWithSmartOps + type t type retnull = Null | NotNull | Maybe val null: unit -> t @@ -136,6 +136,12 @@ sig val not_zero_of_ikind: Cil.ikind -> t end +module type LatticeWithNull = +sig + include LatticeWithSmartOps + include Null with type t := t +end + module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is taken as a parameter to satisfy the type system, it is not diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 9dfc65a1f1..4a83447e97 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -39,13 +39,7 @@ sig val is_top_value: t -> typ -> bool val zero_init_value: ?varAttr:attributes -> typ -> t - type retnull = Null | NotNull | Maybe - val null: unit -> t - val is_null: t -> retnull - - val get_ikind: t -> Cil.ikind option - val zero_of_ikind: Cil.ikind -> t - val not_zero_of_ikind: Cil.ikind -> t + include ArrayDomain.Null with type t := t val project: VDQ.t -> int_precision option-> ( attributes * attributes ) option -> t -> t val mark_jmpbufs_as_copied: t -> t From 71489df7d186e4a3ad81c88c95adda5a1e55b99a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 20:12:09 +0100 Subject: [PATCH 133/233] Introduce Printable.Either3 --- src/analyses/basePriv.ml | 27 ++++++++++++-------------- src/analyses/commonPriv.ml | 7 +++---- src/common/domains/printable.ml | 34 +++++++++++++++++++++++++++++++++ src/framework/constraints.ml | 12 ++++++------ 4 files changed, 55 insertions(+), 25 deletions(-) diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 3843dda300..e42cd5a309 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -211,12 +211,12 @@ struct let thread_join ?(force=false) ask get e st = st let thread_return ask get set tid st = st - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (read_unprotected_global getg) g' + | _ -> (* mutex *) + Invariant.none + end module PerMutexOplusPriv: S = @@ -625,13 +625,11 @@ struct let get_mutex_inits' = CPA.find x get_mutex_inits in VD.join get_mutex_global_x' get_mutex_inits' - let invariant_global getg g = - match g with - | `Left (`Left _) -> (* mutex *) - Invariant.none - | `Left (`Right g') -> (* global *) - ValueDomain.invariant_global (read_unprotected_global getg) g' - | `Right _ -> (* thread *) + let invariant_global getg = function + | `Middle g -> (* global *) + ValueDomain.invariant_global (read_unprotected_global getg) g + | `Left _ + | `Right _ -> (* mutex or thread *) Invariant.none end @@ -847,16 +845,15 @@ struct open Locksets - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (fun x -> GWeak.fold (fun s' tm acc -> WeakRange.fold_weak VD.join tm acc ) (G.weak (getg (V.global x))) (VD.bot ()) ) g' + | _ -> (* mutex *) + Invariant.none let invariant_vars ask getg st = let module VS = Set.Make (CilType.Varinfo) in diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 88181000b9..73a2e75de1 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -85,11 +85,10 @@ struct end module V = struct - (* TODO: Either3? *) - include Printable.Either (struct include Printable.Either (VMutex) (VMutexInits) let name () = "mutex" end) (VGlobal) + include Printable.Either3 (VMutex) (VMutexInits) (VGlobal) let name () = "MutexGlobals" - let mutex x: t = `Left (`Left x) - let mutex_inits: t = `Left (`Right ()) + let mutex x: t = `Left x + let mutex_inits: t = `Middle () let global x: t = `Right x end diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index b0755fb730..3499cfdb04 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -273,6 +273,40 @@ struct | `Right x -> `Right (Base2.relift x) end +module Either3 (Base1: S) (Base2: S) (Base3: S) = +struct + type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] + include Std + + let pretty () (state:t) = + match state with + | `Left n -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n + | `Middle n -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Right n -> Pretty.dprintf "%s:%a" (Base3.name ()) Base3.pretty n + + let show state = + match state with + | `Left n -> (Base1.name ()) ^ ":" ^ Base1.show n + | `Middle n -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Right n -> (Base3.name ()) ^ ":" ^ Base3.show n + + let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () ^ " or " ^ Base3.name () + let printXml f = function + | `Left x -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x + | `Middle x -> BatPrintf.fprintf f "\n\nMiddle\n\n%a\n\n" Base2.printXml x + | `Right x -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base3.printXml x + + let to_yojson = function + | `Left x -> `Assoc [ Base1.name (), Base1.to_yojson x ] + | `Middle x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Right x -> `Assoc [ Base3.name (), Base3.to_yojson x ] + + let relift = function + | `Left x -> `Left (Base1.relift x) + | `Middle x -> `Middle (Base2.relift x) + | `Right x -> `Right (Base3.relift x) +end + module Option (Base: S) (N: Name) = struct type t = Base.t option [@@deriving eq, ord, hash] diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index b1bbc73660..b6046d023b 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1467,14 +1467,14 @@ struct module V = struct - include Printable.Either (S.V) (Printable.Either (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C))) + include Printable.Either3 (S.V) (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C)) let name () = "longjmp" let s x = `Left x - let longjmpto x = `Right (`Left x) - let longjmpret x = `Right (`Right x) + let longjmpto x = `Middle x + let longjmpret x = `Right x let is_write_only = function | `Left x -> S.V.is_write_only x - | `Right _ -> false + | _ -> false end module G = @@ -1511,7 +1511,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (WarnGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | InvariantGlobal g -> @@ -1519,7 +1519,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (InvariantGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | IterSysVars (vq, vf) -> From 11516b13fc1070ac0463a51ccf79c46e8cf5ea8f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 20:23:31 +0100 Subject: [PATCH 134/233] Fix name of modifiedSinceSetjmp --- src/analyses/accessAnalysis.ml | 2 +- .../{modifiedSinceLongjmp.ml => modifiedSinceSetjmp.ml} | 6 ++---- src/autoTune.ml | 2 +- src/goblint_lib.ml | 2 +- 4 files changed, 5 insertions(+), 7 deletions(-) rename src/analyses/{modifiedSinceLongjmp.ml => modifiedSinceSetjmp.ml} (96%) diff --git a/src/analyses/accessAnalysis.ml b/src/analyses/accessAnalysis.ml index b181a1c70e..efad8b4c2e 100644 --- a/src/analyses/accessAnalysis.ml +++ b/src/analyses/accessAnalysis.ml @@ -29,7 +29,7 @@ struct let init _ = collect_local := get_bool "witness.yaml.enabled" && get_bool "witness.invariant.accessed"; let activated = get_string_list "ana.activated" in - emit_single_threaded := List.mem (ModifiedSinceLongjmp.Spec.name ()) activated || List.mem (PoisonVariables.Spec.name ()) activated + emit_single_threaded := List.mem (ModifiedSinceSetjmp.Spec.name ()) activated || List.mem (PoisonVariables.Spec.name ()) activated let do_access (ctx: (D.t, G.t, C.t, V.t) ctx) (kind:AccessKind.t) (reach:bool) (e:exp) = if M.tracing then M.trace "access" "do_access %a %a %B\n" d_exp e AccessKind.pretty kind reach; diff --git a/src/analyses/modifiedSinceLongjmp.ml b/src/analyses/modifiedSinceSetjmp.ml similarity index 96% rename from src/analyses/modifiedSinceLongjmp.ml rename to src/analyses/modifiedSinceSetjmp.ml index a129c9f92c..93e55b2a17 100644 --- a/src/analyses/modifiedSinceLongjmp.ml +++ b/src/analyses/modifiedSinceSetjmp.ml @@ -1,6 +1,4 @@ -(** Analysis of variables modified since [setjmp] ([modifiedSinceLongjmp]). *) - -(* TODO: this name is wrong *) +(** Analysis of variables modified since [setjmp] ([modifiedSinceSetjmp]). *) open GoblintCil open Analyses @@ -9,7 +7,7 @@ module Spec = struct include Analyses.IdentitySpec - let name () = "modifiedSinceLongjmp" + let name () = "modifiedSinceSetjmp" module D = JmpBufDomain.LocallyModifiedMap module VS = D.VarSet module C = Lattice.Unit diff --git a/src/autoTune.ml b/src/autoTune.ml index 0c3d3727f0..3cda36a302 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -200,7 +200,7 @@ let reduceThreadAnalyses () = (* This is run independent of the autotuner being enabled or not to be sound in the presence of setjmp/longjmp *) (* It is done this way around to allow enabling some of these analyses also for programs without longjmp *) -let longjmpAnalyses = ["activeLongjmp"; "activeSetjmp"; "taintPartialContexts"; "modifiedSinceLongjmp"; "poisonVariables"; "expsplit"; "vla"] +let longjmpAnalyses = ["activeLongjmp"; "activeSetjmp"; "taintPartialContexts"; "modifiedSinceSetjmp"; "poisonVariables"; "expsplit"; "vla"] let activateLongjmpAnalysesWhenRequired () = let isLongjmp = function diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 70f331b5ac..66ab2c76a4 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -130,7 +130,7 @@ module ExtractPthread = ExtractPthread Analyses related to [longjmp] and [setjmp]. *) module ActiveSetjmp = ActiveSetjmp -module ModifiedSinceLongjmp = ModifiedSinceLongjmp +module ModifiedSinceSetjmp = ModifiedSinceSetjmp module ActiveLongjmp = ActiveLongjmp module PoisonVariables = PoisonVariables module Vla = Vla From 89698bc46dd00b27a89cb726c82097419c504f57 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 20:45:22 +0100 Subject: [PATCH 135/233] RFC: Remove spec & file analysis --- docs/developer-guide/messaging.md | 13 - scripts/goblint-lib-modules.py | 2 - scripts/spec/check.sh | 27 - scripts/spec/regression.py | 61 --- scripts/spec/regression.sh | 18 - scripts/spec/spec.sh | 10 - src/analyses/fileUse.ml | 296 ----------- src/analyses/spec.ml | 496 ------------------ src/common/util/options.schema.json | 26 - src/goblint_lib.ml | 2 - src/main.camldoc | 2 - src/mainspec.ml | 13 - src/spec/dune | 2 - src/spec/file.dot | 37 -- src/spec/render.sh | 31 -- src/spec/specCore.ml | 152 ------ src/spec/specLexer.mll | 67 --- src/spec/specParser.mly | 116 ---- src/spec/specUtil.ml | 52 -- tests/regression/18-file/01-ok.c | 12 - tests/regression/18-file/02-function.c | 17 - tests/regression/18-file/03-if-close.c | 15 - tests/regression/18-file/04-no-open.c | 10 - tests/regression/18-file/05-open-mode.c | 11 - tests/regression/18-file/06-2open.c | 12 - tests/regression/18-file/07-2close.c | 11 - tests/regression/18-file/08-var-reuse.c | 15 - .../regression/18-file/09-inf-loop-no-close.c | 17 - tests/regression/18-file/10-inf-loop-ok.c | 19 - tests/regression/18-file/11-2if.c | 18 - tests/regression/18-file/12-2close-if.c | 15 - tests/regression/18-file/13-ptr-arith-ok.c | 16 - tests/regression/18-file/14-ptr-arith-close.c | 13 - tests/regression/18-file/15-var-switch.c | 18 - tests/regression/18-file/16-var-reuse-close.c | 14 - tests/regression/18-file/17-myfopen.c | 21 - tests/regression/18-file/18-myfopen-arg.c | 20 - tests/regression/18-file/19-if-close-else.c | 17 - tests/regression/18-file/20-loop-close.c | 18 - tests/regression/18-file/21-for-i.c | 26 - tests/regression/18-file/22-f_int.c | 13 - tests/regression/18-file/23-f_str.c | 13 - tests/regression/18-file/24-f_wstr.c | 14 - tests/regression/18-file/25-mem-ok.c | 29 - tests/regression/18-file/26-open-error-ok.c | 15 - tests/regression/18-file/27-open-error.c | 13 - tests/regression/18-file/28-multiple-exits.c | 14 - tests/regression/18-file/29-alias-global.c | 22 - tests/regression/18-file/30-ptr-of-ptr.c | 14 - tests/regression/18-file/31-var-reuse-fun.c | 16 - tests/regression/18-file/32-multi-ptr-close.c | 25 - tests/regression/18-file/33-multi-ptr-open.c | 23 - .../regression/18-file/34-multi-alias-close.c | 25 - .../regression/18-file/35-multi-alias-open.c | 23 - tests/regression/18-file/36-fun-ptr.c | 14 - .../regression/18-file/37-var-switch-alias.c | 18 - tests/regression/18-file/README.md | 2 + tests/regression/18-file/file.c | 44 -- tests/regression/18-file/file.optimistic.spec | 34 -- tests/regression/18-file/file.spec | 57 -- tests/regression/19-spec/01-malloc-free.c | 19 - tests/regression/19-spec/02-mutex_rc.c | 23 - tests/regression/19-spec/README.md | 2 + .../regression/19-spec/malloc.optimistic.spec | 23 - tests/regression/19-spec/malloc.spec | 26 - tests/regression/19-spec/mutex-lock.spec | 31 -- 66 files changed, 4 insertions(+), 2306 deletions(-) delete mode 100755 scripts/spec/check.sh delete mode 100755 scripts/spec/regression.py delete mode 100755 scripts/spec/regression.sh delete mode 100755 scripts/spec/spec.sh delete mode 100644 src/analyses/fileUse.ml delete mode 100644 src/analyses/spec.ml delete mode 100644 src/mainspec.ml delete mode 100644 src/spec/dune delete mode 100644 src/spec/file.dot delete mode 100755 src/spec/render.sh delete mode 100644 src/spec/specCore.ml delete mode 100644 src/spec/specLexer.mll delete mode 100644 src/spec/specParser.mly delete mode 100644 src/spec/specUtil.ml delete mode 100644 tests/regression/18-file/01-ok.c delete mode 100644 tests/regression/18-file/02-function.c delete mode 100644 tests/regression/18-file/03-if-close.c delete mode 100644 tests/regression/18-file/04-no-open.c delete mode 100644 tests/regression/18-file/05-open-mode.c delete mode 100644 tests/regression/18-file/06-2open.c delete mode 100644 tests/regression/18-file/07-2close.c delete mode 100644 tests/regression/18-file/08-var-reuse.c delete mode 100644 tests/regression/18-file/09-inf-loop-no-close.c delete mode 100644 tests/regression/18-file/10-inf-loop-ok.c delete mode 100644 tests/regression/18-file/11-2if.c delete mode 100644 tests/regression/18-file/12-2close-if.c delete mode 100644 tests/regression/18-file/13-ptr-arith-ok.c delete mode 100644 tests/regression/18-file/14-ptr-arith-close.c delete mode 100644 tests/regression/18-file/15-var-switch.c delete mode 100644 tests/regression/18-file/16-var-reuse-close.c delete mode 100644 tests/regression/18-file/17-myfopen.c delete mode 100644 tests/regression/18-file/18-myfopen-arg.c delete mode 100644 tests/regression/18-file/19-if-close-else.c delete mode 100644 tests/regression/18-file/20-loop-close.c delete mode 100644 tests/regression/18-file/21-for-i.c delete mode 100644 tests/regression/18-file/22-f_int.c delete mode 100644 tests/regression/18-file/23-f_str.c delete mode 100644 tests/regression/18-file/24-f_wstr.c delete mode 100644 tests/regression/18-file/25-mem-ok.c delete mode 100644 tests/regression/18-file/26-open-error-ok.c delete mode 100644 tests/regression/18-file/27-open-error.c delete mode 100644 tests/regression/18-file/28-multiple-exits.c delete mode 100644 tests/regression/18-file/29-alias-global.c delete mode 100644 tests/regression/18-file/30-ptr-of-ptr.c delete mode 100644 tests/regression/18-file/31-var-reuse-fun.c delete mode 100644 tests/regression/18-file/32-multi-ptr-close.c delete mode 100644 tests/regression/18-file/33-multi-ptr-open.c delete mode 100644 tests/regression/18-file/34-multi-alias-close.c delete mode 100644 tests/regression/18-file/35-multi-alias-open.c delete mode 100644 tests/regression/18-file/36-fun-ptr.c delete mode 100644 tests/regression/18-file/37-var-switch-alias.c create mode 100644 tests/regression/18-file/README.md delete mode 100644 tests/regression/18-file/file.c delete mode 100644 tests/regression/18-file/file.optimistic.spec delete mode 100644 tests/regression/18-file/file.spec delete mode 100644 tests/regression/19-spec/01-malloc-free.c delete mode 100644 tests/regression/19-spec/02-mutex_rc.c create mode 100644 tests/regression/19-spec/README.md delete mode 100644 tests/regression/19-spec/malloc.optimistic.spec delete mode 100644 tests/regression/19-spec/malloc.spec delete mode 100644 tests/regression/19-spec/mutex-lock.spec diff --git a/docs/developer-guide/messaging.md b/docs/developer-guide/messaging.md index 28f24bc49c..0028d51f87 100644 --- a/docs/developer-guide/messaging.md +++ b/docs/developer-guide/messaging.md @@ -47,16 +47,3 @@ The `~loc` argument is optional and defaults to the current location, but allows The `_noloc` suffixed functions allow general messages without any location (not even current). By convention, may-warnings (the usual case) should use warning severity and must-warnings should use error severity. - -### Spec analysis - -Warnings inside `.spec` files are converted to warnings. -They parsed from string warnings: the first space-delimited substring determines the category and the rest determines the text. - -For example: -``` -w1 "behavior.undefined.use_after_free" -w2 "integer.overflow" -w3 "unknown my message" -w4 "integer.overflow some text describing the warning" -``` diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 5f02271616..6369af53a1 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -42,8 +42,6 @@ "MessageCategory", # included in Messages "PreValueDomain", # included in ValueDomain - "SpecCore", # spec stuff - "SpecUtil", # spec stuff "ConfigVersion", "ConfigProfile", diff --git a/scripts/spec/check.sh b/scripts/spec/check.sh deleted file mode 100755 index 57b63edfd2..0000000000 --- a/scripts/spec/check.sh +++ /dev/null @@ -1,27 +0,0 @@ -export OCAMLRUNPARAM=b -# file to analyze -file=${1-"tests/file.c"} -# analysis to run or spec file -ana=${2-"tests/regression/18-file/file.optimistic.spec"} -debug=${debug-"true"} -if [ $ana == "file" ]; then - ana="file" - opt="--set ana.file.optimistic true" -else - spec=$ana - ana="spec" - opt="--set ana.spec.file $spec" -fi -cmd="./goblint --set ana.activated[0][+] $ana $opt --html --set warn.debug $debug $file" -echo -e "$(tput setaf 6)$cmd$(tput sgr 0)" -$cmd - - -# # focuses Firefox and reloads current tab -# if false && command -v xdotool >/dev/null 2>&1; then -# WID=`xdotool search --name "Mozilla Firefox" | head -1` -# xdotool windowactivate $WID -# #xdotool key F5 -# # reload is done by add-on Auto Reload (reload result/* on change of report.html) -# # https://addons.mozilla.org/en-US/firefox/addon/auto-reload/?src=api -# fi diff --git a/scripts/spec/regression.py b/scripts/spec/regression.py deleted file mode 100755 index dc9f9fa276..0000000000 --- a/scripts/spec/regression.py +++ /dev/null @@ -1,61 +0,0 @@ -# import fileinput -# for line in fileinput.input(): -# pass - -import sys, os -import re - -if len(sys.argv) != 2: - print("Stdin: output from goblint, 1. argument: C source-file") - sys.exit(1) -path = sys.argv[1] - -goblint = {} -for line in sys.stdin.readlines(): - line = re.sub(r"\033.*?m", "", line) - m = re.match(r"(.+) \("+re.escape(path)+":(.+)\)", line) - if m: goblint[int(m.group(2))] = m.group(1) - -source = {} -lines = open(path).readlines() -for i,line in zip(range(1, len(lines)+1), lines): - m = re.match(r".+ // WARN: (.+)", line) - if m: source[i] = m.group(1) - -diff = {}; -for k,v in sorted(set.union(set(goblint.items()), set(source.items()))): - if k in diff: continue - if k in goblint and k in source and goblint[k]!=source[k]: - diff[k] = ('D', [goblint[k], source[k]]) - elif (k,v) in goblint.items() and (k,v) not in source.items(): - diff[k] = ('G', [goblint[k]]) - elif (k,v) not in goblint.items() and (k,v) in source.items(): - diff[k] = ('S', [source[k]]) - -if not len(diff): - sys.exit(0) - -print("#"*50) -print(path) -print("file://"+os.getcwd()+"/result/"+os.path.basename(path)+".html") - -if len(goblint): - print("## Goblint warnings:") - for k,v in sorted(goblint.items()): - print("{} \t {}".format(k, v)) - print - -if len(source): - print("## Source warnings:") - for k,v in source.items(): - print("{} \t {}".format(k, v)) - print - -if len(diff): - print("## Diff (G..only goblint, S..only source, D..different):") - for k,(s,v) in sorted(diff.items()): - print("{} {} \t {}".format(s, k, v[0])) - for v in v[1:]: print("\t {}".format(v)) - -print -sys.exit(1) \ No newline at end of file diff --git a/scripts/spec/regression.sh b/scripts/spec/regression.sh deleted file mode 100755 index 6dc740ca75..0000000000 --- a/scripts/spec/regression.sh +++ /dev/null @@ -1,18 +0,0 @@ -debug_tmp=$debug -export debug=false # temporarily disable debug output -n=0 -c=0 -dir=${2-"tests/regression/18-file"} -for f in $dir/*.c; do - ./scripts/spec/check.sh $f ${1-"file"} 2>/dev/null | python scripts/spec/regression.py $f && ((c++)) - ((n++)) -done -debug=$debug_tmp -msg="passed $c/$n tests" -echo $msg -if [ $c -eq $n ]; then - exit 0 -else - notify-send -i stop "$msg" - exit 1 -fi diff --git a/scripts/spec/spec.sh b/scripts/spec/spec.sh deleted file mode 100755 index 03abe9a0c7..0000000000 --- a/scripts/spec/spec.sh +++ /dev/null @@ -1,10 +0,0 @@ -# print all states the parser goes through -#export OCAMLRUNPARAM='p' -bin=src/mainspec.native -spec=${1-"tests/regression/18-file/file.spec"} -ocamlbuild -yaccflag -v -X webapp -no-links -use-ocamlfind $bin \ - && (./_build/$bin $spec \ - || (echo "$spec failed, running interactive now..."; - rlwrap ./_build/$bin - ) - ) diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml deleted file mode 100644 index 58257b7843..0000000000 --- a/src/analyses/fileUse.ml +++ /dev/null @@ -1,296 +0,0 @@ -(** Analysis of correct file handle usage ([file]). - - @see Vogler, R. Verifying Regular Safety Properties of C Programs Using the Static Analyzer Goblint. Section 3.*) - -open Batteries -open GoblintCil -open Analyses - -module Spec = -struct - include Analyses.DefaultSpec - - let name () = "file" - module D = FileDomain.Dom - module C = FileDomain.Dom - - (* special variables *) - let return_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@return" Cil.voidType, `NoOffset - let unclosed_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@unclosed" Cil.voidType, `NoOffset - - (* keys that were already warned about; needed for multiple returns (i.e. can't be kept in D) *) - let warned_unclosed = ref Set.empty - - (* queries *) - let query ctx (type a) (q: a Queries.t) = - match q with - | Queries.MayPointTo exp -> if M.tracing then M.tracel "file" "query MayPointTo: %a" d_plainexp exp; Queries.Result.top q - | _ -> Queries.Result.top q - - let query_ad (ask: Queries.ask) exp = - match ask.f (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - let print_query_lv ?msg:(msg="") ask exp = - let addrs = query_ad ask exp in (* MayPointTo -> LValSet *) - let pretty_key = function - | Queries.AD.Addr.Addr (v,o) -> Pretty.text (D.string_of_key (v, ValueDomain.Addr.Offs.to_exp o)) - | _ -> Pretty.text "" in - if M.tracing then M.tracel "file" "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) addrs - - let eval_fv ask exp: varinfo option = - match query_ad ask exp with - | [addr] -> Queries.AD.Addr.to_var_may addr - | _ -> None - - - (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - let m = ctx.local in - (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) - let saveOpened ?unknown:(unknown=false) k m = (* save maybe opened files in the domain to warn about maybe unclosed files at the end *) - if D.may k D.opened m && not (D.is_unknown k m) then (* if unknown we don't have any location for the warning and have handled it already anyway *) - let mustOpen, mayOpen = D.filter_records k D.opened m in - let mustOpen, mayOpen = if unknown then Set.empty, mayOpen else mustOpen, Set.diff mayOpen mustOpen in - D.extend_value unclosed_var (mustOpen, mayOpen) m - else m - in - let key_from_exp = function - | Lval x -> Some (D.key_from_lval x) - | _ -> None - in - match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* we just care about Lval assignments *) - | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) - | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - if M.tracing then M.tracel "file" "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - saveOpened k1 m |> D.remove' k1 |> D.alias k1 k2 - | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - if M.tracing then M.tracel "file" "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - saveOpened k1 m |> D.remove' k1 - | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - if M.tracing then M.tracel "file" "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - D.alias k1 k2 m - | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - if M.tracing then M.tracel "file" "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; - D.warn @@ "[Unsound]changed pointer "^D.string_of_key k1^" (no longer safe)"; - saveOpened ~unknown:true k1 m |> D.unknown k1 - | _ -> (* no change in D for other things *) - if M.tracing then M.tracel "file" "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; - m - - let branch ctx (exp:exp) (tv:bool) : D.t = - let m = ctx.local in - (* ignore(printf "if %a = %B (line %i)\n" d_plainexp exp tv (!Tracing.current_loc).line); *) - let check a b tv = - (* ignore(printf "check: %a = %a, %B\n" d_plainexp a d_plainexp b tv); *) - match a, b with - | Const (CInt(i, kind, str)), Lval lval - | Lval lval, Const (CInt(i, kind, str)) -> - (* ignore(printf "branch(%s==%i, %B)\n" v.vname (Int64.to_int i) tv); *) - let k = D.key_from_lval lval in - if Z.compare i Z.zero = 0 && tv then ( - (* ignore(printf "error-branch\n"); *) - D.error k m - )else - D.success k m - | _ -> M.debug ~category:Analyzer "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m - in - match stripCasts (constFold true exp) with - (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts - -> matching as in flagMode didn't work *) - (* | BinOp (Eq, Const (CInt64(i, kind, str)), Lval (Var v, NoOffset), _) - | BinOp (Eq, Lval (Var v, NoOffset), Const (CInt64(i, kind, str)), _) -> - ignore(printf "%s %i\n" v.vname (Int64.to_int i)); m *) - | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv - | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | e -> M.debug ~category:Analyzer "branch: nothing matched the given exp: %a" d_plainexp e; m - - let body ctx (f:fundec) : D.t = - ctx.local - - let return ctx (exp:exp option) (f:fundec) : D.t = - (* TODO check One Return transformation: oneret.ml *) - let m = ctx.local in - (* if f.svar.vname <> "main" && BatList.is_empty (callstack m) then M.write ("\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"); *) - if f.svar.vname = "main" then ( - let mustOpen, mayOpen = D.union (D.filter_values D.opened m) (D.get_value unclosed_var m) in - if Set.cardinal mustOpen > 0 then ( - D.warn @@ "unclosed files: "^D.string_of_keys mustOpen; - Set.iter (fun v -> D.warn ~loc:(D.V.loc v) "file is never closed") mustOpen; - (* add warnings about currently open files (don't include overwritten or changed file handles!) *) - warned_unclosed := Set.union !warned_unclosed (fst (D.filter_values D.opened m)) (* can't save in domain b/c it wouldn't reach the other return *) - ); - (* go through files "never closed" and recheck for current return *) - Set.iter (fun v -> if D.must (D.V.key v) D.closed m then D.warn ~may:true ~loc:(D.V.loc v) "file is never closed") !warned_unclosed; - (* let mustOpenVars = List.map (fun x -> x.key) mustOpen in *) - (* let mayOpen = List.filter (fun x -> not (List.mem x.key mustOpenVars)) mayOpen in (* ignore values that are already in mustOpen *) *) - let mayOpen = Set.diff mayOpen mustOpen in - if Set.cardinal mayOpen > 0 then - D.warn ~may:true @@ "unclosed files: "^D.string_of_keys mayOpen; - Set.iter (fun v -> D.warn ~may:true ~loc:(D.V.loc v) "file is never closed") mayOpen - ); - (* take care of return value *) - let au = match exp with - | Some(Lval lval) when D.mem (D.key_from_lval lval) m -> (* we return a var in D *) - let k = D.key_from_lval lval in - let varinfo,offset = k in - if varinfo.vglob then - D.alias return_var k m (* if var is global, we alias it *) - else - D.add return_var (D.find' k m) m (* if var is local, we make a copy *) - | _ -> m - in - (* remove formals and locals *) - (* this is not a good approach, what if we added a key foo.fp? -> just keep the globals *) - List.fold_left (fun m var -> D.remove' (var, `NoOffset) m) au (f.sformals @ f.slocals) - (* D.only_globals au *) - - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let m = if f.svar.vname <> "main" then - (* push current location onto stack *) - D.edit_callstack (BatList.cons (Option.get !Node.current_node)) ctx.local - else ctx.local in - (* we need to remove all variables that are neither globals nor special variables from the domain for f *) - (* problem: we need to be able to check aliases of globals in check_overwrite_open -> keep those in too :/ *) - (* TODO see Base.make_entry, reachable vars > globals? *) - (* [m, D.only_globals m] *) - [m, m] (* this is [caller, callee] *) - - let check_overwrite_open k m = (* used in combine and special *) - if List.is_empty (D.get_aliases k m) then ( - (* there are no other variables pointing to the file handle - and it is opened again without being closed before *) - D.report k D.opened ("overwriting still opened file handle "^D.string_of_key k) m; - let mustOpen, mayOpen = D.filter_records k D.opened m in - let mayOpen = Set.diff mayOpen mustOpen in - (* save opened files in the domain to warn about unclosed files at the end *) - D.extend_value unclosed_var (mustOpen, mayOpen) m - ) else m - - let combine_env ctx lval fexp f args fc au f_ask = - let m = ctx.local in - (* pop the last location off the stack *) - let m = D.edit_callstack List.tl m in (* TODO could it be problematic to keep this in the caller instead of callee domain? if we only add the stack for the callee in enter, then there would be no need to pop a location anymore... *) - (* TODO add all globals from au to m (since we remove formals and locals on return, we can just add everything except special vars?) *) - D.without_special_vars au |> D.add_all m - - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - let m = ctx.local in - let return_val = D.find_option return_var au in - match lval, return_val with - | Some lval, Some v -> - let k = D.key_from_lval lval in - (* handle potential overwrites *) - let m = check_overwrite_open k m in - (* if v.key is still in D, then it must be a global and we need to alias instead of rebind *) - (* TODO what if there is a local with the same name as the global? *) - if D.V.is_top v then (* returned a local that was top -> just add k as top *) - D.add' k v m - else (* v is now a local which is not top or a global which is aliased *) - let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) - if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - D.alias k vvar m - else (* returned variable was a local *) - let v = D.V.set_key k v in (* adjust var-field to lval *) - D.add' k v m - | _ -> m - - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - (* is f a pointer to a function we look out for? *) - let f = eval_fv (Analyses.ask_of_ctx ctx) (Lval (Var f, NoOffset)) |? f in - let m = ctx.local in - let loc = (Option.get !Node.current_node)::(D.callstack m) in - let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) - let split_err_branch lval dom = - (* type? NULL = 0 = 0-ptr? Cil.intType, Cil.intPtrType, Cil.voidPtrType -> no difference *) - if not (GobConfig.get_bool "ana.file.optimistic") then - ctx.split dom [Events.SplitBranch ((Cil.BinOp (Cil.Eq, Cil.Lval lval, Cil.integer 0, Cil.intType)), true)]; - dom - in - (* fold possible keys on domain *) - let ret_all f lval = - let xs = D.keys_from_lval lval (Analyses.ask_of_ctx ctx) in (* get all possible keys for a given lval *) - if xs = [] then (D.warn @@ GobPretty.sprintf "could not resolve %a" CilType.Lval.pretty lval; m) - else if List.compare_length_with xs 1 = 0 then f (List.hd xs) m true - (* else List.fold_left (fun m k -> D.join m (f k m)) m xs *) - else - (* if there is more than one key, join all values and do warnings on the result *) - let v = List.fold_left (fun v k -> match v, D.find_option k m with - | None, None -> None - | Some a, None - | None, Some a -> Some a - | Some a, Some b -> Some (D.V.join a b)) None xs in - (* set all of the keys to the computed joined value *) - (* let m' = Option.map_default (fun v -> List.fold_left (fun m k -> D.add' k v m) m xs) m v in *) - (* then check each key *) - (* List.iter (fun k -> ignore(f k m')) xs; *) - (* get Mval.Exp from lval *) - let k' = D.key_from_lval lval in - (* add joined value for that key *) - let m' = Option.map_default (fun v -> D.add' k' v m) m v in - (* check for warnings *) - ignore(f k' m' true); - (* and join the old domain without issuing warnings *) - List.fold_left (fun m k -> D.join m (f k m false)) m xs - in - match lval, f.vname, arglist with - | None, "fopen", _ -> - D.warn "file handle is not saved!"; m - | Some lval, "fopen", _ -> - let f k m w = - let m = check_overwrite_open k m in - (match arglist with - | Const(CStr(filename,_))::Const(CStr(mode,_))::[] -> - (* M.debug ~category:Analyzer @@ "fopen(\""^filename^"\", \""^mode^"\")"; *) - D.fopen k loc filename mode m |> split_err_branch lval (* TODO k instead of lval? *) - | e::Const(CStr(mode,_))::[] -> - (* ignore(printf "CIL: %a\n" d_plainexp e); *) - (match ctx.ask (Queries.EvalStr e) with - | `Lifted filename -> D.fopen k loc filename mode m - | _ -> D.warn "[Unsound]unknown filename"; D.fopen k loc "???" mode m - ) - | xs -> - let args = (String.concat ", " (List.map CilType.Exp.show xs)) in - M.debug ~category:Analyzer "fopen args: %s" args; - (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) xs; *) - D.warn @@ "[Program]fopen needs two strings as arguments, given: "^args; m - ) - in ret_all f lval - - | _, "fclose", [Lval fp] -> - let f k m w = - if w then D.reports k [ - false, D.closed, "closeing already closed file handle "^D.string_of_key k; - true, D.opened, "closeing unopened file handle "^D.string_of_key k - ] m; - D.fclose k loc m - in ret_all f fp - | _, "fclose", _ -> - D.warn "fclose needs exactly one argument"; m - - | _, "fprintf", (Lval fp)::_::_ -> - let f k m w = - if w then D.reports k [ - false, D.closed, "writing to closed file handle "^D.string_of_key k; - true, D.opened, "writing to unopened file handle "^D.string_of_key k; - true, D.writable, "writing to read-only file handle "^D.string_of_key k; - ] m; - m - in ret_all f fp - | _, "fprintf", fp::_::_ -> - (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) arglist; *) - print_query_lv ~msg:"fprintf(?, ...): " (Analyses.ask_of_ctx ctx) fp; - D.warn "[Program]first argument to printf must be a Lval"; m - | _, "fprintf", _ -> - D.warn "[Program]fprintf needs at least two arguments"; m - - | _ -> m - - let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local - let exitstate v = D.bot () -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml deleted file mode 100644 index 2f754f6160..0000000000 --- a/src/analyses/spec.ml +++ /dev/null @@ -1,496 +0,0 @@ -(** Analysis using finite automaton specification file ([spec]). - - @author Ralf Vogler - - @see Vogler, R. Verifying Regular Safety Properties of C Programs Using the Static Analyzer Goblint. Section 4. *) - -open Batteries -open GoblintCil -open Analyses - -module SC = SpecCore - -module Spec = -struct - include Analyses.DefaultSpec - - let name() = "spec" - module D = SpecDomain.Dom - module C = SpecDomain.Dom - - (* special variables *) - let return_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@return" Cil.voidType, `NoOffset - let global_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@global" Cil.voidType, `NoOffset - - (* spec data *) - let nodes = ref [] - let edges = ref [] - - let load_specfile () = - let specfile = GobConfig.get_string "ana.spec.file" in - if String.length specfile < 1 then failwith "You need to specify a specification file using --set ana.spec.file path/to/file.spec when using the spec analysis!"; - if not (Sys.file_exists specfile) then failwith @@ "The given spec-file ("^specfile^") doesn't exist (CWD is "^Sys.getcwd ()^")."; - let _nodes, _edges = SpecUtil.parseFile specfile in - nodes := _nodes; edges := _edges (* don't change -> no need to save them in domain *) - - (* module for encapsulating general spec checking functions used in multiple transfer functions (assign, special) *) - (* - .spec-format: - - The file contains two types of definitions: nodes and edges. The labels of nodes are output. The labels of edges are the constraints. - - The given nodes are warnings, which have an implicit back edge to the previous node if used as a target. - - Alternatively warnings can be specified like this: "node1 -w1,w2,w3> node2 ...1" (w1, w2 and w3 will be output when the transition is taken). - - The start node of the first transition is the start node of the automaton. - - End nodes are specified by "node -> end _". - - "_end" is the local warning for nodes that are not in an end state, _END is the warning at return ($ is the list of keys). - - An edge with '_' matches everything. - - Edges with "->>" (or "-w1,w2>>" etc.) are forwarding edges, which will continue matching the same statement for the target node. - *) - module SpecCheck = - struct - (* custom goto (D.goto is just for modifying) that checks if the target state is a warning and acts accordingly *) - let goto ?may:(may=false) ?change_state:(change_state=true) key state m ws = - let loc = (Option.get !Node.current_node)::(D.callstack m) in - let warn key m msg = - Str.global_replace (Str.regexp_string "$") (D.string_of_key key) msg - |> D.warn ~may:(D.is_may key m || D.is_unknown key m) - in - (* do transition warnings *) - List.iter (fun state -> match SC.warning state !nodes with Some msg -> warn key m msg | _ -> ()) ws; - match SC.warning state !nodes with - | Some msg -> - warn key m msg; - m (* no goto == implicit back edge *) - | None -> - M.debug ~category:Analyzer "GOTO %s: %s -> %s" (D.string_of_key key) (D.string_of_state key m) state; - if not change_state then m - else if may then D.may_goto key loc state m else D.goto key loc state m - - let equal_exp ctx spec_exp cil_exp = match spec_exp, cil_exp with - (* TODO match constants right away to avoid queries? *) - | `String a, Const(CStr (b,_)) -> a=b - (* | `String a, Const(CWStr xs as c) -> failwith "not implemented" *) - (* CWStr is done in base.ml, query only returns `Str if it's safe *) - | `String a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> a = b - | _ -> M.debug ~category:Analyzer "EQUAL String Query: no result!"; false - ) - | `Regex a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> Str.string_match (Str.regexp a) b 0 - | _ -> M.debug ~category:Analyzer "EQUAL Regex String Query: no result!"; false - ) - | `Bool a, e -> (match ctx.ask (Queries.EvalInt e) with - | b -> (match Queries.ID.to_bool b with Some b -> a=b | None -> false) - ) - | `Int a, e -> (match ctx.ask (Queries.EvalInt e) with - | b -> (match Queries.ID.to_int b with Some b -> (Int64.of_int a)=(IntOps.BigIntOps.to_int64 b) | None -> false) - ) - | `Float a, Const(CReal (b, fkind, str_opt)) -> a=b - | `Float a, _ -> M.debug ~category:Analyzer "EQUAL Float: unsupported!"; false - (* arg is a key. currently there can only be one key per constraint, so we already used it for lookup. TODO multiple keys? *) - | `Var a, b -> true - (* arg is a identifier we use for matching constraints. TODO save in domain *) - | `Ident a, b -> true - | `Error s, b -> failwith @@ "Spec error: "^s - (* wildcard matches anything *) - | `Free, b -> true - | a,b -> M.info ~category:Unsound "EQUAL? Unmatched case - assume true..."; true - - let check_constraint ctx get_key matches m new_a old_key (a,ws,fwd,b,c as edge) = - (* If we have come to a wildcard, we match it instantly, but since there is no way of determining a key - this only makes sense if fwd is true (TODO wildcard for global. TODO use old_key). We pass a state replacement as 'new_a', - which will be applied in the following checks. - Multiple forwarding wildcards are not allowed, i.e. new_a must be None, otherwise we end up in a loop. *) - if SC.is_wildcard c && fwd && new_a=None then Some (m,fwd,Some (b,a),old_key) (* replace b with a in the following checks *) - else - (* save original start state of the constraint (needed to detect reflexive edges) *) - let old_a = a in - (* Assume new_a *) - let a = match new_a with - | Some (x,y) when a=x -> y - | _ -> a - in - (* if we forward, we have to replace the starting state for the following constraints *) - let new_a = if fwd then Some (b,a) else None in - (* TODO how to detect the key?? use "$foo" as key, "foo" as var in constraint and "_" for anything we're not interested in. - What to do for multiple keys (e.g. $foo, $bar)? -> Only allow one key & one map per spec-file (e.g. only $ as a key) or implement multiple maps? *) - (* look inside the constraint if there is a key and if yes, return what it corresponds to *) - (* if we can't find a matching key, we use the global key *) - let key = get_key c |? Cil.var (fst global_var) in - (* ignore(printf "KEY: %a\n" d_plainlval key); *) - (* get possible keys that &lval may point to *) - let keys = D.keys_from_lval key (Analyses.ask_of_ctx ctx) in (* does MayPointTo query *) - let check_key (m,n) var = - (* M.debug ~category:Analyzer @@ "check_key: "^f.vname^"(...): "^D.string_of_entry var m; *) - let wildcard = SC.is_wildcard c && fwd && b<>"end" in - (* skip transitions we can't take b/c we're not in the right state *) - (* i.e. if not in map, we must be at the start node or otherwise we must be in one of the possible saved states *) - if not (D.mem var m) && a<>SC.startnode !edges || D.mem var m && not (D.may_in_state var a m) then ( - (* ignore(printf "SKIP %s: state: %s, a: %s at %i\n" f.vname (D.string_of_state var m) a (!Tracing.current_loc.line)); *) - (m,n) (* not in map -> initial state. TODO save initial state? *) - ) - (* edge must match the current state or be a wildcard transition (except those for end) *) - else if not (matches edge) && not wildcard then (m,n) - (* everything matches the constraint -> go to new state and increase counter *) - else - (* TODO if #Queries.MayPointTo > 1: each result is May, but all combined are Must *) - let may = (List.compare_length_with keys 1 > 0) in - (* do not change state for reflexive edges where the key is not assigned to (e.g. *$p = _) *) - let change_state = not (old_a=b && SC.get_lval c <> Some `Var) in - M.debug ~category:Analyzer "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); - let new_m = goto ~may:may ~change_state:change_state var b m ws in - (new_m,n+1) - in - (* do check for each varinfo and return the resulting domain if there has been at least one matching constraint *) - let new_m,n = List.fold_left check_key (m,0) keys in (* start with original domain and #transitions=0 *) - if n==0 then None (* no constraint matched the current state *) - else Some (new_m,fwd,new_a,Some key) (* return new domain and forwarding info *) - - let check ctx get_key matches = - let m = ctx.local in - (* go through constraints and return resulting domain for the first match *) - (* if no constraint matches, the unchanged domain is returned *) - (* repeat for target node if it is a forwarding edge *) - (* TODO what should be done if multiple constraints would match? *) - (* TODO ^^ for May-Sets multiple constraints could match and should be taken! *) - try - let rec check_fwd_loop m new_a old_key = (* TODO cycle detection? *) - let new_m,fwd,new_a,key = List.find_map (check_constraint ctx get_key matches m new_a old_key) !edges in - (* List.iter (fun x -> M.debug ~category:Analyzer (x^"\n")) (D.string_of_map new_m); *) - if fwd then M.debug ~category:Analyzer "FWD: %B, new_a: %s, old_key: %s" fwd (dump new_a) (dump old_key); - if fwd then check_fwd_loop new_m new_a key else new_m,key - in - (* now we get the new domain and the latest key that was used *) - let new_m,key = check_fwd_loop m None None in - (* List.iter (fun x -> M.debug ~category:Analyzer (x^"\n")) (D.string_of_map new_m); *) - (* next we have to check if there is a branch() transition we could take *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c) !edges in - (* just for the compiler: key is initialized with None, but changes once some constaint matches. If none match, we wouldn't be here but at catch Not_found. *) - match key with - | Some key -> - (* we need to pass the key to the branch function. There is no scheme for getting the key from the constraint, but we should have been forwarded and can use the old key. *) - let check_branch branches var = - (* only keep those branch_edges for which our key might be in the right state *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> D.may_in_state var a new_m) branch_edges in - (* M.debug ~category:Analyzer @@ D.string_of_entry var new_m^" -> branch_edges: "^String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges; *) - (* count should be a multiple of 2 (true/false), otherwise the spec is malformed *) - if List.length branch_edges mod 2 <> 0 then failwith "Spec is malformed: branch-transitions always need a true and a false case!" else - (* if nothing matches, just return new_m without branching *) - (* if List.is_empty branch_edges then Set.of_list new_m else *) - if List.is_empty branch_edges then Set.of_list ([new_m, Cil.integer 1, true]) else (* XX *) - (* unique set of (dom,exp,tv) used in branch *) - let do_branch branches (a,ws,fwd,b,c) = - let c_str = match SC.branch_exp c with Some (exp,tv) -> SC.exp_to_string exp | _ -> "" in - let c_str = Str.global_replace (Str.regexp_string "$key") "%e:key" c_str in (* TODO what should be used to specify the key? *) - (* TODO this somehow also prints the expression!? why?? *) - let c_exp = Formatcil.cExp c_str [("key", Fe (D.K.to_cil_exp var))] in (* use Fl for Lval instead? *) - (* TODO encode key in exp somehow *) - (* ignore(printf "BRANCH %a\n" d_plainexp c_exp); *) - ctx.split new_m [Events.SplitBranch (c_exp, true)]; - Set.add (new_m,c_exp,true) (Set.add (new_m,c_exp,false) branches) - in - List.fold_left do_branch branches branch_edges - in - let keys = D.keys_from_lval key (Analyses.ask_of_ctx ctx) in - let new_set = List.fold_left check_branch Set.empty keys in ignore(new_set); (* TODO refactor *) - (* List.of_enum (Set.enum new_set) *) - new_m (* XX *) - | None -> new_m - with Not_found -> m (* nothing matched -> no change *) - end - - (* queries *) - let query ctx (type a) (q: a Queries.t) = - match q with - | _ -> Queries.Result.top q - - let query_addrs ask exp = - match ask (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - - let eval_fv ask exp: varinfo option = - match query_addrs ask exp with - | [addr] -> Queries.AD.Addr.to_var_may addr - | _ -> None - - - (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) - let get_key c = match SC.get_key_variant c with - | `Lval s -> - M.debug ~category:Analyzer "Key variant assign `Lval %s; %s" s (SC.stmt_to_string c); - (match SC.get_lval c, lval with - | Some `Var, _ -> Some lval - | Some `Ptr, (Mem Lval x, o) -> Some x (* TODO offset? *) - | _ -> None) - | _ -> None - in - let matches (a,ws,fwd,b,c) = - SC.equal_form (Some lval) c && - (* check for constraints *p = _ where p is the key *) - match lval, SC.get_lval c with - | (Mem Lval x, o), Some `Ptr when SpecCheck.equal_exp ctx (SC.get_rval c) rval -> - let keys = D.keys_from_lval x (Analyses.ask_of_ctx ctx) in - if List.compare_length_with keys 1 <> 0 then failwith "not implemented" - else true - | _ -> false (* nothing to do *) - in - let m = SpecCheck.check ctx get_key matches in - let key_from_exp = function - | Lval (Var v,o) -> Some (v, Offset.Exp.of_cil o) - | _ -> None - in - match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* TODO for now we just care about Lval assignments -> should use Queries.MayPointTo *) - | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) - | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug ~category:Analyzer "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - (* saveOpened k1 *) m |> D.remove' k1 |> D.alias k1 k2 - | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug ~category:Analyzer "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - (* saveOpened k1 *) m |> D.remove' k1 - | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug ~category:Analyzer "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - let m = D.alias k1 k2 m in (* point k1 to k2 *) - if Basetype.Variables.to_group (fst k2) = Temp (* check if k2 is a temporary Lval introduced by CIL *) - then D.remove' k2 m (* if yes we need to remove it from our map *) - else m (* otherwise no change *) - | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug ~category:Analyzer "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; - D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; - (* saveOpened ~unknown:true k1 *) m |> D.unknown k1 - | _ -> (* no change in D for other things *) - M.debug ~category:Analyzer "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; - m - - (* - - branch-transitions in the spec-file come in pairs: e.g. true-branch goes to node a, false-branch to node b - - branch is called for both possibilities - - TODO query the exp and take/don't take the transition - - in case of `Top we take the transition - - both branches get joined after (e.g. for fopen: May [open; error]) - - if there is a branch in the code, branch is also called - -> get the key from exp and backtrack to the corresponding branch-transitions - -> reevaluate with current exp and meet domain with result - *) - (* - - get key from exp - - ask EvalInt - - if result is `Top and we are in a state that is the starting node of a branch edge, we have to: - - go to target node and modify the state in specDomain - - find out which value of key makes exp equal to tv - - save this value and answer queries for EvalInt with it - - if not, compare it with tv and take the corresponding branch - *) - let branch ctx (exp:exp) (tv:bool) : D.t = - let m = ctx.local in - (* ignore(printf "if %a = %B (line %i)\n" d_plainexp exp tv (!Tracing.current_loc).line); *) - let check a b tv = - (* ignore(printf "check: %a = %a\n" d_plainexp a d_plainexp b); *) - match a, b with - | Const (CInt(i, kind, str)), Lval lval - | Lval lval, Const (CInt(i, kind, str)) -> - (* let binop = BinOp (Eq, a, b, Cil.intType) in *) - (* standardize the format of the expression to 'lval==i'. -> spec needs to follow that format, the code is mapped to it. *) - let binop = BinOp (Eq, Lval lval, Const (CInt(i, kind, str)), Cil.intType) in - let key = D.key_from_lval lval in - let value = D.find key m in - if Z.equal i Z.zero && tv then ( - M.debug ~category:Analyzer "error-branch"; - (* D.remove key m *) - )else( - M.debug ~category:Analyzer "success-branch"; - (* m *) - ); - (* there should always be an entry in our domain for key *) - if not (D.mem key m) then m else - (* TODO for now we just assume that a Binop is used and Lval is the key *) - (* get the state(s) that key is/might be in *) - let states = D.get_states key m in - (* compare SC.exp with Cil.exp and tv *) - let branch_exp_eq c exp tv = - (* let c_str = match SC.branch_exp c with Some (exp,tv) -> SC.exp_to_string exp | _ -> "" in - let c_str = Str.global_replace (Str.regexp_string "$key") "%e:key" c_str in - let c_exp = Formatcil.cExp c_str [("key", Fe (D.K.to_exp key))] in *) - (* c_exp=exp *) (* leads to Out_of_memory *) - match SC.branch_exp c with - | Some (c_exp,c_tv) -> - (* let exp_str = CilType.Exp.show exp in *) (* contains too many casts, so that matching fails *) - let exp_str = CilType.Exp.show binop in - let c_str = SC.exp_to_string c_exp in - let c_str = Str.global_replace (Str.regexp_string "$key") (D.string_of_key key) c_str in - (* ignore(printf "branch_exp_eq: '%s' '%s' -> %B\n" c_str exp_str (c_str=exp_str)); *) - c_str=exp_str && c_tv=tv - | _ -> false - in - (* filter those edges that are branches, start with a state from states and have the same branch expression and the same tv *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem a states && branch_exp_eq c exp tv) !edges in - (* there should be only one such edge or none *) - if List.compare_length_with branch_edges 1 <> 0 then ( (* call of branch for an actual branch *) - M.debug ~category:Analyzer "branch: branch_edges length is not 1! -> actual branch"; - M.debug ~category:Analyzer "%s -> branch_edges1: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; - (* filter those edges that are branches, end with a state from states have the same branch expression and the same tv *) - (* TODO they should end with any predecessor of the current state, not only the direct predecessor *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem b states && branch_exp_eq c exp tv) !edges in - M.debug ~category:Analyzer "%s -> branch_edges2: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; - if List.compare_length_with branch_edges 1 <> 0 then m else - (* meet current value with the target state. this is tricky: we can not simply take the target state, since there might have been more than one element already before the branching. - -> find out what the alternative branch target was and remove it *) - let (a,ws,fwd,b,c) = List.hd branch_edges in - (* the alternative branch has the same start node, the same branch expression and the negated tv *) - let (a,ws,fwd,b,c) = List.find (fun (a2,ws,fwd,b,c) -> SC.is_branch c && a2=a && branch_exp_eq c exp (not tv)) !edges in - (* now b is the state the alternative branch goes to -> remove it *) - (* TODO may etc. *) - (* being explicit: check how many records there are. if the value is Must b, then we're sure that it is so and we don't remove anything. *) - if D.V.length value = (1,1) then m else (* XX *) - (* there are multiple possible states -> remove b *) - let v2 = D.V.remove_state b value in - (* M.debug ~category:Analyzer @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) - D.add key v2 m - ) else (* call of branch directly after splitting *) - let (a,ws,fwd,b,c) = List.hd branch_edges in - (* TODO may etc. *) - let v2 = D.V.set_state b value in - (* M.debug ~category:Analyzer @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) - D.add key v2 m - | _ -> M.debug ~category:Analyzer "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m - in - match stripCasts (constFold true exp) with - (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts - -> matching as in flagMode didn't work *) - | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv - | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | UnOp (LNot, a, _) -> check (stripCasts a) (integer 0) tv - (* TODO makes 2 tests fail. probably check changes something it shouldn't *) - (* | Lval _ as a -> check (stripCasts a) (integer 0) (not tv) *) - | e -> M.debug ~category:Analyzer "branch: nothing matched the given exp: %a" d_plainexp e; m - - let body ctx (f:fundec) : D.t = - ctx.local - - let return ctx (exp:exp option) (f:fundec) : D.t = - let m = ctx.local in - (* M.debug ~category:Analyzer @@ "return: ctx.local="^D.short 50 m^D.string_of_callstack m; *) - (* if f.svar.vname <> "main" && BatList.is_empty (D.callstack m) then M.debug ~category:Analyzer @@ "\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"; *) - if f.svar.vname = "main" then ( - let warn_main msg_loc msg_end = (* there is an end warning for local, return or both *) - (* find edges that have 'end' as a target *) - (* we ignore the constraint, TODO maybe find a better syntax for declaring end states *) - let end_states = BatList.filter_map (fun (a,ws,fwd,b,c) -> if b="end" then Some a else None) !edges in - let must_not, may_not = D.filter_values (fun r -> not @@ List.exists (fun end_state -> D.V.in_state end_state r) end_states) m in - let may_not = Set.diff may_not must_not in - (match msg_loc with (* local warnings for entries that must/may not be in an end state *) - | Some msg -> - Set.iter (fun r -> D.warn ~loc:(D.V.loc r) msg) must_not; - Set.iter (fun r -> D.warn ~may:true ~loc:(D.V.loc r) msg) may_not - | None -> ()); - (match msg_end with - | Some msg -> (* warnings at return for entries that must/may not be in an end state *) - let f msg rs = Str.global_replace (Str.regexp_string "$") (D.string_of_keys rs) msg in - if Set.cardinal must_not > 0 then D.warn (f msg must_not); - if Set.cardinal may_not > 0 then D.warn ~may:true (f msg may_not) - | _ -> ()) - in - (* check if there is a warning for entries that are not in an end state *) - match SC.warning "_end" !nodes, SC.warning "_END" !nodes with - | None, None -> () (* nothing to do here *) - | msg_loc,msg_end -> warn_main msg_loc msg_end - ); - (* take care of return value *) - let au = match exp with - | Some(Lval lval) when D.mem (D.key_from_lval lval) m -> (* we return a var in D *) - let k = D.key_from_lval lval in - let varinfo,offset = k in - if varinfo.vglob then - D.alias return_var k m (* if var is global, we alias it *) - else - D.add return_var (D.find' k m) m (* if var is local, we make a copy *) - | _ -> m - in - (* remove formals and locals *) - (* TODO only keep globals like in fileUse *) - List.fold_left (fun m var -> D.remove' (var, `NoOffset) m) au (f.sformals @ f.slocals) - - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - (* M.debug ~category:Analyzer @@ "entering function "^f.vname^D.string_of_callstack ctx.local; *) - if f.svar.vname = "main" then load_specfile (); - let m = if f.svar.vname <> "main" then - D.edit_callstack (BatList.cons (Option.get !Node.current_node)) ctx.local - else ctx.local in [m, m] - - let combine_env ctx lval fexp f args fc au f_ask = - (* M.debug ~category:Analyzer @@ "leaving function "^f.vname^D.string_of_callstack au; *) - let au = D.edit_callstack List.tl au in - (* remove special return var *) - D.remove' return_var au - - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - let return_val = D.find_option return_var au in - match lval, return_val with - | Some lval, Some v -> - let k = D.key_from_lval lval in - (* handle potential overwrites *) - (* |> check_overwrite_open k *) - (* if v.key is still in D, then it must be a global and we need to alias instead of rebind *) - (* TODO what if there is a local with the same name as the global? *) - if D.V.is_top v then (* returned a local that was top -> just add k as top *) - D.add' k v ctx.local - else (* v is now a local which is not top or a global which is aliased *) - let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) - if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug ~category:Analyzer @@ vvar.vname^" was a global -> alias" in *) - D.alias k vvar ctx.local - else (* returned variable was a local *) - let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug ~category:Analyzer @@ vvar.vname^" was a local -> rebind"; *) - D.add' k v ctx.local - | _ -> ctx.local - - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) - let get_key c = match SC.get_key_variant c with - | `Lval s -> - M.debug ~category:Analyzer "Key variant special `Lval %s; %s" s (SC.stmt_to_string c); - lval - | `Arg(s, i) -> - M.debug ~category:Analyzer "Key variant special `Arg(%s, %d). %s" s i (SC.stmt_to_string c); - (try - let arg = List.at arglist i in - match arg with - | Lval x -> Some x (* TODO enough to just assume the arg is already there as a Lval? *) - | AddrOf x -> Some x - | _ -> None - with Invalid_argument s -> - M.debug ~category:Analyzer "Key out of bounds! Msg: %s" s; (* TODO what to do if spec says that there should be more args... *) - None - ) - | _ -> None (* `Rval or `None *) - in - let matches (a,ws,fwd,b,c) = - let equal_args spec_args cil_args = - if List.compare_length_with spec_args 1 = 0 && List.hd spec_args = `Free then - true (* wildcard as an argument matches everything *) - else if List.compare_lengths arglist spec_args <> 0 then ( - M.debug ~category:Analyzer "SKIP the number of arguments doesn't match the specification!"; - false - )else - List.for_all2 (SpecCheck.equal_exp ctx) spec_args cil_args (* TODO Cil.constFold true arg. Test: Spec and c-file: 1+1 *) - in - (* function name must fit the constraint *) - SC.fname_is f.vname c && - (* right form (assignment or not) *) - SC.equal_form lval c && - (* function arguments match those of the constraint *) - equal_args (SC.get_fun_args c) arglist - in - SpecCheck.check ctx get_key matches - - - let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local - let exitstate v = D.bot () -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/common/util/options.schema.json b/src/common/util/options.schema.json index 7c921c4f53..4d9546a9ca 100644 --- a/src/common/util/options.schema.json +++ b/src/common/util/options.schema.json @@ -467,32 +467,6 @@ }, "additionalProperties": false }, - "file": { - "title": "ana.file", - "type": "object", - "properties": { - "optimistic": { - "title": "ana.file.optimistic", - "description": "Assume fopen never fails.", - "type": "boolean", - "default": false - } - }, - "additionalProperties": false - }, - "spec": { - "title": "ana.spec", - "type": "object", - "properties": { - "file": { - "title": "ana.spec.file", - "description": "Path to the specification file.", - "type": "string", - "default": "" - } - }, - "additionalProperties": false - }, "pml": { "title": "ana.pml", "type": "object", diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 70f331b5ac..d4f2982902 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -147,12 +147,10 @@ module UnitAnalysis = UnitAnalysis (** {2 Other} *) module Assert = Assert -module FileUse = FileUse module LoopTermination = LoopTermination module Uninit = Uninit module Expsplit = Expsplit module StackTrace = StackTrace -module Spec = Spec (** {2 Helper} diff --git a/src/main.camldoc b/src/main.camldoc index ec08a14a7b..0a0e52035f 100644 --- a/src/main.camldoc +++ b/src/main.camldoc @@ -85,7 +85,6 @@ FlagModeDomain LockDomain StackDomain FileDomain -SpecDomain LvalMapDomain } @@ -106,7 +105,6 @@ Glob {!modules: MCP Base -Spec CondVars Contain diff --git a/src/mainspec.ml b/src/mainspec.ml deleted file mode 100644 index 4509645f98..0000000000 --- a/src/mainspec.ml +++ /dev/null @@ -1,13 +0,0 @@ -open Goblint_lib -open Batteries (* otherwise open_in would return wrong type for SpecUtil *) -open SpecUtil - -let _ = - (* no arguments -> run interactively (= reading from stdin) *) - let args = Array.length Sys.argv > 1 in - if args && Sys.argv.(1) = "-" then - ignore(parse ~dot:true stdin) - else - let cin = if args then open_in Sys.argv.(1) else stdin in - ignore(parse ~repl:(not args) ~print:true cin) -(* exit 0 *) diff --git a/src/spec/dune b/src/spec/dune deleted file mode 100644 index 47c22a0d46..0000000000 --- a/src/spec/dune +++ /dev/null @@ -1,2 +0,0 @@ -(ocamllex specLexer) -(ocamlyacc specParser) diff --git a/src/spec/file.dot b/src/spec/file.dot deleted file mode 100644 index a78c64d3fc..0000000000 --- a/src/spec/file.dot +++ /dev/null @@ -1,37 +0,0 @@ -digraph file { - // changed file pointer {fp} (no longer safe) - - // file handle is not saved! - // overwriting still opened file handle - // file is never closed - // file may be never closed - // closeing unopened file handle - // closeing already closed file handle - // writing to closed file handle - // writing to unopened file handle - // writing to read-only file handle - - // unclosed files: ... - // maybe unclosed files: ... - - w1 [label="file handle is not saved!"]; - w2 [label="closeing unopened file handle"]; - w3 [label="writing to unopened file handle"]; - w4 [label="writing to read-only file handle"]; - w5 [label="closeing already closed file handle"]; - w6 [label="writing to closed file handle"]; - - 1 -> w1 [label="fopen(_)"]; - 1 -> w2 [label="fclose($fp)"]; - 1 -> w3 [label="fprintf($fp, _)"]; - 1 -> open_read [label="$fp = fopen($path, \"r\")"]; - 1 -> open_write [label="$fp = fopen($path, \"w\")"]; - 1 -> open_write [label="$fp = fopen($path, \"a\")"]; - open_read -> w4 [label="fprintf($fp, _)"]; - open_write -> open_write [label="fprintf($fp, _)"]; - open_read -> closed [label="fclose($fp)"]; - open_write -> closed [label="fclose($fp)"]; - closed -> w5 [label="fclose($fp)"]; - closed -> w6 [label="fprintf($fp, _)"]; - closed -> 1 [label="->"]; -} \ No newline at end of file diff --git a/src/spec/render.sh b/src/spec/render.sh deleted file mode 100755 index 91e486c247..0000000000 --- a/src/spec/render.sh +++ /dev/null @@ -1,31 +0,0 @@ -# command -v ls >&- || {echo >&2 bla; exit 1;} -function check(){ - set -e # needed to exit script from function - hash $1 2>&- || (echo >&2 "$1 is needed but not installed! $2"; exit 1;) - set +e # do not exit shell if some command fails (default) -} -check dot -mode=${1-"png"} -file=${2-"file"} -dst=graph -viewcmd=gpicview - -mkdir -p ${dst} -cp ${file}.dot ${dst} -file=${file##*/} # use basename in case the file was somewhere else -cd ${dst} -trap 'cd ..' EXIT # leave dst again on exit -case "$mode" in - png) dot -Tpng -o${file}.png ${file}.dot; - check ${viewcmd} "Please edit viewcmd accordingly." - pkill ${viewcmd}; - ${viewcmd} ${file}.png & - ;; - pdf) rm -f ${file}.tex; - check dot2tex - dot -Txdot ${file}.dot | dot2tex > ${file}.tex; - check pdflatex - pdflatex ${file}.tex - echo "generated $dst/$file.pdf" - ;; -esac diff --git a/src/spec/specCore.ml b/src/spec/specCore.ml deleted file mode 100644 index 9d0ce35624..0000000000 --- a/src/spec/specCore.ml +++ /dev/null @@ -1,152 +0,0 @@ -(* types used by specParser and functions for handling the constructed types *) - -open Batteries - -exception Endl -exception Eof - -(* type value = String of string | Bool of bool | Int of int | Float of float *) -type lval = Ptr of lval | Var of string | Ident of string -type fcall = {fname: string; args: exp list} -and exp = - Fun of fcall | - Exp_ | - Lval of lval | - Regex of string | - String of string | Bool of bool | Int of int | Float of float | - Binop of string * exp * exp | - Unop of string * exp -type stmt = {lval: lval option; exp: exp} -type def = Node of (string * string) (* node warning *) - | Edge of (string * string list * bool * string * stmt) (* start-node, warning-nodes, forwarding, target-node, constraint *) - -(* let stmts edges = List.map (fun (a,b,c) -> c) edges - let get_fun stmt = match stmt.exp with Fun x -> Some x | _ -> None - let fun_records edges = List.filter_map get_fun (stmts edges) - let fun_names edges = fun_records edges |> List.map (fun x -> x.fname) - let fun_by_fname fname edges = List.filter (fun x -> x.fname=fname) (fun_records edges) *) -let fname_is fname stmt = - match stmt.exp with - | Fun x -> x.fname=fname - | _ -> false - -let is_wildcard stmt = stmt.exp = Exp_ - -let branch_exp stmt = - match stmt.exp with - | Fun { fname="branch"; args=[exp; Bool tv] } -> Some (exp,tv) - | _ -> None - -let is_branch stmt = branch_exp stmt <> None - -let startnode edges = - (* The start node of the first transition is the start node of the automaton. *) - let a,ws,fwd,b,c = List.hd edges in a - -let warning state nodes = - try - Some (snd (List.find (fun x -> fst x = state) nodes)) (* find node for state and return its warning *) - with - | Not_found -> None (* no node for state *) - -let get_lval stmt = - let f = function - | Ptr x -> `Ptr (* TODO recursive *) - | Var s -> `Var - | Ident s -> `Ident - in - Option.map f stmt.lval - -let get_exp = function - | Regex x -> `Regex x - | String x -> `String x - | Bool x -> `Bool x - | Int x -> `Int x - | Float x -> `Float x - | Lval (Var x) -> `Var x - | Lval (Ident x) -> `Ident x - | Fun x -> `Error "Functions aren't allowed to have functions as an argument (put the function as a previous state instead)" - | Exp_ -> `Free - | Unop ("!", Bool x) -> `Bool (not x) - | _ -> `Error "Unsupported operation inside function argument, use a simpler expression instead." - -let get_rval stmt = get_exp stmt.exp - -let get_key_variant stmt = - let rec get_from_exp = function - | Fun f -> get_from_args f.args (* TODO for special we only consider constraints where the root of the exp is Fun (see fname_is) *) - | Lval (Var s) -> `Rval s - | _ -> `None - (* walks over arguments until it finds something or returns `None *) - and get_from_argsi i = function - | [] -> `None - | x::xs -> - match get_from_exp x with - | `Rval s -> `Arg(s, i) - | _ -> get_from_argsi (i+1) xs (* matches `None and `Arg -> `Arg of `Arg not supported *) - and get_from_args args = get_from_argsi 0 args (* maybe better use List.findi *) - in - let rec get_from_lval = function - | Ptr x -> get_from_lval x - | Var s -> Some s - | Ident s -> None - in - match stmt.lval with - | Some lval when Option.is_some (get_from_lval lval) -> `Lval (Option.get (get_from_lval lval)) - | _ -> get_from_exp stmt.exp - -let equal_form lval stmt = - match lval, stmt.lval with - | Some _, Some _ - | None, None -> true - | _ -> false - -(* get function arguments with tags corresponding to the type -> should only be called for functions, returns [] for everything else *) -let get_fun_args stmt = match stmt.exp with - | Fun f -> List.map get_exp f.args - | _ -> [] - -(* functions for output *) -let rec lval_to_string = function - | Ptr x -> "*"^(lval_to_string x) - | Var x -> "$"^x - | Ident x -> x -let rec exp_to_string = function - | Fun x -> x.fname^"("^String.concat ", " (List.map exp_to_string x.args)^")" - | Exp_ -> "_" - | Lval x -> lval_to_string x - | Regex x -> "r\""^x^"\"" - | String x -> "\""^x^"\"" - | Bool x -> string_of_bool x - | Int x -> string_of_int x - | Float x -> string_of_float x - | Binop (op, a, b) -> exp_to_string a ^ " " ^ op ^ " " ^ exp_to_string b - | Unop (op, a) -> op ^ " " ^ exp_to_string a -let stmt_to_string stmt = match stmt.lval, stmt.exp with - | Some lval, exp -> lval_to_string lval^" = "^exp_to_string exp - | None, exp -> exp_to_string exp -let arrow_to_string ws fwd = (String.concat "," ws)^if fwd then ">" else "" -let def_to_string = function - | Node(n, m) -> n^"\t\""^m^"\"" - | Edge(a, ws, fwd, b, s) -> a^" -"^arrow_to_string ws fwd^"> "^b^"\t"^stmt_to_string s - -let to_dot_graph defs = - let no_warnings = true in - let def_to_string = function - | Node(n, m) -> - if no_warnings then "" - else n^"\t[style=filled, fillcolor=orange, label=\""^n^": "^m^"\"];" - | Edge(a, ws, fwd, b, s) -> - let style = if fwd then "style=dotted, " else "" in - let ws = if List.is_empty ws then "" else (String.concat "," ws)^" | " in - a^" -> "^b^"\t["^style^"label=\""^ws^String.escaped (stmt_to_string s)^"\"];" - in - let ends,defs = List.partition (function Edge (a,ws,fwd,b,s) -> b="end" && s.exp=Exp_ | _ -> false) defs in - let endstates = List.filter_map (function Edge (a,ws,fwd,b,s) -> Some a | _ -> None) ends in - (* set the default style for nodes *) - let defaultstyle = "node [shape=box, style=rounded];" in - (* style end nodes and then reset *) - let endstyle = if List.is_empty endstates then "" else "node [peripheries=2]; "^(String.concat " " endstates)^"; node [peripheries=1];" in - let lines = "digraph file {"::defaultstyle::endstyle::(List.map def_to_string defs |> List.filter (fun s -> s<>"")) in - (* List.iter print_endline lines *) - String.concat "\n " lines ^ "\n}" diff --git a/src/spec/specLexer.mll b/src/spec/specLexer.mll deleted file mode 100644 index 64ac69359e..0000000000 --- a/src/spec/specLexer.mll +++ /dev/null @@ -1,67 +0,0 @@ -{ - open SpecParser (* The type token is defined in specParser.mli *) - exception Token of string - let line = ref 1 -} - -let digit = ['0'-'9'] -let alpha = ['a'-'z' 'A'-'Z'] -let nl = '\r'?'\n' (* new line *) -let s = [' ' '\t'] (* whitespace *) -let w = '_' | alpha | digit (* word *) -let endlinecomment = "//" [^'\n']* -let multlinecomment = "/*"([^'*']|('*'+[^'*''/'])|nl)*'*'+'/' -let comments = endlinecomment | multlinecomment -let str = ('\"'(([^'\"']|"\\\"")* as s)'\"') | ('\''(([^'\'']|"\\'")* as s)'\'') - -rule token = parse - | s { token lexbuf } (* skip blanks *) - | comments { token lexbuf } (* skip comments *) - | nl { incr line; EOL } - - (* operators *) - | '(' { LPAREN } - | ')' { RPAREN } - | '[' { LBRACK } - | ']' { RBRACK } - | '{' { LCURL } - | '}' { RCURL } - (*| '.' { DOT } *) - (*| "->" { ARROW } *) - | '+' { PLUS } - | '-' { MINUS } - | '*' { MUL } - | '/' { DIV } - | '%' { MOD } - | '<' { LT } - | '>' { GT } - | "==" { EQEQ } - | "!=" { NE } - | "<=" { LE } - | ">=" { GE } - | "&&" { AND } - | "||" { OR } - | '!' { NOT } - | '=' { EQ } - | ',' { COMMA } - | ';' { SEMICOLON } - - (* literals, identifiers *) - | "true" { BOOL(true) } - | "false" { BOOL(false) } - | "null" { NULL } - | digit+ as x { INT(int_of_string x) } - | str { STRING(s) } - | '_' { UNDERS } (* used for spec, but has to be before Ident! *) - | ('_'|alpha) w* as x { IDENT(x) } - - (* spec *) - | ':' { COLON } - | "$"(w+ as x) { VAR(x) } - | "r" str { REGEX(s) } - | (w+ as n) s+ str - { NODE(n, s) } - | (w+ as a) s* "-" ((w+ ("," w+)*)? as ws) (">"? as fwd) ">" s* (w+ as b) s+ - { EDGE(a, BatString.split_on_string ~by:"," ws, fwd=">", b) } - | eof { EOF } - | _ as x { raise(Token (Char.escaped x^": unknown token in line "^string_of_int !line)) } diff --git a/src/spec/specParser.mly b/src/spec/specParser.mly deleted file mode 100644 index fe8fe90ec8..0000000000 --- a/src/spec/specParser.mly +++ /dev/null @@ -1,116 +0,0 @@ -%{ - (* necessary to open a different compilation unit - because exceptions directly defined here aren't visible outside - (e.g. SpecParser.Eof is raised, but Error: Unbound constructor - if used to catch in a different module) *) - open SpecCore -%} - -%token EOL EOF -/* operators */ -%token LPAREN RPAREN LCURL RCURL LBRACK RBRACK -%token PLUS MINUS MUL DIV MOD -%token LT GT EQEQ NE LE GE AND OR NOT -%token EQ COMMA SEMICOLON -/* literals, identifiers */ -%token BOOL -%token NULL -%token INT -%token STRING -%token IDENT -/* spec */ -%token UNDERS COLON -%token VAR -%token REGEX -%token NODE -%token EDGE - -/* precedence groups from low to high */ -%right EQ -%left OR -%left AND -%left EQEQ NE -%left LT GT LE GE -%left PLUS MINUS -%left MUL DIV MOD -%right NOT UPLUS UMINUS DEREF - -%start file -%type file - -%% - -file: - | def EOL { $1 } - | def EOF { $1 } /* no need for an empty line at the end */ - | EOL { raise Endl } /* empty line */ - | EOF { raise Eof } /* end of file */ -; - -def: - | NODE { Node($1) } - | EDGE stmt { let a, ws, fwd, b = $1 in Edge(a, ws, fwd, b, $2) } -; - -stmt: - | lval EQ expr { {lval = Some $1; exp = $3} } /* TODO expression would be better */ - | expr { {lval = None; exp = $1} } -; - -lval: - | MUL lval %prec DEREF { Ptr $2 } - | IDENT { Ident $1 } /* C identifier, e.g. foo, _foo, _1, but not 1b */ - | VAR { Var $1 } /* spec variable, e.g. $foo, $123, $__ */ -; - -expr: - | LPAREN expr RPAREN { $2 } - | REGEX { Regex $1 } - | STRING { String $1 } - | BOOL { Bool $1 } - | lval { Lval $1 } - | IDENT args { Fun {fname=$1; args=$2} } /* function */ - | UNDERS { Exp_ } - | nexpr { Int $1 } - /* | nexpr LT nexpr { Bool ($1<$3) } - | nexpr GT nexpr { Bool ($1>$3) } - | nexpr EQEQ nexpr { Bool ($1=$3) } - | nexpr NE nexpr { Bool ($1<>$3) } - | nexpr LE nexpr { Bool ($1<=$3) } - | nexpr GE nexpr { Bool ($1>=$3) } */ - | expr OR expr { Binop ("||", $1, $3) } - | expr AND expr { Binop ("&&", $1, $3) } - | expr EQEQ expr { Binop ("==", $1, $3) } - | expr NE expr { Binop ("!=", $1, $3) } - | expr LT expr { Binop ("<", $1, $3) } - | expr GT expr { Binop (">", $1, $3) } - | expr LE expr { Binop ("<=", $1, $3) } - | expr GE expr { Binop (">=", $1, $3) } - | expr PLUS expr { Binop ("+", $1, $3) } - | expr MINUS expr { Binop ("-", $1, $3) } - | expr MUL expr { Binop ("*", $1, $3) } - | expr DIV expr { Binop ("/", $1, $3) } - | expr MOD expr { Binop ("%", $1, $3) } - | NOT expr { Unop ("!", $2) } -; - -nexpr: - | INT { $1 } - | MINUS nexpr %prec UMINUS { - $2 } - | PLUS nexpr %prec UPLUS { $2 } - /* | LPAREN nexpr RPAREN { $2 } - | nexpr PLUS nexpr { $1 + $3 } - | nexpr MINUS nexpr { $1 - $3 } - | nexpr MUL nexpr { $1 * $3 } - | nexpr DIV nexpr { $1 / $3 } */ -; - -args: - | LPAREN RPAREN { [] } - | LPAREN expr_list RPAREN { $2 } -; - -expr_list: - | expr { [$1] } - | expr COMMA expr_list { $1 :: $3 } -; diff --git a/src/spec/specUtil.ml b/src/spec/specUtil.ml deleted file mode 100644 index 55e0b51135..0000000000 --- a/src/spec/specUtil.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* functions for driving specParser *) - -open Batteries - -(* config *) -let save_dot = true - -let line = ref 1 -exception Parse_error of string - -let parse ?repl:(repl=false) ?print:(print=false) ?dot:(dot=false) cin = - let lexbuf = Lexing.from_channel cin in - let defs = ref [] in - (* Printf.printf "\nrepl: %B, print: %B, dot: %B, save_dot: %B\n" repl print dot save_dot; *) - try - while true do (* loop over all lines *) - try - let result = SpecParser.file SpecLexer.token lexbuf in - defs := !defs@[result]; - incr line; - if print then (print_endline (SpecCore.def_to_string result); flush stdout) - with - (* just an empty line -> don't print *) - | SpecCore.Endl -> incr line - (* somehow gets raised in some cases instead of SpecCore.Eof *) - | BatInnerIO.Input_closed -> raise SpecCore.Eof - (* catch and print in repl-mode *) - | e when repl -> print_endline (Printexc.to_string e) - done; - ([], []) (* never happens, but ocaml needs it for type *) - with - (* done *) - | SpecCore.Eof -> - let nodes = List.filter_map (function SpecCore.Node x -> Some x | _ -> None) !defs in - let edges = List.filter_map (function SpecCore.Edge x -> Some x | _ -> None) !defs in - if print then Printf.printf "\n#Definitions: %i, #Nodes: %i, #Edges: %i\n" - (List.length !defs) (List.length nodes) (List.length edges); - if save_dot && not dot then ( - let dotgraph = SpecCore.to_dot_graph !defs in - output_file ~filename:"result/graph.dot" ~text:dotgraph; - print_endline ("saved graph as "^Sys.getcwd ()^"/result/graph.dot"); - ); - if dot then ( - print_endline (SpecCore.to_dot_graph !defs) - ); - (nodes, edges) - (* stop on parsing error if not in REPL and include line number *) - | e -> raise (Parse_error ("Line "^string_of_int !line^": "^Printexc.to_string e)) - -let parseFile filename = parse (open_in filename) - -(* print ~first:"[" ~sep:", " ~last:"]" print_any stdout @@ 5--10 *) diff --git a/tests/regression/18-file/01-ok.c b/tests/regression/18-file/01-ok.c deleted file mode 100644 index 5c1f21ff1c..0000000000 --- a/tests/regression/18-file/01-ok.c +++ /dev/null @@ -1,12 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/02-function.c b/tests/regression/18-file/02-function.c deleted file mode 100644 index fc3157c264..0000000000 --- a/tests/regression/18-file/02-function.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -void f(){ - fp = fopen("test.txt", "a"); -} - -int main(){ - f(); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/03-if-close.c b/tests/regression/18-file/03-if-close.c deleted file mode 100644 index b2bf1ebe97..0000000000 --- a/tests/regression/18-file/03-if-close.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - fprintf(fp, "Testing...\n"); - - if (b) - fclose(fp); -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/04-no-open.c b/tests/regression/18-file/04-no-open.c deleted file mode 100644 index 70683f3852..0000000000 --- a/tests/regression/18-file/04-no-open.c +++ /dev/null @@ -1,10 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fprintf(fp, "Testing...\n"); // WARN: writing to unopened file handle fp - fclose(fp); // WARN: closeing unopened file handle fp -} diff --git a/tests/regression/18-file/05-open-mode.c b/tests/regression/18-file/05-open-mode.c deleted file mode 100644 index 77326d7a70..0000000000 --- a/tests/regression/18-file/05-open-mode.c +++ /dev/null @@ -1,11 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fp = fopen("test.txt", "r"); - fprintf(fp, "Testing...\n"); // WARN: writing to read-only file handle fp - fclose(fp); -} diff --git a/tests/regression/18-file/06-2open.c b/tests/regression/18-file/06-2open.c deleted file mode 100644 index 2826c2f1dc..0000000000 --- a/tests/regression/18-file/06-2open.c +++ /dev/null @@ -1,12 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fp = fopen("test1.txt", "a"); // WARN: file is never closed - fp = fopen("test2.txt", "a"); // WARN: overwriting still opened file handle fp - fprintf(fp, "Testing...\n"); - fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/07-2close.c b/tests/regression/18-file/07-2close.c deleted file mode 100644 index 0545bf9814..0000000000 --- a/tests/regression/18-file/07-2close.c +++ /dev/null @@ -1,11 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - fclose(fp); // WARN: closeing already closed file handle fp -} diff --git a/tests/regression/18-file/08-var-reuse.c b/tests/regression/18-file/08-var-reuse.c deleted file mode 100644 index 1caa238517..0000000000 --- a/tests/regression/18-file/08-var-reuse.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - fp = fopen("test2.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/09-inf-loop-no-close.c b/tests/regression/18-file/09-inf-loop-no-close.c deleted file mode 100644 index e9563ef195..0000000000 --- a/tests/regression/18-file/09-inf-loop-no-close.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); // WARN: file is never closed - - while (i){ - fprintf(fp, "Testing...\n"); - i++; - } - - //fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/10-inf-loop-ok.c b/tests/regression/18-file/10-inf-loop-ok.c deleted file mode 100644 index d88fde272e..0000000000 --- a/tests/regression/18-file/10-inf-loop-ok.c +++ /dev/null @@ -1,19 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); - - while (i){ - fprintf(fp, "Testing...\n"); - i++; - } - - fclose(fp); -} - -// All ok. diff --git a/tests/regression/18-file/11-2if.c b/tests/regression/18-file/11-2if.c deleted file mode 100644 index e24fec6e46..0000000000 --- a/tests/regression/18-file/11-2if.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - if (b) - fclose(fp); - - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to closed file handle fp - - if (!b) - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/12-2close-if.c b/tests/regression/18-file/12-2close-if.c deleted file mode 100644 index 4934b33114..0000000000 --- a/tests/regression/18-file/12-2close-if.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - int b; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - - if (b) - fclose(fp); - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} diff --git a/tests/regression/18-file/13-ptr-arith-ok.c b/tests/regression/18-file/13-ptr-arith-ok.c deleted file mode 100644 index f707110957..0000000000 --- a/tests/regression/18-file/13-ptr-arith-ok.c +++ /dev/null @@ -1,16 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - - fp++; // WARN: changed pointer fp (no longer safe) - fp--; // WARN: changed pointer fp (no longer safe) - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp - -// OPT: All ok! diff --git a/tests/regression/18-file/14-ptr-arith-close.c b/tests/regression/18-file/14-ptr-arith-close.c deleted file mode 100644 index 3f9cd21ee2..0000000000 --- a/tests/regression/18-file/14-ptr-arith-close.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - - fp++; // WARN: changed pointer fp (no longer safe) - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/15-var-switch.c b/tests/regression/18-file/15-var-switch.c deleted file mode 100644 index d7f74b85db..0000000000 --- a/tests/regression/18-file/15-var-switch.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp2, "Testing...\n"); - - fp2 = fp1; - - fclose(fp1); - fclose(fp2); // WARN: closeing already closed file handle fp2 -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/16-var-reuse-close.c b/tests/regression/18-file/16-var-reuse-close.c deleted file mode 100644 index cb1fb5fd22..0000000000 --- a/tests/regression/18-file/16-var-reuse-close.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - - fp = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp, "Testing...\n"); - // fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/17-myfopen.c b/tests/regression/18-file/17-myfopen.c deleted file mode 100644 index 3e005c6e70..0000000000 --- a/tests/regression/18-file/17-myfopen.c +++ /dev/null @@ -1,21 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - - -FILE* myfopen(){ - // FILE *fp_tmp = fopen("test.txt", "a"); // local! - return fopen("test.txt", "a"); -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen(); - fp2 = myfopen(); // WARN: file is never closed - - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - // fclose(fp2); -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/18-myfopen-arg.c b/tests/regression/18-file/18-myfopen-arg.c deleted file mode 100644 index 5d98db4c53..0000000000 --- a/tests/regression/18-file/18-myfopen-arg.c +++ /dev/null @@ -1,20 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - - -FILE* myfopen(char* f){ - return fopen(f, "a"); -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen("test1.txt"); - fp2 = myfopen("test2.txt"); // WARN: file is never closed - - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - // fclose(fp2); -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/19-if-close-else.c b/tests/regression/18-file/19-if-close-else.c deleted file mode 100644 index 049e8454b4..0000000000 --- a/tests/regression/18-file/19-if-close-else.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); - - if (b) - fclose(fp); - else - fprintf(fp, "Testing...\n"); - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} diff --git a/tests/regression/18-file/20-loop-close.c b/tests/regression/18-file/20-loop-close.c deleted file mode 100644 index 981248c152..0000000000 --- a/tests/regression/18-file/20-loop-close.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - while (i){ // May closed (11, 3), open(test.txt, Write) (7, 3) - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to closed file handle fp - fclose(fp); // WARN: MAYBE closeing already closed file handle fp - i++; - } - // why: fp -> Must open(test.txt, Write) (7, 3) - // -> because loop wouldn't exit? -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/21-for-i.c b/tests/regression/18-file/21-for-i.c deleted file mode 100644 index e41bb9b005..0000000000 --- a/tests/regression/18-file/21-for-i.c +++ /dev/null @@ -1,26 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "w"); // WARN: MAYBE file is never closed - - for(i=1; i<10; i++){ // join - // i -> Unknown int - if(i%2){ - // i -> Unknown int - // fprintf(fp, "Testing...%s\n", i); // Segmentation fault! - // actually shouldn't warn because open and close are always alternating... - fprintf(fp, "Testing...%i\n", i); // WARN: MAYBE writing to closed file handle fp - fclose(fp); // WARN: MAYBE closeing already closed file handle fp - }else{ - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - } - // why no join? - } - // fp opened or closed? (last i=9 -> open) - // widening -> Warn: might be unclosed -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/22-f_int.c b/tests/regression/18-file/22-f_int.c deleted file mode 100644 index f0376fc5a9..0000000000 --- a/tests/regression/18-file/22-f_int.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int f(int x){ - return 2*x; -} - -int main(){ - int a = 1; - a = f(2); - return 0; -} diff --git a/tests/regression/18-file/23-f_str.c b/tests/regression/18-file/23-f_str.c deleted file mode 100644 index 81224d2e72..0000000000 --- a/tests/regression/18-file/23-f_str.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -char* f(char* x){ - return x; -} - -int main(){ - char* a = "foo"; - a = f("bar"); - return 0; -} diff --git a/tests/regression/18-file/24-f_wstr.c b/tests/regression/18-file/24-f_wstr.c deleted file mode 100644 index 2379c1f718..0000000000 --- a/tests/regression/18-file/24-f_wstr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include -#include - -wchar_t* f(wchar_t* x){ - return x; -} - -int main(){ - wchar_t* a = L"foo"; - a = f(L"bar"); - return 0; -} diff --git a/tests/regression/18-file/25-mem-ok.c b/tests/regression/18-file/25-mem-ok.c deleted file mode 100644 index 00ba189b8d..0000000000 --- a/tests/regression/18-file/25-mem-ok.c +++ /dev/null @@ -1,29 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp[3]; - // Array -> varinfo with index-offset - fp[1] = fopen("test.txt", "a"); - fprintf(fp[1], "Testing...\n"); - fclose(fp[1]); - - - struct foo { - int i; - FILE *fp; - } bar; - // Struct -> varinfo with field-offset - bar.fp = fopen("test.txt", "a"); - fprintf(bar.fp, "Testing...\n"); - fclose(bar.fp); - - - // Pointer -> Mem exp - *(fp+2) = fopen("test.txt", "a"); - fprintf(*(fp+2), "Testing...\n"); - fclose(*(fp+2)); -} - -// All ok! diff --git a/tests/regression/18-file/26-open-error-ok.c b/tests/regression/18-file/26-open-error-ok.c deleted file mode 100644 index 5cf3aaf7bb..0000000000 --- a/tests/regression/18-file/26-open-error-ok.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main (){ - FILE *fp; - fp = fopen("test.txt", "w"); - - if(fp!=NULL){ - fprintf(fp, "Testing..."); - fclose(fp); - } -} - -// All ok! diff --git a/tests/regression/18-file/27-open-error.c b/tests/regression/18-file/27-open-error.c deleted file mode 100644 index bd3048208f..0000000000 --- a/tests/regression/18-file/27-open-error.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main (){ - FILE *fp; - fp = fopen("test.txt", "w"); // WARN: MAYBE file is never closed - - if(fp==NULL){ - fprintf(fp, "Testing..."); // WARN: writing to unopened file handle fp - fclose(fp); // WARN: closeing unopened file handle fp - } -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/28-multiple-exits.c b/tests/regression/18-file/28-multiple-exits.c deleted file mode 100644 index 04fa5abab0..0000000000 --- a/tests/regression/18-file/28-multiple-exits.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - int b; - if(b) - return 1; // WARN: unclosed files: fp - fclose(fp); - return 0; -} diff --git a/tests/regression/18-file/29-alias-global.c b/tests/regression/18-file/29-alias-global.c deleted file mode 100644 index 17b94748c0..0000000000 --- a/tests/regression/18-file/29-alias-global.c +++ /dev/null @@ -1,22 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE* fp; -FILE* myfopen(char* f){ - fp = fopen(f, "a"); - return fp; -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen("test1.txt"); - fp2 = myfopen("test2.txt"); - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - fclose(fp2); -} - -// All ok! diff --git a/tests/regression/18-file/30-ptr-of-ptr.c b/tests/regression/18-file/30-ptr-of-ptr.c deleted file mode 100644 index 5a8d1f97a9..0000000000 --- a/tests/regression/18-file/30-ptr-of-ptr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - FILE **fp2; - - fp2 = &fp1; - - fclose(fp1); - fclose(*fp2); // WARN: closeing already closed file handle fp1 -} diff --git a/tests/regression/18-file/31-var-reuse-fun.c b/tests/regression/18-file/31-var-reuse-fun.c deleted file mode 100644 index 9c0ccb16a2..0000000000 --- a/tests/regression/18-file/31-var-reuse-fun.c +++ /dev/null @@ -1,16 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE* myfopen(char* f){ - FILE* fp; - fp = fopen(f, "a"); - return fp; -} - -int main(){ - FILE *fp; - fp = fopen("test1.txt", "a"); // WARN: file is never closed - fp = myfopen("test2.txt"); // WARN: overwriting still opened file handle fp - fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/32-multi-ptr-close.c b/tests/regression/18-file/32-multi-ptr-close.c deleted file mode 100644 index e252d563a5..0000000000 --- a/tests/regression/18-file/32-multi-ptr-close.c +++ /dev/null @@ -1,25 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test2.txt", "a"); - fprintf(fp2, "Testing...\n"); - - FILE **fp; - int b; - if(b){ - fp = &fp1; - }else{ - fp = &fp2; - } - - fclose(*fp); - fclose(fp1); // WARN: MAYBE closeing already closed file handle fp1 - fclose(fp2); // WARN: MAYBE closeing already closed file handle fp2 -} diff --git a/tests/regression/18-file/33-multi-ptr-open.c b/tests/regression/18-file/33-multi-ptr-open.c deleted file mode 100644 index b3cfa0ade4..0000000000 --- a/tests/regression/18-file/33-multi-ptr-open.c +++ /dev/null @@ -1,23 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); // WARN: MAYBE file is never closed - - FILE *fp2; - fp2 = fopen("test2.txt", "r"); // WARN: MAYBE file is never closed - - FILE **fp; - int b; - if(b){ - fp = &fp1; - }else{ - fp = &fp2; - } - - fprintf(*fp, "Testing...\n"); // WARN: MAYBE writing to read-only file handle fp - - fclose(*fp); -} // WARN: MAYBE unclosed files: fp1, fp2 diff --git a/tests/regression/18-file/34-multi-alias-close.c b/tests/regression/18-file/34-multi-alias-close.c deleted file mode 100644 index 0ebb9ddd30..0000000000 --- a/tests/regression/18-file/34-multi-alias-close.c +++ /dev/null @@ -1,25 +0,0 @@ -// SKIP PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test2.txt", "a"); - fprintf(fp2, "Testing...\n"); - - FILE *fp; - int b; - if(b){ - fp = fp1; - }else{ - fp = fp2; - } - - fclose(fp); - fclose(fp1); // WARN: MAYBE closeing already closed file handle fp1 - fclose(fp2); // WARN: MAYBE closeing already closed file handle fp2 -} diff --git a/tests/regression/18-file/35-multi-alias-open.c b/tests/regression/18-file/35-multi-alias-open.c deleted file mode 100644 index 21a4a9cca6..0000000000 --- a/tests/regression/18-file/35-multi-alias-open.c +++ /dev/null @@ -1,23 +0,0 @@ -// SKIP PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); // WARN: MAYBE file is never closed - - FILE *fp2; - fp2 = fopen("test2.txt", "r"); // WARN: MAYBE file is never closed - - FILE *fp; - int b; - if(b){ - fp = fp1; - }else{ - fp = fp2; - } - - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to read-only file handle fp - - fclose(fp); -} // WARN: MAYBE unclosed files: fp1, fp2 diff --git a/tests/regression/18-file/36-fun-ptr.c b/tests/regression/18-file/36-fun-ptr.c deleted file mode 100644 index 4f70bf7382..0000000000 --- a/tests/regression/18-file/36-fun-ptr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - FILE* (*f)(const char *, const char*); - f = fopen; - fp = f("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/37-var-switch-alias.c b/tests/regression/18-file/37-var-switch-alias.c deleted file mode 100644 index 5dfde5a2d9..0000000000 --- a/tests/regression/18-file/37-var-switch-alias.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp2, "Testing...\n"); - - fp2 = fp1; - - fclose(fp2); - fclose(fp1); // WARN: closeing already closed file handle fp1 -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/README.md b/tests/regression/18-file/README.md new file mode 100644 index 0000000000..0e93e175c6 --- /dev/null +++ b/tests/regression/18-file/README.md @@ -0,0 +1,2 @@ +The file analysis has been removed from recent Goblint versions, please use Release 2.3.0 +Folder is left in place to avoid renumbering all tests diff --git a/tests/regression/18-file/file.c b/tests/regression/18-file/file.c deleted file mode 100644 index fc2ebe1699..0000000000 --- a/tests/regression/18-file/file.c +++ /dev/null @@ -1,44 +0,0 @@ -#include - -int main(){ - - // no errors - FILE *fp; - fp = fopen("test.txt", "a"); - if(fp!=0) { - fprintf(fp, "Testing...\n"); - fclose(fp); - } - - // missing fopen -> compiles, but leads to Segmentation fault - FILE *fp2; - // fp2 = fopen("test.txt", "a"); - fprintf(fp2, "Testing...\n"); // WARN - fclose(fp2); // WARN - - // writing to a read-only file -> doesn't do anything - FILE *fp3; - fp3 = fopen("test.txt", "r"); - fprintf(fp3, "Testing...\n"); // (WARN) - fclose(fp3); - - // accessing closed file -> write doesn't do anything - FILE *fp4; - fp4 = fopen("test.txt", "a"); - fclose(fp4); - fprintf(fp4, "Testing...\n"); // WARN - - // missing fclose - FILE *fp5; - fp5 = fopen("test.txt", "a"); // WARN - fprintf(fp5, "Testing...\n"); - - // missing assignment to file handle - fopen("test.txt", "a"); // WARN - - - // bad style: - // opening file but not doing anything - - return 0; // WARN about all unclosed files -} \ No newline at end of file diff --git a/tests/regression/18-file/file.optimistic.spec b/tests/regression/18-file/file.optimistic.spec deleted file mode 100644 index d42e2217b7..0000000000 --- a/tests/regression/18-file/file.optimistic.spec +++ /dev/null @@ -1,34 +0,0 @@ -w1 "file handle is not saved!" -w2 "closeing unopened file handle $" -w3 "writing to unopened file handle $" -w4 "writing to read-only file handle $" -w5 "closeing already closed file handle $" -w6 "writing to closed file handle $" -w7 "overwriting still opened file handle $" -w8 "unrecognized file open mode for file handle $" - -1 -> w1 fopen(_, _) -1 -> w2 fclose($fp) -1 -> w3 fprintf($fp, _) -1 -> open_read $fp = fopen(path, "r") -1 -> open_write $fp = fopen(path, r"[wa]") // see OCaml doc for details (e.g. \\| for alternatives) -1 -> w8 $fp = fopen(path, _) - -open_read -> w4 fprintf($fp, _) - -open_read -w7>> 1 $fp = fopen(path, _) -open_write -w7>> 1 $fp = fopen(path, _) - -open_read -> closed fclose($fp) -open_write -> closed fclose($fp) - -closed -> w5 fclose($fp) -closed -> w6 fprintf($fp, _) -closed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -closed -> end _ -// warning for all entries that are not in an end state -_end "file is never closed" -_END "unclosed files: $" \ No newline at end of file diff --git a/tests/regression/18-file/file.spec b/tests/regression/18-file/file.spec deleted file mode 100644 index aeb747abfd..0000000000 --- a/tests/regression/18-file/file.spec +++ /dev/null @@ -1,57 +0,0 @@ -w1 "file handle is not saved!" -w2 "closeing unopened file handle $" -w3 "writing to unopened file handle $" -w4 "writing to read-only file handle $" -w5 "closeing already closed file handle $" -w6 "writing to closed file handle $" -w7 "overwriting still opened file handle $" -w8 "unrecognized file open mode for file handle $" - -// TODO later add fputs and stuff -1 -> w1 fopen(_, _) -1 -> w2 fclose($fp) -1 -> w3 fprintf($fp, _) -//1 -> open_read $fp = fopen(path, "r") -//1 -> open_write $fp = fopen(path, r"[wa]") // see OCaml doc for details (e.g. \\| for alternatives) -//1 -> w8 $fp = fopen(path, _) - -// go to unchecked states first -1 -> u_open_read $fp = fopen(path, "r") -1 -> u_open_write $fp = fopen(path, r"[wa]") -1 -> w8 $fp = fopen(path, _) -// once branch(exp, tv) is matched, return dom with 1. arg (lval = exp) and true/false -// forwarding from branch is not possible (would need an extra map for storing states) -> ignore it -// warnings are also ignored -// then in branch take out lval, check exp and do the transition to a checked state -u_open_read -> 1 branch($key==0, true) -u_open_read -> open_read branch($key==0, false) -u_open_write -> 1 branch($key==0, true) -u_open_write -> open_write branch($key==0, false) - -// alternative: forward everything. Problem: saving arguments of call (special_fn -> branch -> special_fn) -// 1 ->> open_check $fp = fopen(path, _) -// open_check ->> 1 branch($fp==0, true) -// open_check ->> open branch($fp==0, false) -// open -> open_read $fp = fopen(path, "r") -// open -> open_write $fp = fopen(path, "[wa]") -// open -> w8 $fp = fopen(path, _) - -open_read -> w4 fprintf($fp, _) -// open_write -> open_write fprintf($fp, _) // not needed, but changes loc - -open_read -w7>> 1 $fp = fopen(path, _) -open_write -w7>> 1 $fp = fopen(path, _) - -open_read -> closed fclose($fp) -open_write -> closed fclose($fp) - -closed -> w5 fclose($fp) -closed -> w6 fprintf($fp, _) -closed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -closed -> end _ -// warning for all entries that are not in an end state -_end "file is never closed" -_END "unclosed files: $" \ No newline at end of file diff --git a/tests/regression/19-spec/01-malloc-free.c b/tests/regression/19-spec/01-malloc-free.c deleted file mode 100644 index 43ee527dba..0000000000 --- a/tests/regression/19-spec/01-malloc-free.c +++ /dev/null @@ -1,19 +0,0 @@ -#include -#include - -int main(){ - int *ip; - //*ip = 5; // segfault - //printf("%i", *ip); // segfault - ip = malloc(sizeof(int)); // assume malloc never fails - - // do stuff - //*ip = 5; - - free(ip); - //free(ip); // crash: double free or corruption - *ip = 5; // undefined but no crash - printf("%i", *ip); // undefined but printed 5 - ip = NULL; // make sure the pointer is not used anymore - *ip = 5; // segfault -} diff --git a/tests/regression/19-spec/02-mutex_rc.c b/tests/regression/19-spec/02-mutex_rc.c deleted file mode 100644 index 82c1642a93..0000000000 --- a/tests/regression/19-spec/02-mutex_rc.c +++ /dev/null @@ -1,23 +0,0 @@ -#include -#include - -int myglobal; -pthread_mutex_t mutex1 = PTHREAD_MUTEX_INITIALIZER; -pthread_mutex_t mutex2 = PTHREAD_MUTEX_INITIALIZER; - -void *t_fun(void *arg) { - pthread_mutex_lock(&mutex1); - myglobal=myglobal+1; // RACE! - pthread_mutex_unlock(&mutex1); - return NULL; -} - -int main(void) { - pthread_t id; - pthread_create(&id, NULL, t_fun, NULL); - pthread_mutex_lock(&mutex2); - myglobal=myglobal+1; // RACE! - pthread_mutex_unlock(&mutex2); - pthread_join (id, NULL); - return 0; -} diff --git a/tests/regression/19-spec/README.md b/tests/regression/19-spec/README.md new file mode 100644 index 0000000000..d7e3ae3c8e --- /dev/null +++ b/tests/regression/19-spec/README.md @@ -0,0 +1,2 @@ +The spec analysis has been removed from recent Goblint versions, please use Release 2.3.0 +Folder is left in place to avoid renumbering all tests diff --git a/tests/regression/19-spec/malloc.optimistic.spec b/tests/regression/19-spec/malloc.optimistic.spec deleted file mode 100644 index 860c573814..0000000000 --- a/tests/regression/19-spec/malloc.optimistic.spec +++ /dev/null @@ -1,23 +0,0 @@ -w1 "pointer is not saved [leak]" -w2 "freeing unallocated pointer $ [segfault?]" -w3 "writing to unallocated pointer $ [segfault?]" -w4 "overwriting unfreed pointer $ [leak]" -w5 "freeing already freed pointer $ [double free!]" - -1 -w1> 1 malloc(_) -1 -w2> 1 free($p) -1 -w3> 1 *$p = _ -1 -> alloc $p = malloc(_) // TODO does compiler check size? - -alloc -w4> alloc $p = malloc(_) -alloc -> freed free($p) - -freed -w5> freed free($p) -freed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -freed -> end _ -// warning for all entries that are not in an end state -_end "pointer is never freed" -_END "unfreed pointers: $" \ No newline at end of file diff --git a/tests/regression/19-spec/malloc.spec b/tests/regression/19-spec/malloc.spec deleted file mode 100644 index 9f09430051..0000000000 --- a/tests/regression/19-spec/malloc.spec +++ /dev/null @@ -1,26 +0,0 @@ -w1 "pointer is not saved [leak]" -w2 "freeing unallocated pointer $ [segfault?]" -w3 "writing to unallocated pointer $ [segfault?]" -w4 "overwriting unfreed pointer $ [leak]" -w5 "freeing already freed pointer $ [double free!]" - -1 -w1> 1 malloc(_) -1 -w2> 1 free($p) -1 -w3> 1 *$p = _ -1 -> u_alloc $p = malloc(_) - -u_alloc -> 1 branch($key==0, true) -u_alloc -> alloc branch($key==0, false) - -alloc -w4> alloc $p = malloc(_) -alloc -> freed free($p) - -freed -w5> freed free($p) -freed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -freed -> end _ -// warning for all entries that are not in an end state -_end "pointer is never freed" -_END "unfreed pointers: $" \ No newline at end of file diff --git a/tests/regression/19-spec/mutex-lock.spec b/tests/regression/19-spec/mutex-lock.spec deleted file mode 100644 index 1ec8264078..0000000000 --- a/tests/regression/19-spec/mutex-lock.spec +++ /dev/null @@ -1,31 +0,0 @@ -w1 "unlocking not locked mutex" -w2 "locking already locked mutex" - -1 -w1> 1 pthread_mutex_unlock($p) -1 -> lock pthread_mutex_lock($p) - -lock -w2> lock pthread_mutex_lock($p) -lock -> 1 pthread_mutex_unlock($p) - -// setup which states are end states -1 -> end _ -// warning for all entries that are not in an end state -_end "mutex is never unlocked" -_END "locked mutexes: $" - - - -//w1 "joining not created thread" -//w2 "overwriting id of already created thread" -// -//1 -w1> 1 pthread_join ($p, _) -//1 -> created pthread_create($p, _, _, _) -// -//created -w2> created pthread_create($p, _, _, _) -//created -> 1 pthread_join ($p, _) -// -//// setup which states are end states -//1 -> end _ -//// warning for all entries that are not in an end state -//_end "thread is never joined" -//_END "unjoined threads: $" \ No newline at end of file From 9e0ef1cc2f5c0c553e92355907ea55b813f61d31 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 21:06:25 +0100 Subject: [PATCH 136/233] Rm: Mainspec --- scripts/goblint-lib-modules.py | 1 - src/dune | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 6369af53a1..6c264a117b 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -30,7 +30,6 @@ "MessagesCompare", "PrivPrecCompare", "ApronPrecCompare", - "Mainspec", # libraries "Goblint_std", diff --git a/src/dune b/src/dune index acd5348acb..d3fe6bdd0d 100644 --- a/src/dune +++ b/src/dune @@ -6,7 +6,7 @@ (library (name goblint_lib) (public_name goblint.lib) - (modules :standard \ goblint mainspec privPrecCompare apronPrecCompare messagesCompare) + (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. @@ -73,10 +73,10 @@ (copy_files# witness/z3/*.ml) (executables - (names goblint mainspec) - (public_names goblint -) + (names goblint) + (public_names goblint) (modes byte native) ; https://dune.readthedocs.io/en/stable/dune-files.html#linking-modes - (modules goblint mainspec) + (modules goblint) (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) From 8104b3e08b1925efe289de73558d735f7804eae5 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 21:33:12 +0100 Subject: [PATCH 137/233] Remove some workarounds not needed with batteries >=3.5.1 --- src/framework/cfgTools.ml | 2 +- src/solvers/postSolver.ml | 8 +------- src/util/std/gobHashtbl.ml | 4 ---- 3 files changed, 2 insertions(+), 12 deletions(-) diff --git a/src/framework/cfgTools.ml b/src/framework/cfgTools.ml index 8f98a48e84..7b673f99bc 100644 --- a/src/framework/cfgTools.ml +++ b/src/framework/cfgTools.ml @@ -475,7 +475,7 @@ let createCFG (file: file) = ); if Messages.tracing then Messages.trace "cfg" "CFG building finished.\n\n"; if get_bool "dbg.verbose" then - ignore (Pretty.eprintf "cfgF (%a), cfgB (%a)\n" GobHashtbl.pretty_statistics (GobHashtbl.magic_stats cfgF) GobHashtbl.pretty_statistics (GobHashtbl.magic_stats cfgB)); + ignore (Pretty.eprintf "cfgF (%a), cfgB (%a)\n" GobHashtbl.pretty_statistics (NH.stats cfgF) GobHashtbl.pretty_statistics (NH.stats cfgB)); cfgF, cfgB, skippedByEdge let createCFG = Timing.wrap "createCFG" createCFG diff --git a/src/solvers/postSolver.ml b/src/solvers/postSolver.ml index f96ca832a1..e01560c752 100644 --- a/src/solvers/postSolver.ml +++ b/src/solvers/postSolver.ml @@ -154,13 +154,7 @@ struct module VH = Hashtbl.Make (S.Var) (* starts as Hashtbl for quick lookup *) - let starth = - (* VH.of_list S.starts *) (* TODO: BatHashtbl.Make.of_list is broken, use after new Batteries release *) - let starth = VH.create (List.length S.starts) in - List.iter (fun (x, d) -> - VH.replace starth x d - ) S.starts; - starth + let starth = VH.of_list S.starts let system x = match S.system x, VH.find_option starth x with diff --git a/src/util/std/gobHashtbl.ml b/src/util/std/gobHashtbl.ml index c14bafc0cb..c93244eb47 100644 --- a/src/util/std/gobHashtbl.ml +++ b/src/util/std/gobHashtbl.ml @@ -1,9 +1,5 @@ module Pretty = GoblintCil.Pretty -let magic_stats h = - let h: _ Hashtbl.t = Obj.magic h in (* Batteries Hashtables don't expose stats yet...: https://github.com/ocaml-batteries-team/batteries-included/pull/1079 *) - Hashtbl.stats h - let pretty_statistics () (s: Hashtbl.statistics) = let load_factor = float_of_int s.num_bindings /. float_of_int s.num_buckets in Pretty.dprintf "bindings=%d buckets=%d max_length=%d histo=%a load=%f" s.num_bindings s.num_buckets s.max_bucket_length (Pretty.docList (Pretty.dprintf "%d")) (Array.to_list s.bucket_histogram) load_factor From aa7a8bb4dfcf0740a5b0d2b49e84032104eea591 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 21:42:15 +0100 Subject: [PATCH 138/233] Require batteries >=3.5.1 --- dune-project | 2 +- goblint.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 81c8d2f091..37e81f4199 100644 --- a/dune-project +++ b/dune-project @@ -25,7 +25,7 @@ (depends (ocaml (>= 4.10)) (goblint-cil (>= 2.0.3)) ; TODO no way to define as pin-depends? Used goblint.opam.template to add it for now. https://github.com/ocaml/dune/issues/3231. Alternatively, removing this line and adding cil as a git submodule and `(vendored_dirs cil)` as ./dune also works. This way, no more need to reinstall the pinned cil opam package on changes. However, then cil is cleaned and has to be rebuild together with goblint. - (batteries (>= 3.5.0)) + (batteries (>= 3.5.1)) (zarith (>= 1.8)) (yojson (>= 2.0.0)) (qcheck-core (>= 0.19)) diff --git a/goblint.opam b/goblint.opam index 669b2d9c40..b5f1f360dc 100644 --- a/goblint.opam +++ b/goblint.opam @@ -22,7 +22,7 @@ depends: [ "dune" {>= "3.7"} "ocaml" {>= "4.10"} "goblint-cil" {>= "2.0.3"} - "batteries" {>= "3.5.0"} + "batteries" {>= "3.5.1"} "zarith" {>= "1.8"} "yojson" {>= "2.0.0"} "qcheck-core" {>= "0.19"} From 9891391807d9bf9a4ac6e5efe1f49b843ace9dbf Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 11:17:42 +0100 Subject: [PATCH 139/233] Rm further spurious domains --- src/cdomains/fileDomain.ml | 81 --------- src/cdomains/mvalMapDomain.ml | 299 ---------------------------------- src/cdomains/specDomain.ml | 34 ---- src/goblint_lib.ml | 4 - 4 files changed, 418 deletions(-) delete mode 100644 src/cdomains/fileDomain.ml delete mode 100644 src/cdomains/mvalMapDomain.ml delete mode 100644 src/cdomains/specDomain.ml diff --git a/src/cdomains/fileDomain.ml b/src/cdomains/fileDomain.ml deleted file mode 100644 index ca585b8bce..0000000000 --- a/src/cdomains/fileDomain.ml +++ /dev/null @@ -1,81 +0,0 @@ -(** Domains for file handles. *) - -open Batteries - -module D = MvalMapDomain - - -module Val = -struct - type mode = Read | Write [@@deriving eq, ord, hash] - type s = Open of string*mode | Closed | Error [@@deriving eq, ord, hash] - let name = "File handles" - let var_state = Closed - let string_of_mode = function Read -> "Read" | Write -> "Write" - let string_of_state = function - | Open(filename, m) -> "open("^filename^", "^string_of_mode m^")" - | Closed -> "closed" - | Error -> "error" - - (* properties of records (e.g. used by Dom.warn_each) *) - let opened s = s <> Closed && s <> Error - let closed s = s = Closed - let writable s = match s with Open((_,Write)) -> true | _ -> false -end - - -module Dom = -struct - include D.Domain (D.Value (Val)) - - (* returns a tuple (thunk, result) *) - let report_ ?(neg=false) k p msg m = - let f ?(may=false) msg = - let f () = warn ~may msg in - f, if may then `May true else `Must true in - let mf = (fun () -> ()), `Must false in - if mem k m then - let p = if neg then not % p else p in - let v = find' k m in - if V.must p v then f msg (* must *) - else if V.may p v then f ~may:true msg (* may *) - else mf (* none *) - else if neg then f msg else mf - - let report ?(neg=false) k p msg m = (fst (report_ ~neg k p msg m)) () (* evaluate thunk *) - - let reports k xs m = - let uncurry (neg, p, msg) = report_ ~neg:neg k p msg m in - let f result x = if snd (uncurry x) = result then Some (fst (uncurry x)) else None in - let must_true = BatList.filter_map (f (`Must true)) xs in - let may_true = BatList.filter_map (f (`May true)) xs in - (* output first must and first may *) - if must_true <> [] then (List.hd must_true) (); - if may_true <> [] then (List.hd may_true) () - - (* handling state *) - let opened r = V.state r |> Val.opened - let closed r = V.state r |> Val.closed - let writable r = V.state r |> Val.writable - - let fopen k loc filename mode m = - if is_unknown k m then m else - let mode = match String.lowercase_ascii mode with "r" -> Val.Read | _ -> Val.Write in - let v = V.make k loc (Val.Open(filename, mode)) in - add' k v m - let fclose k loc m = - if is_unknown k m then m else - let v = V.make k loc Val.Closed in - change k v m - let error k m = - if is_unknown k m then m else - let loc = if mem k m then find' k m |> V.split |> snd |> Set.choose |> V.loc else [] in - let v = V.make k loc Val.Error in - change k v m - let success k m = - if is_unknown k m then m else - match find_option k m with - | Some v when V.may (Val.opened%V.state) v && V.may (V.in_state Val.Error) v -> - change k (V.filter (Val.opened%V.state) v) m (* TODO what about must-set? *) - | _ -> m -end diff --git a/src/cdomains/mvalMapDomain.ml b/src/cdomains/mvalMapDomain.ml deleted file mode 100644 index d0d2f8da85..0000000000 --- a/src/cdomains/mvalMapDomain.ml +++ /dev/null @@ -1,299 +0,0 @@ -(** Domains for {{!Mval} mvalue} maps. *) - -open Batteries -open GoblintCil - -module M = Messages - - -exception Unknown -exception Error - -(* signature for map entries *) -module type S = -sig - include Lattice.S - type k = Mval.Exp.t (* key *) - type s (* state is defined by Impl *) - type r (* record *) - - (* printing *) - val string_of: t -> string - val string_of_key: k -> string - val string_of_record: r -> string - - (* constructing *) - val make: k -> Node.t list -> s -> t - - (* manipulation *) - val map: (r -> r) -> t -> t - val filter: (r -> bool) -> t -> t - val union: t -> t -> t - val set_key: k -> t -> t - val set_state: s -> t -> t - val remove_state: s -> t -> t - - (* deconstructing *) - val split: t -> r Set.t * r Set.t - val map': (r -> 'a) -> t -> 'a Set.t * 'a Set.t - val filter': (r -> bool) -> t -> r Set.t * r Set.t - val length: t -> int * int - - (* predicates *) - val must: (r -> bool) -> t -> bool - val may: (r -> bool) -> t -> bool - (* properties of records *) - val key: r -> k - val loc: r -> Node.t list - val edit_loc: (Node.t list -> Node.t list) -> r -> r - val state: r -> s - val in_state: s -> r -> bool - - (* special variables *) - val get_record: t -> r option - (* val make_record: k -> location list -> s -> r *) - val make_var: k -> t - val from_tuple: r Set.t * r Set.t -> t - - (* aliasing *) - val is_alias: t -> bool - val get_alias: t -> k - val make_alias: k -> t -end - -module Value (Impl: sig - type s (* state *) [@@deriving eq, ord, hash] - val name: string - val var_state: s - val string_of_state: s -> string - end) : S with type s = Impl.s = -struct - type k = Mval.Exp.t [@@deriving eq, ord, hash] - type s = Impl.s [@@deriving eq, ord, hash] - module R = struct - include Printable.StdLeaf - type t = { key: k; loc: Node.t list; state: s } [@@deriving eq, ord, hash] - let name () = "MValMapDomainValue" - - let pretty () {key; loc; state} = - Pretty.dprintf "{key=%a; loc=%a; state=%s}" Mval.Exp.pretty key (Pretty.d_list ", " Node.pretty) loc (Impl.string_of_state state) - - include Printable.SimplePretty ( - struct - type nonrec t = t - let pretty = pretty - end - ) - end - type r = R.t - open R - (* TODO: use SetDomain.Reverse? *) - module Must' = SetDomain.ToppedSet (R) (struct let topname = "top" end) - module Must = Lattice.Reverse (Must') - module May = SetDomain.ToppedSet (R) (struct let topname = "top" end) - include Lattice.Prod (Must) (May) - let name () = Impl.name - - (* converts to polymorphic sets *) - let split (x,y) = try Must'.elements x |> Set.of_list, May.elements y |> Set.of_list with SetDomain.Unsupported _ -> Set.empty, Set.empty - - (* special variable used for indirection *) - let alias_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@alias" Cil.voidType, `NoOffset - (* alias structure: x[0].key=alias_var, y[0].key=linked_var *) - let is_alias (x,y) = neg Must'.is_empty x && (Must'.choose x).key=alias_var - let get_alias (x,y) = (May.choose y).key - - (* Printing *) - let string_of_key k = Mval.Exp.show k - let string_of_loc xs = String.concat ", " (List.map (CilType.Location.show % Node.location) xs) - let string_of_record r = Impl.string_of_state r.state^" ("^string_of_loc r.loc^")" - let string_of (x,y) = - if is_alias (x,y) then - "alias for "^string_of_key @@ get_alias (x,y) - else - let x, y = split (x,y) in - let z = Set.diff y x in - "{ "^String.concat ", " (List.map string_of_record (Set.elements x))^" }, "^ - "{ "^String.concat ", " (List.map string_of_record (Set.elements z))^" }" - let show x = string_of x - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) - (* constructing & manipulation *) - let make_record k l s = { key=k; loc=l; state=s } - let make k l s = let v = make_record k l s in Must'.singleton v, May.singleton v - let map f (x,y) = Must'.map f x, May.map f y - let filter p (x,y) = Must'.filter p x, May.filter p y (* retains top *) - let union (a,b) (c,d) = Must'.union a c, May.union b d - let set_key k v = map (fun x -> {x with key=k}) v (* changes key for all elements *) - let set_state s v = map (fun x -> {x with state=s}) v - let remove_state s v = filter (fun x -> x.state<>s) v - - (* deconstructing *) - let length = split %> Tuple2.mapn Set.cardinal - let map' f = split %> Tuple2.mapn (Set.map f) - let filter' f = split %> Tuple2.mapn (Set.filter f) - - (* predicates *) - let must p (x,y) = Must'.exists p x || May.for_all p y - let may p (x,y) = May.exists p y - - (* properties of records *) - let key r = r.key - let loc r = r.loc - let edit_loc f r = {r with loc=f r.loc} - let state r = r.state - let in_state s r = r.state = s - - (* special variables *) - let get_record (x,y) = if Must'.is_empty x then None else Some (Must'.choose x) - let make_var_record k = make_record k [] Impl.var_state - let make_var k = Must'.singleton (make_var_record k), May.singleton (make_var_record k) - let make_alias k = Must'.singleton (make_var_record alias_var), May.singleton (make_var_record k) - let from_tuple (x,y) = Set.to_list x |> Must'.of_list, Set.to_list y |> May.of_list -end - - -module Domain (V: S) = -struct - module K = Mval.Exp - module V = V - module MD = MapDomain.MapBot (Mval.Exp) (V) - include MD - - (* Map functions *) - (* find that resolves aliases *) - let find' k m = let v = find k m in if V.is_alias v then find (V.get_alias v) m else v - let find_option k m = if mem k m then Some(find' k m) else None - let get_alias k m = (* target: returns Some k' if k links to k' *) - if mem k m && V.is_alias (find k m) then Some (V.get_alias (find k m)) else None - let get_aliased k m = (* sources: get list of keys that link to k *) - (* iter (fun k' (x,y) -> if V.is_alias (x,y) then print_endline ("alias "^V.string_of_key k'^" -> "^V.string_of_key (Set.choose y).key)) m; *) - (* TODO V.get_alias v=k somehow leads to Out_of_memory... *) - filter (fun k' v -> V.is_alias v && V.string_of_key (V.get_alias v)=V.string_of_key k) m |> bindings |> List.map fst - let get_aliases k m = (* get list of all other keys that have the same pointee *) - match get_alias k m with - | Some k' -> [k] (* k links to k' *) - | None -> get_aliased k m (* k' that link to k *) - let alias a b m = (* link a to b *) - (* if b is already an alias, follow it... *) - let b' = get_alias b m |? b in - (* add an entry for key a, that points to b' *) - add a (V.make_alias b') m - let remove' k m = (* fixes keys that link to k before removing it *) - if mem k m && not (V.is_alias (find k m)) then (* k might be aliased *) - let v = find k m in - match get_aliased k m with - | [] -> remove k m (* nothing links to k *) - | k'::xs -> let m = add k' v m in (* set k' to v, link xs to k', finally remove k *) - (* List.map (fun x -> x.vname) (k'::xs) |> String.concat ", " |> print_endline; *) - List.fold_left (fun m x -> alias x k' m) m xs |> remove k - else remove k m (* k not in m or an alias *) - let add' k v m = - remove' k m (* fixes keys that might have linked to k *) - |> add k v (* set new value *) - let change k v m = (* if k is an alias, replace its pointee *) - add (get_alias k m |? k) v m - - (* special variables *) - let get_record k m = Option.bind (find_option k m) V.get_record - let edit_record k f m = - let v = find_option k m |? V.make_var k in - add k (V.map f v) m - let get_value k m = find_option k m |> Option.map_default V.split (Set.empty,Set.empty) - let extend_value k v' m = - let v = V.from_tuple v' in - if mem k m then - add k (V.union (find k m) v) m - else - add k v m - let union (a,b) (c,d) = Set.union a c, Set.union b d - let is_special_var k = String.get (V.string_of_key k) 0 = '@' - let without_special_vars m = filter (fun k v -> not @@ is_special_var k) m - - (* functions needed for enter & combine *) - (* only keep globals, aliases to them and special variables *) - let only_globals m = filter (fun k v -> (fst k).vglob || V.is_alias v && (fst (V.get_alias v)).vglob || is_special_var k) m - (* adds all the bindings from m2 to m1 (overwrites!) *) - let add_all m1 m2 = add_list (bindings m2) m1 - - (* callstack for locations *) - let callstack_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@callstack" Cil.voidType, `NoOffset - let callstack m = get_record callstack_var m |> Option.map_default V.loc [] - let string_of_callstack m = " [call stack: "^String.concat ", " (List.map (CilType.Location.show % Node.location) (callstack m))^"]" - let edit_callstack f m = edit_record callstack_var (V.edit_loc f) m - - - (* predicates *) - let must k p m = mem k m && V.must p (find' k m) - let may k p m = mem k m && V.may p (find' k m) - let is_may k m = mem k m && let x,y = V.length (find' k m) in x=0 && y>0 - - let filter_values p m = (* filters all values in the map and flattens result *) - let flatten_sets = List.fold_left Set.union Set.empty in - without_special_vars m - |> filter (fun k v -> V.may p v && not (V.is_alias v)) - |> bindings |> List.map (fun (k,v) -> V.filter' p v) - |> List.split |> (fun (x,y) -> flatten_sets x, flatten_sets y) - let filter_records k p m = (* filters both sets of k *) - if mem k m then V.filter' p (find' k m) else Set.empty, Set.empty - - let unknown k m = add' k (V.top ()) m - let is_unknown k m = if mem k m then V.is_top (find' k m) else false - - (* printing *) - let string_of_state k m = if not (mem k m) then "?" else V.string_of (find' k m) - let string_of_key k = V.string_of_key k - let string_of_keys rs = Set.map (V.string_of_key % V.key) rs |> Set.elements |> String.concat ", " - let string_of_entry k m = string_of_key k ^ ": " ^ string_of_state k m - let string_of_map m = List.map (fun (k,v) -> string_of_entry k m) (bindings m) - - let warn ?may:(may=false) ?loc:(loc=[Option.get !Node.current_node]) msg = - let split_category s = - if Str.string_partial_match (Str.regexp {|\[\([^]]*\)\]|}) s 0 then - (Some (Str.matched_group 1 s), Str.string_after s (Str.match_end ())) - else - (None, s) - in - let rec split_categories s = - match split_category s with - | (Some category, s') -> - let (categories, s'') = split_categories s' in - (category :: categories, s'') - | (None, s') -> ([], s') - in - match split_categories msg with - | ([], msg) -> (if may then Messages.warn else Messages.error) ~loc:(Node (List.last loc)) "%s" msg - | (category :: categories, msg) -> - let category_of_string s = Messages.Category.from_string_list [String.lowercase_ascii s] in (* TODO: doesn't split subcategories, not used and no defined syntax even *) - let category = category_of_string category in - let tags = List.map (fun category -> Messages.Tag.Category (category_of_string category)) categories in - (if may then Messages.warn else Messages.error) ~loc:(Node (List.last loc)) ~category ~tags "%s" msg - - (* getting keys from Cil Lvals *) - - let key_from_lval lval = match lval with (* TODO try to get a Mval.Exp from Cil.Lval *) - | Var v1, o1 -> v1, Offset.Exp.of_cil o1 - | Mem Lval(Var v1, o1), o2 -> v1, Offset.Exp.of_cil (addOffset o1 o2) - (* | Mem exp, o1 -> failwith "not implemented yet" (* TODO use query_lv *) *) - | _ -> Cilfacade.create_var @@ Cil.makeVarinfo false ("?"^CilType.Lval.show lval) Cil.voidType, `NoOffset (* TODO *) - - let keys_from_lval lval (ask: Queries.ask) = (* use MayPointTo query to get all possible pointees of &lval *) - (* print_query_lv ctx.ask (AddrOf lval); *) - let query_addrs (ask: Queries.ask) exp = match ask.f (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - in - let exp = AddrOf lval in - let addrs = query_addrs ask exp in (* MayPointTo -> LValSet *) - let keys = List.fold (fun vs addr -> - match addr with - | Queries.AD.Addr.Addr (v,o) -> (v, ValueDomain.Offs.to_exp o) :: vs - | _ -> vs - ) [] addrs - in - let pretty_key k = Pretty.text (string_of_key k) in - Messages.debug ~category:Analyzer "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) keys; - keys -end diff --git a/src/cdomains/specDomain.ml b/src/cdomains/specDomain.ml deleted file mode 100644 index 75a9d8edc5..0000000000 --- a/src/cdomains/specDomain.ml +++ /dev/null @@ -1,34 +0,0 @@ -(** Domains for finite automaton specification file analysis. *) - -open Batteries - -module D = MvalMapDomain - - -module Val = -struct - type s = string [@@deriving eq, ord, hash] - let name = "Spec value" - let var_state = "" - let string_of_state s = s - - (* transforms May-Sets of length 1 to Must. NOTE: this should only be done if the original set had more than one element! *) - (* let maybe_must = function May xs when Set.cardinal xs = 1 -> Must (Set.choose xs) | x -> x *) - (* let may = function Must x -> May (Set.singleton x) | xs -> xs *) - (* let records = function Must x -> (Set.singleton x) | May xs -> xs *) - (* let list_of_records = function Must x -> [x] | May xs -> List.of_enum (Set.enum xs) *) - (* let vnames x = String.concat ", " (List.map (fun r -> string_of_key r.var) (list_of_records x)) *) -end - - -module Dom = -struct - include D.Domain (D.Value (Val)) - - (* handling state *) - let goto k loc state m = add' k (V.make k loc state) m - let may_goto k loc state m = let v = V.join (find' k m) (V.make k loc state) in add' k v m - let in_state k s m = must k (V.in_state s) m - let may_in_state k s m = may k (V.in_state s) m - let get_states k m = if not (mem k m) then [] else find' k m |> V.map' V.state |> snd |> Set.elements -end diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index d4f2982902..8d319dd4a1 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -261,12 +261,8 @@ module AccessDomain = AccessDomain module MusteqDomain = MusteqDomain module RegionDomain = RegionDomain -module FileDomain = FileDomain module StackDomain = StackDomain -module MvalMapDomain = MvalMapDomain -module SpecDomain = SpecDomain - (** {2 Testing} Modules related to (property-based) testing of domains. *) From d7d350325cc3f330a6f280c22a0d721d33bc615b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 17:17:00 +0100 Subject: [PATCH 140/233] Localize two helpers in `relationDomain.apron.ml` --- src/cdomains/apron/relationDomain.apron.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/cdomains/apron/relationDomain.apron.ml b/src/cdomains/apron/relationDomain.apron.ml index c5b6a0a89b..e613cad6c3 100644 --- a/src/cdomains/apron/relationDomain.apron.ml +++ b/src/cdomains/apron/relationDomain.apron.ml @@ -184,10 +184,9 @@ struct let name () = RD.name () ^ " * " ^ PrivD.name () - let of_tuple(rel, priv):t = {rel; priv} - let to_tuple r = (r.rel, r.priv) - let arbitrary () = + let to_tuple r = (r.rel, r.priv) in + let of_tuple (rel, priv) = {rel; priv} in let tr = QCheck.pair (RD.arbitrary ()) (PrivD.arbitrary ()) in QCheck.map ~rev:to_tuple of_tuple tr From 1473d6edb0437b716ebb4c5795d03e963da24439 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 17:31:50 +0100 Subject: [PATCH 141/233] Add citation to TODO --- src/analyses/apron/relationAnalysis.apron.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index d2fe7eab9e..f5dc227ad2 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -283,6 +283,7 @@ struct let pass_to_callee fundec any_local_reachable var = (* TODO: currently, we pass all locals of the caller to the callee, provided one of them is reachbale to preserve relationality *) (* there should be smarter ways to do this, e.g. by keeping track of which values are written etc. ... *) + (* See, e.g, Beckschulze E, Kowalewski S, Brauer J (2012) Access-based localization for octagons. Electron Notes Theor Comput Sci 287:29–40 *) (* Also, a local *) let vname = RD.Var.to_string var in let locals = fundec.sformals @ fundec.slocals in From d9831131890923838186f9d0d4fd19fdda7e022c Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 17:37:05 +0100 Subject: [PATCH 142/233] `make_callee_rel`: Introduce `filter_map` --- src/analyses/apron/relationAnalysis.apron.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index f5dc227ad2..b3c6dcb9b3 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -296,8 +296,7 @@ struct let st = ctx.local in let arg_assigns = GobList.combine_short f.sformals args (* TODO: is it right to ignore missing formals/args? *) - |> List.filter (fun (x, _) -> RD.Tracked.varinfo_tracked x) - |> List.map (Tuple2.map1 RV.arg) + |> List.filter_map (fun (x, e) -> if RD.Tracked.varinfo_tracked x then Some (RV.arg x, e) else None) in let arg_vars = List.map fst arg_assigns in let new_rel = RD.add_vars st.rel arg_vars in From 4940cebb9bf9f26c4c1d0044d0b5c59f039513d6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 18:49:32 +0100 Subject: [PATCH 143/233] Simplify --- .../apron/affineEqualityAnalysis.apron.ml | 1 - src/analyses/apron/apronAnalysis.apron.ml | 3 +- src/analyses/apron/relationAnalysis.apron.ml | 6 +-- src/analyses/apron/relationPriv.apron.ml | 3 +- .../apron/affineEqualityDomain.apron.ml | 5 +-- src/cdomains/apron/apronDomain.apron.ml | 11 +++--- src/cdomains/apron/gobApron.apron.ml | 37 +++++++++++++++++++ src/cdomains/apron/gobApron.no-apron.ml | 0 src/cdomains/apron/relationDomain.apron.ml | 28 +++++--------- src/cdomains/apron/sharedFunctions.apron.ml | 36 ------------------ src/dune | 4 ++ 11 files changed, 62 insertions(+), 72 deletions(-) create mode 100644 src/cdomains/apron/gobApron.apron.ml create mode 100644 src/cdomains/apron/gobApron.no-apron.ml diff --git a/src/analyses/apron/affineEqualityAnalysis.apron.ml b/src/analyses/apron/affineEqualityAnalysis.apron.ml index 03a9ecdb57..ce859d87b7 100644 --- a/src/analyses/apron/affineEqualityAnalysis.apron.ml +++ b/src/analyses/apron/affineEqualityAnalysis.apron.ml @@ -11,7 +11,6 @@ let spec_module: (module MCPSpec) Lazy.t = let module AD = AffineEqualityDomain.D2 (VectorMatrix.ArrayVector) (VectorMatrix.ArrayMatrix) in let module RD: RelationDomain.RD = struct - module Var = AffineEqualityDomain.Var module V = AffineEqualityDomain.V include AD end diff --git a/src/analyses/apron/apronAnalysis.apron.ml b/src/analyses/apron/apronAnalysis.apron.ml index 29e295a662..72dc81c121 100644 --- a/src/analyses/apron/apronAnalysis.apron.ml +++ b/src/analyses/apron/apronAnalysis.apron.ml @@ -12,10 +12,9 @@ let spec_module: (module MCPSpec) Lazy.t = let module AD = (val if diff_box then (module ApronDomain.BoxProd (AD): ApronDomain.S3) else (module AD)) in let module RD: RelationDomain.RD = struct - module Var = ApronDomain.Var module V = ApronDomain.V include AD - type var = ApronDomain.Var.t + type var = GobApron.Var.t end in let module Priv = (val RelationPriv.get_priv ()) in diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index b3c6dcb9b3..b401b58e93 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -285,7 +285,7 @@ struct (* there should be smarter ways to do this, e.g. by keeping track of which values are written etc. ... *) (* See, e.g, Beckschulze E, Kowalewski S, Brauer J (2012) Access-based localization for octagons. Electron Notes Theor Comput Sci 287:29–40 *) (* Also, a local *) - let vname = RD.Var.to_string var in + let vname = GobApron.Var.to_string var in let locals = fundec.sformals @ fundec.slocals in match List.find_opt (fun v -> VM.var_name (Local v) = vname) locals with (* TODO: optimize *) | None -> true @@ -318,7 +318,7 @@ struct RD.remove_filter_with new_rel (fun var -> match RV.find_metadata var with | Some (Local _) when not (pass_to_callee fundec any_local_reachable var) -> true (* remove caller locals provided they are unreachable *) - | Some (Arg _) when not (List.mem_cmp RD.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) + | Some (Arg _) when not (List.mem_cmp GobApron.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) | _ -> false (* keep everything else (just added args, globals, global privs) *) ); if M.tracing then M.tracel "combine" "relation enter newd: %a\n" RD.pretty new_rel; @@ -404,7 +404,7 @@ struct in let any_local_reachable = any_local_reachable fundec reachable_from_args in let arg_vars = f.sformals |> List.filter (RD.Tracked.varinfo_tracked) |> List.map RV.arg in - if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (RD.Var.to_string v))) arg_vars; + if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (GobApron.Var.to_string v))) arg_vars; RD.remove_vars_with new_fun_rel arg_vars; (* fine to remove arg vars that also exist in caller because unify from new_rel adds them back with proper constraints *) let tainted = f_ask.f Queries.MayBeTainted in let tainted_vars = TaintPartialContexts.conv_varset tainted in diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index b386af162b..a51fc3545f 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -195,8 +195,7 @@ struct end module AV = struct - include RelationDomain.VarMetadataTbl (VM) (RD.Var) - + include RelationDomain.VarMetadataTbl (VM) let local g = make_var (Local g) let unprot g = make_var (Unprot g) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index a6f00fdba0..0054f685b1 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -10,7 +10,7 @@ open Batteries open GoblintCil open Pretty module M = Messages -open Apron +open GobApron open VectorMatrix module Mpqf = struct @@ -26,8 +26,7 @@ module Mpqf = struct let hash x = 31 * (Z.hash (get_den x)) + Z.hash (get_num x) end -module Var = SharedFunctions.Var -module V = RelationDomain.V(Var) +module V = RelationDomain.V (** It defines the type t of the affine equality domain (a struct 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 get_coeff_vec that parses an apron expression into a vector of coefficients if the apron expression has an affine form. *) diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index 7dffafe967..ef9eac9bef 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -4,7 +4,7 @@ open Batteries open GoblintCil open Pretty (* A binding to a selection of Apron-Domains *) -open Apron +open GobApron open RelationDomain open SharedFunctions @@ -29,8 +29,7 @@ let widening_thresholds_apron = ResettableLazy.from_fun (fun () -> let reset_lazy () = ResettableLazy.reset widening_thresholds_apron -module Var = SharedFunctions.Var -module V = RelationDomain.V(Var) +module V = RelationDomain.V module type Manager = @@ -497,9 +496,9 @@ struct let to_yojson (x: t) = let constraints = A.to_lincons_array Man.mgr x - |> SharedFunctions.Lincons1Set.of_earray - |> SharedFunctions.Lincons1Set.elements - |> List.map (fun lincons1 -> `String (SharedFunctions.Lincons1.show lincons1)) + |> Lincons1Set.of_earray + |> Lincons1Set.elements + |> List.map (fun lincons1 -> `String (Lincons1.show lincons1)) in let env = `String (Format.asprintf "%a" (Environment.print: Format.formatter -> Environment.t -> unit) (A.env x)) in diff --git a/src/cdomains/apron/gobApron.apron.ml b/src/cdomains/apron/gobApron.apron.ml new file mode 100644 index 0000000000..df20f3c59d --- /dev/null +++ b/src/cdomains/apron/gobApron.apron.ml @@ -0,0 +1,37 @@ +open Batteries +include Apron + +module Var = +struct + include Var + let equal x y = Var.compare x y = 0 +end + +module Lincons1 = +struct + include Lincons1 + + let show = Format.asprintf "%a" print + let compare x y = String.compare (show x) (show y) (* HACK *) + + let num_vars x = + (* Apron.Linexpr0.get_size returns some internal nonsense, so we count ourselves. *) + let size = ref 0 in + Lincons1.iter (fun coeff var -> + if not (Apron.Coeff.is_zero coeff) then + incr size + ) x; + !size +end + +module Lincons1Set = +struct + include Set.Make (Lincons1) + + let of_earray ({lincons0_array; array_env}: Lincons1.earray): t = + Array.enum lincons0_array + |> Enum.map (fun (lincons0: Lincons0.t) -> + Lincons1.{lincons0; env = array_env} + ) + |> of_enum +end diff --git a/src/cdomains/apron/gobApron.no-apron.ml b/src/cdomains/apron/gobApron.no-apron.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/cdomains/apron/relationDomain.apron.ml b/src/cdomains/apron/relationDomain.apron.ml index e613cad6c3..e68540c41b 100644 --- a/src/cdomains/apron/relationDomain.apron.ml +++ b/src/cdomains/apron/relationDomain.apron.ml @@ -5,25 +5,15 @@ open Batteries open GoblintCil -(** Abstracts the extended apron Var. *) -module type Var = -sig - type t - val compare : t -> t -> int - val of_string : string -> t - val to_string : t -> string - val hash : t -> int - val equal : t -> t -> bool -end - module type VarMetadata = sig type t val var_name: t -> string end -module VarMetadataTbl (VM: VarMetadata) (Var: Var) = +module VarMetadataTbl (VM: VarMetadata) = struct + open GobApron module VH = Hashtbl.Make (Var) let vh = VH.create 113 @@ -57,7 +47,7 @@ end module type RV = sig - type t + type t = GobApron.Var.t type vartable val vh: vartable @@ -70,10 +60,11 @@ sig val to_cil_varinfo: t -> varinfo Option.t end -module V (Var: Var): (RV with type t = Var.t and type vartable = VM.t VarMetadataTbl (VM) (Var).VH.t) = +module V: (RV with type vartable = VM.t VarMetadataTbl (VM).VH.t) = struct + open GobApron type t = Var.t - module VMT = VarMetadataTbl (VM) (Var) + module VMT = VarMetadataTbl (VM) include VMT open VM @@ -105,7 +96,7 @@ end module type S2 = sig type t - type var + type var = GobApron.Var.t type marshal module Tracked: Tracked @@ -215,7 +206,6 @@ end module type RD = sig - module Var : Var - module V : module type of struct include V(Var) end - include S3 with type var = Var.t + module V : module type of struct include V end + include S3 end diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index 059a7f8264..9c229e2d64 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -8,42 +8,6 @@ module M = Messages module BI = IntOps.BigIntOps -module Var = -struct - include Var - - let equal x y = Var.compare x y = 0 -end - -module Lincons1 = -struct - include Lincons1 - - let show = Format.asprintf "%a" print - let compare x y = String.compare (show x) (show y) (* HACK *) - - let num_vars x = - (* Apron.Linexpr0.get_size returns some internal nonsense, so we count ourselves. *) - let size = ref 0 in - Lincons1.iter (fun coeff var -> - if not (Apron.Coeff.is_zero coeff) then - incr size - ) x; - !size -end - -module Lincons1Set = -struct - include Set.Make (Lincons1) - - let of_earray ({lincons0_array; array_env}: Lincons1.earray): t = - Array.enum lincons0_array - |> Enum.map (fun (lincons0: Lincons0.t) -> - Lincons1.{lincons0; env = array_env} - ) - |> of_enum -end - let int_of_scalar ?round (scalar: Scalar.t) = if Scalar.is_infty scalar <> 0 then (* infinity means unbounded *) None diff --git a/src/dune b/src/dune index acd5348acb..40faae1f3f 100644 --- a/src/dune +++ b/src/dune @@ -11,6 +11,10 @@ ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. + (select gobApron.ml from + (apron -> gobApron.apron.ml) + (-> gobApron.no-apron.ml) + ) (select apronDomain.ml from (apron apron.octD apron.boxD apron.polkaMPQ zarith_mlgmpidl -> apronDomain.apron.ml) (-> apronDomain.no-apron.ml) From 49eb46df9bf722d0f528f52dbfcb2c8a524ede19 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 19:08:36 +0100 Subject: [PATCH 144/233] Cleanup --- src/cdomains/apron/relationDomain.apron.ml | 59 ++++++++++------------ 1 file changed, 26 insertions(+), 33 deletions(-) diff --git a/src/cdomains/apron/relationDomain.apron.ml b/src/cdomains/apron/relationDomain.apron.ml index e68540c41b..aca2346820 100644 --- a/src/cdomains/apron/relationDomain.apron.ml +++ b/src/cdomains/apron/relationDomain.apron.ml @@ -1,7 +1,7 @@ (** Signatures for relational value domains. See {!ApronDomain} and {!AffineEqualityDomain}. *) - +open GobApron open Batteries open GoblintCil @@ -11,23 +11,6 @@ sig val var_name: t -> string end -module VarMetadataTbl (VM: VarMetadata) = -struct - open GobApron - module VH = Hashtbl.Make (Var) - - let vh = VH.create 113 - - let make_var ?name metadata = - let name = Option.default_delayed (fun () -> VM.var_name metadata) name in - let var = Var.of_string name in - VH.replace vh var metadata; - var - - let find_metadata (var: Var.t) = - VH.find_option vh var -end - module VM = struct type t = @@ -45,10 +28,26 @@ struct | Global g -> g.vname end +module VarMetadataTbl (VM: VarMetadata) = +struct + module VH = Hashtbl.Make (Var) + + let vh = VH.create 113 + + let make_var ?name metadata = + let name = Option.default_delayed (fun () -> VM.var_name metadata) name in + let var = Var.of_string name in + VH.replace vh var metadata; + var + + let find_metadata (var: Var.t) = + VH.find_option vh var +end + module type RV = sig - type t = GobApron.Var.t - type vartable + type t = Var.t + type vartable = VM.t VarMetadataTbl (VM).VH.t val vh: vartable val make_var: ?name:string -> VM.t -> t @@ -60,13 +59,13 @@ sig val to_cil_varinfo: t -> varinfo Option.t end -module V: (RV with type vartable = VM.t VarMetadataTbl (VM).VH.t) = +module V: RV = struct - open GobApron + open VM + type t = Var.t module VMT = VarMetadataTbl (VM) include VMT - open VM type vartable = VM.t VMT.VH.t @@ -81,12 +80,6 @@ struct | _ -> None end -module type LinCons = -sig - type t - val num_vars: t -> int -end - module type Tracked = sig val type_tracked: typ -> bool @@ -96,7 +89,7 @@ end module type S2 = sig type t - type var = GobApron.Var.t + type var = Var.t type marshal module Tracked: Tracked @@ -135,8 +128,8 @@ module type S3 = sig include S2 - val cil_exp_of_lincons1: Apron.Lincons1.t -> exp option - val invariant: t -> Apron.Lincons1.t list + val cil_exp_of_lincons1: Lincons1.t -> exp option + val invariant: t -> Lincons1.t list end type ('a, 'b) relcomponents_t = { @@ -206,6 +199,6 @@ end module type RD = sig - module V : module type of struct include V end + module V : RV include S3 end From d1b62287dc64b825b3640d5b95ce90394a85d725 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 19:37:06 +0100 Subject: [PATCH 145/233] Move `Environment` things into `GobApron` --- .../apron/affineEqualityDomain.apron.ml | 14 ++--- src/cdomains/apron/apronDomain.apron.ml | 25 +++----- src/cdomains/apron/gobApron.apron.ml | 61 +++++++++++++++++++ src/cdomains/apron/sharedFunctions.apron.ml | 60 ------------------ 4 files changed, 76 insertions(+), 84 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 0054f685b1..ff2339cd6f 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -32,7 +32,6 @@ module V = RelationDomain.V Furthermore, it provides the function get_coeff_vec that parses an apron expression into a vector of coefficients if the apron expression has an affine form. *) module VarManagement (Vec: AbstractVector) (Mx: AbstractMatrix)= struct - include SharedFunctions.EnvOps module Vector = Vec (Mpqf) module Matrix = Mx(Mpqf) (Vec) @@ -77,16 +76,18 @@ struct let change_d t new_env add del = timing_wrap "dimension change" (change_d t new_env add) del + let vars x = Environment.ivars_only x.env + let add_vars t vars = let t = copy t in - let env' = add_vars t.env vars in + let env' = Environment.add_vars t.env vars in change_d t env' true false let add_vars t vars = timing_wrap "add_vars" (add_vars t) vars let drop_vars t vars del = let t = copy t in - let env' = remove_vars t.env vars in + let env' = Environment.remove_vars t.env vars in change_d t env' false del let drop_vars t vars = timing_wrap "drop_vars" (drop_vars t) vars @@ -101,7 +102,7 @@ struct t.env <- t'.env let remove_filter t f = - let env' = remove_filter t.env f in + let env' = Environment.remove_filter t.env f in change_d t env' false false let remove_filter t f = timing_wrap "remove_filter" (remove_filter t) f @@ -113,19 +114,18 @@ struct let keep_filter t f = let t = copy t in - let env' = keep_filter t.env f in + let env' = Environment.keep_filter t.env f in change_d t env' false false let keep_filter t f = timing_wrap "keep_filter" (keep_filter t) f let keep_vars t vs = let t = copy t in - let env' = keep_vars t.env vs in + let env' = Environment.keep_vars t.env vs in change_d t env' false false let keep_vars t vs = timing_wrap "keep_vars" (keep_vars t) vs - let vars t = vars t.env let mem_var t var = Environment.mem_var t.env var diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index ef9eac9bef..077aa971f2 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -208,7 +208,6 @@ module type AOpsExtra = sig type t val copy : t -> t - val vars_as_array : t -> Var.t array val vars : t -> Var.t list type marshal val unmarshal : marshal -> t @@ -247,15 +246,6 @@ struct let copy = A.copy Man.mgr - let vars_as_array d = - let ivs, fvs = Environment.vars (A.env d) in - assert (Array.length fvs = 0); (* shouldn't ever contain floats *) - ivs - - let vars d = - let ivs = vars_as_array d in - List.of_enum (Array.enum ivs) - (* marshal type: Abstract0.t and an array of var names *) type marshal = Man.mt Abstract0.t * string array @@ -265,30 +255,32 @@ struct let env = Environment.make vars [||] in {abstract0; env} + let vars x = Environment.ivars_only @@ A.env x + let marshal (x: t): marshal = - let vars = Array.map Var.to_string (vars_as_array x) in + let vars = Array.map Var.to_string (Array.of_list (Environment.ivars_only (A.env x))) in x.abstract0, vars let mem_var d v = Environment.mem_var (A.env d) v let add_vars_with nd vs = - let env' = EnvOps.add_vars (A.env nd) vs in + let env' = Environment.add_vars (A.env nd) vs in A.change_environment_with Man.mgr nd env' false let remove_vars_with nd vs = - let env' = EnvOps.remove_vars (A.env nd) vs in + let env' = Environment.remove_vars (A.env nd) vs in A.change_environment_with Man.mgr nd env' false let remove_filter_with nd f = - let env' = EnvOps.remove_filter (A.env nd) f in + let env' = Environment.remove_filter (A.env nd) f in A.change_environment_with Man.mgr nd env' false let keep_vars_with nd vs = - let env' = EnvOps.keep_vars (A.env nd) vs in + let env' = Environment.keep_vars (A.env nd) vs in A.change_environment_with Man.mgr nd env' false let keep_filter_with nd f = - let env' = EnvOps.keep_filter (A.env nd) f in + let env' = Environment.keep_filter (A.env nd) f in A.change_environment_with Man.mgr nd env' false let forget_vars_with nd vs = @@ -885,7 +877,6 @@ struct let unmarshal (b, d) = (BoxD.unmarshal b, D.unmarshal d) let mem_var (_, d) v = D.mem_var d v - let vars_as_array (_, d) = D.vars_as_array d let vars (_, d) = D.vars d let pretty_diff () ((_, d1), (_, d2)) = D.pretty_diff () (d1, d2) diff --git a/src/cdomains/apron/gobApron.apron.ml b/src/cdomains/apron/gobApron.apron.ml index df20f3c59d..c39a3e42db 100644 --- a/src/cdomains/apron/gobApron.apron.ml +++ b/src/cdomains/apron/gobApron.apron.ml @@ -35,3 +35,64 @@ struct ) |> of_enum end + +(** A few code elements for environment changes from functions as remove_vars etc. have been moved to sharedFunctions as they are needed in a similar way inside affineEqualityDomain. + A module that includes various methods used by variable handling operations such as add_vars, remove_vars etc. in apronDomain and affineEqualityDomain. *) +module Environment = +struct + include Environment + + let ivars_only env = + let ivs, fvs = Environment.vars env in + assert (Array.length fvs = 0); (* shouldn't ever contain floats *) + List.of_enum (Array.enum ivs) + + let add_vars env vs = + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> not (Environment.mem_var env v)) + |> Array.of_enum + in + Environment.add env vs' [||] + + let remove_vars env vs = + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> Environment.mem_var env v) + |> Array.of_enum + in + Environment.remove env vs' + + let remove_filter env f = + let vs' = + ivars_only env + |> List.enum + |> Enum.filter f + |> Array.of_enum + in + Environment.remove env vs' + + let keep_vars env vs = + (* Instead of iterating over all vars in env and doing a linear lookup in vs just to remove them, + make a new env with just the desired vs. *) + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> Environment.mem_var env v) + |> Array.of_enum + in + Environment.make vs' [||] + + let keep_filter env f = + (* Instead of removing undesired vars, + make a new env with just the desired vars. *) + let vs' = + ivars_only env + |> List.enum + |> Enum.filter f + |> Array.of_enum + in + Environment.make vs' [||] +end diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index 9c229e2d64..e66be00ae4 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -255,66 +255,6 @@ struct include CilOfApron (V) end -(** A few code elements for environment changes from functions as remove_vars etc. have been moved to sharedFunctions as they are needed in a similar way inside affineEqualityDomain. - A module that includes various methods used by variable handling operations such as add_vars, remove_vars etc. in apronDomain and affineEqualityDomain. *) -module EnvOps = -struct - let vars env = - let ivs, fvs = Environment.vars env in - assert (Array.length fvs = 0); (* shouldn't ever contain floats *) - List.of_enum (Array.enum ivs) - - let add_vars env vs = - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> not (Environment.mem_var env v)) - |> Array.of_enum - in - Environment.add env vs' [||] - - let remove_vars env vs = - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> Environment.mem_var env v) - |> Array.of_enum - in - Environment.remove env vs' - - let remove_filter env f = - let vs' = - vars env - |> List.enum - |> Enum.filter f - |> Array.of_enum - in - Environment.remove env vs' - - let keep_vars env vs = - (* Instead of iterating over all vars in env and doing a linear lookup in vs just to remove them, - make a new env with just the desired vs. *) - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> Environment.mem_var env v) - |> Array.of_enum - in - Environment.make vs' [||] - - let keep_filter env f = - (* Instead of removing undesired vars, - make a new env with just the desired vars. *) - let vs' = - vars env - |> List.enum - |> Enum.filter f - |> Array.of_enum - in - Environment.make vs' [||] - -end - (** A more specific module type for RelationDomain.RelD2 with ConvBounds integrated and various apron elements. It is designed to be the interface for the D2 modules in affineEqualityDomain and apronDomain and serves as a functor argument for AssertionModule. *) module type AssertionRelS = From 4a848e4c809fd9e917ecc5dd5bdfaea234c06ea1 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 19:45:47 +0100 Subject: [PATCH 146/233] Simplify marshal --- src/cdomains/apron/apronDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index 077aa971f2..ac9d7f0232 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -258,7 +258,7 @@ struct let vars x = Environment.ivars_only @@ A.env x let marshal (x: t): marshal = - let vars = Array.map Var.to_string (Array.of_list (Environment.ivars_only (A.env x))) in + let vars = Array.map Var.to_string (Array.of_list (vars x)) in x.abstract0, vars let mem_var d v = Environment.mem_var (A.env d) v From 13ac2001d8eed3060712ac05af74dfd3fc943b1d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 19:52:21 +0100 Subject: [PATCH 147/233] Some reuse --- src/cdomains/apron/apronDomain.apron.ml | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index ac9d7f0232..03b9558621 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -263,25 +263,16 @@ struct let mem_var d v = Environment.mem_var (A.env d) v - let add_vars_with nd vs = - let env' = Environment.add_vars (A.env nd) vs in + let envop f nd a = + let env' = f (A.env nd) a in A.change_environment_with Man.mgr nd env' false - let remove_vars_with nd vs = - let env' = Environment.remove_vars (A.env nd) vs in - A.change_environment_with Man.mgr nd env' false - - let remove_filter_with nd f = - let env' = Environment.remove_filter (A.env nd) f in - A.change_environment_with Man.mgr nd env' false + let add_vars_with = envop Environment.add_vars + let remove_vars_with = envop Environment.remove_vars + let remove_filter_with = envop Environment.remove_filter + let keep_vars_with = envop Environment.keep_vars + let keep_filter_with = envop Environment.keep_filter - let keep_vars_with nd vs = - let env' = Environment.keep_vars (A.env nd) vs in - A.change_environment_with Man.mgr nd env' false - - let keep_filter_with nd f = - let env' = Environment.keep_filter (A.env nd) f in - A.change_environment_with Man.mgr nd env' false let forget_vars_with nd vs = (* Unlike keep_vars_with, this doesn't check mem_var, but assumes valid vars, like assigns *) From efa239491f9060aa7a89bd9197d82b8e757bd427 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 4 Dec 2023 20:16:51 +0100 Subject: [PATCH 148/233] Add TODO --- src/cdomains/apron/affineEqualityDomain.apron.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ff2339cd6f..5aa1090dd4 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -461,6 +461,7 @@ struct let assign_exp (t: VarManagement(Vc)(Mx).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 + (* TODO: Do we need to do a constant folding here? It happens for texpr1_of_cil_exp *) match Convert.texpr1_expr_of_cil_exp t t.env exp (Lazy.force no_ov) with | exp -> assign_texpr t var exp | exception Convert.Unsupported_CilExp _ -> From daf4c855f7524daded7d3b712b9684c17864ee8c Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Dec 2023 20:23:06 +0000 Subject: [PATCH 149/233] Bump actions/configure-pages from 3 to 4 Bumps [actions/configure-pages](https://github.com/actions/configure-pages) from 3 to 4. - [Release notes](https://github.com/actions/configure-pages/releases) - [Commits](https://github.com/actions/configure-pages/compare/v3...v4) --- updated-dependencies: - dependency-name: actions/configure-pages dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index e1648904c3..a34d3d1a87 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -46,7 +46,7 @@ jobs: - name: Setup Pages id: pages - uses: actions/configure-pages@v3 + uses: actions/configure-pages@v4 - name: Install dependencies run: opam install . --deps-only --locked --with-doc From ea28ee894565a9897594977ca561c6b4ae2e988a Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 4 Dec 2023 20:23:11 +0000 Subject: [PATCH 150/233] Bump actions/deploy-pages from 2 to 3 Bumps [actions/deploy-pages](https://github.com/actions/deploy-pages) from 2 to 3. - [Release notes](https://github.com/actions/deploy-pages/releases) - [Commits](https://github.com/actions/deploy-pages/compare/v2...v3) --- updated-dependencies: - dependency-name: actions/deploy-pages dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index e1648904c3..60314d6f2e 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -68,4 +68,4 @@ jobs: steps: - name: Deploy to GitHub Pages id: deployment - uses: actions/deploy-pages@v2 + uses: actions/deploy-pages@v3 From dff61c929f444a46dd40d327562115e433272554 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 5 Dec 2023 16:19:50 +0200 Subject: [PATCH 151/233] Remove two ignores of spec analysis --- .gitignore | 1 - scripts/regression2sv-benchmarks.py | 1 - 2 files changed, 2 deletions(-) diff --git a/.gitignore b/.gitignore index 75bd23d36b..faf1513653 100644 --- a/.gitignore +++ b/.gitignore @@ -29,7 +29,6 @@ linux-headers .goblint*/ goblint_temp_*/ -src/spec/graph .vagrant g2html.jar diff --git a/scripts/regression2sv-benchmarks.py b/scripts/regression2sv-benchmarks.py index 8f74a70f52..7bcc1c7ea3 100755 --- a/scripts/regression2sv-benchmarks.py +++ b/scripts/regression2sv-benchmarks.py @@ -31,7 +31,6 @@ "09-regions_34-escape_rc", # duplicate of 04/45 "09-regions_35-list2_rc-offsets-thread", # duplicate of 09/03 "10-synch_17-glob_fld_nr", # duplicate of 05/08 - "19-spec_02-mutex_rc", # duplicate of 04/01 "29-svcomp_01-race-2_3b-container_of", # duplicate sv-benchmarks "29-svcomp_01-race-2_4b-container_of", # duplicate sv-benchmarks From 02721c64ade754dc77e2032647994ba46fbb8050 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 15:31:28 +0200 Subject: [PATCH 152/233] Remove unused MyCheck.Arbitrary.varinfo --- src/common/cdomains/basetype.ml | 2 -- src/common/domains/myCheck.ml | 3 --- 2 files changed, 5 deletions(-) diff --git a/src/common/cdomains/basetype.ml b/src/common/cdomains/basetype.ml index 55b5dbde07..da6c2bc100 100644 --- a/src/common/cdomains/basetype.ml +++ b/src/common/cdomains/basetype.ml @@ -20,8 +20,6 @@ struct | _ -> Local let name () = "variables" let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) - - let arbitrary () = MyCheck.Arbitrary.varinfo end module RawStrings: Printable.S with type t = string = diff --git a/src/common/domains/myCheck.ml b/src/common/domains/myCheck.ml index 98583cd2c3..12809d5b46 100644 --- a/src/common/domains/myCheck.ml +++ b/src/common/domains/myCheck.ml @@ -56,7 +56,4 @@ struct let gens = List.map gen arbs in let shrinks = List.map shrink arbs in make ~shrink:(Shrink.sequence shrinks) (Gen.sequence gens) - - open GoblintCil - let varinfo: Cil.varinfo arbitrary = QCheck.always (Cil.makeGlobalVar "arbVar" Cil.voidPtrType) (* S TODO: how to generate this *) end From 152ed0df4f1fc525c5401311f86038a3bb618f04 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 15:36:46 +0200 Subject: [PATCH 153/233] Move MyCheck to goblint.std as GobQCheck --- src/analyses/mCPRegistry.ml | 2 +- src/cdomains/intDomain.ml | 24 +++++++++---------- src/common/common.mld | 3 --- src/common/domains/printable.ml | 8 +++---- src/goblint_lib.ml | 6 ----- src/util/std/dune | 3 ++- .../myCheck.ml => util/std/gobQCheck.ml} | 0 src/util/std/goblint_std.ml | 1 + unittest/util/intOpsTest.ml | 4 ++-- 9 files changed, 22 insertions(+), 29 deletions(-) rename src/{common/domains/myCheck.ml => util/std/gobQCheck.ml} (100%) diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index 810da827ff..5d0174d44c 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -215,7 +215,7 @@ struct let arbitrary () = let arbs = map (fun (n, (module D: Printable.S)) -> QCheck.map ~rev:(fun (_, o) -> obj o) (fun x -> (n, repr x)) @@ D.arbitrary ()) @@ domain_list () in - MyCheck.Arbitrary.sequence arbs + GobQCheck.Arbitrary.sequence arbs let relift = unop_map (fun (module S: Printable.S) x -> Obj.repr (S.relift (Obj.obj x))) end diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 054030017f..5d5174744f 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -996,12 +996,12 @@ struct let arbitrary ik = let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint MyCheck.Arbitrary.big_int 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 MyCheck.Arbitrary.int64 in + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in let pair_arb = QCheck.pair int_arb int_arb in let shrink = function - | Some (l, u) -> (return None) <+> (MyCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | 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) @@ -1601,13 +1601,13 @@ struct let arbitrary ik = let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint MyCheck.Arbitrary.big_int 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 MyCheck.Arbitrary.int64 in + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in let pair_arb = QCheck.pair int_arb int_arb in let list_pair_arb = QCheck.small_list pair_arb in let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in - let shrink xs = MyCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) end @@ -1695,7 +1695,7 @@ struct let logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) let logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) let cast_to ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 MyCheck.Arbitrary.int64 (* TODO: use ikind *) + let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) let invariant _ _ = Invariant.none (* TODO *) end @@ -2402,8 +2402,8 @@ struct let excluded s = from_excl ik s in let definite x = of_int ik x in let shrink = function - | `Excluded (s, _) -> MyCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (MyCheck.shrink (BigInt.arbitrary ()) x >|= definite) + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (BigInt.arbitrary ()) x >|= definite) | `Bot -> empty in QCheck.frequency ~shrink ~print:show [ @@ -2816,8 +2816,8 @@ module Enums : S with type int_t = BigInt.t = struct let neg s = of_excl_list ik (BISet.elements s) in let pos s = norm ik (Inc s) in let shrink = function - | Exc (s, _) -> MyCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> MyCheck.shrink (BISet.arbitrary ()) s >|= pos + | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) + | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map neg (BISet.arbitrary ()); @@ -3307,7 +3307,7 @@ struct let arbitrary ik = let open QCheck in - let int_arb = map ~rev:Ints_t.to_int64 Ints_t.of_int64 MyCheck.Arbitrary.int64 in + let int_arb = map ~rev:Ints_t.to_int64 Ints_t.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 diff --git a/src/common/common.mld b/src/common/common.mld index 662c789572..bf3f4d62e1 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -69,6 +69,3 @@ RichVarinfo {2 Standard library} {!modules:GobFormat} - -{2 Other libraries} -{!modules:MyCheck} diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index 3499cfdb04..cc01718ee8 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -233,9 +233,9 @@ struct let arbitrary () = let open QCheck.Iter in let shrink = function - | `Lifted x -> (return `Bot) <+> (MyCheck.shrink (Base.arbitrary ()) x >|= lift) + | `Lifted x -> (return `Bot) <+> (GobQCheck.shrink (Base.arbitrary ()) x >|= lift) | `Bot -> empty - | `Top -> MyCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift + | `Top -> GobQCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map lift (Base.arbitrary ()); @@ -626,8 +626,8 @@ struct let arbitrary () = let open QCheck.Iter in let shrink = function - | `Lifted x -> MyCheck.shrink (Base.arbitrary ()) x >|= lift - | `Top -> MyCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift + | `Lifted x -> GobQCheck.shrink (Base.arbitrary ()) x >|= lift + | `Top -> GobQCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map lift (Base.arbitrary ()); diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index cdb37b1256..e448d23775 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -461,9 +461,3 @@ module ApronPrecCompareUtil = ApronPrecCompareUtil OCaml standard library extensions which are not provided by {!Batteries}. *) module GobFormat = GobFormat - -(** {2 Other libraries} - - External library extensions. *) - -module MyCheck = MyCheck diff --git a/src/util/std/dune b/src/util/std/dune index c6961a1725..b074a29937 100644 --- a/src/util/std/dune +++ b/src/util/std/dune @@ -9,7 +9,8 @@ goblint-cil fpath yojson - yaml) + yaml + qcheck-core) (preprocess (pps ppx_deriving.std diff --git a/src/common/domains/myCheck.ml b/src/util/std/gobQCheck.ml similarity index 100% rename from src/common/domains/myCheck.ml rename to src/util/std/gobQCheck.ml diff --git a/src/util/std/goblint_std.ml b/src/util/std/goblint_std.ml index e716d1df5b..0d548cac08 100644 --- a/src/util/std/goblint_std.ml +++ b/src/util/std/goblint_std.ml @@ -19,6 +19,7 @@ module GobUnix = GobUnix module GobFpath = GobFpath module GobPretty = GobPretty +module GobQCheck = GobQCheck module GobYaml = GobYaml module GobYojson = GobYojson module GobZ = GobZ diff --git a/unittest/util/intOpsTest.ml b/unittest/util/intOpsTest.ml index 611f2f546f..006c66e13f 100644 --- a/unittest/util/intOpsTest.ml +++ b/unittest/util/intOpsTest.ml @@ -10,13 +10,13 @@ let old_div a b = if Z.lt a Z.zero then Z.neg (Z.ediv (Z.neg a) b) else Z.ediv a let old_rem a b = Z.sub a (Z.mul b (old_div a b)) let test_bigint_div = - QCheck.(Test.make ~name:"div" (pair MyCheck.Arbitrary.big_int MyCheck.Arbitrary.big_int) (fun (x, y) -> + QCheck.(Test.make ~name:"div" (pair GobQCheck.Arbitrary.big_int GobQCheck.Arbitrary.big_int) (fun (x, y) -> assume (Z.compare y Z.zero <> 0); Z.equal (Z.div x y) (old_div x y) )) let test_bigint_rem = - QCheck.(Test.make ~name:"rem" (pair MyCheck.Arbitrary.big_int MyCheck.Arbitrary.big_int) (fun (x, y) -> + QCheck.(Test.make ~name:"rem" (pair GobQCheck.Arbitrary.big_int GobQCheck.Arbitrary.big_int) (fun (x, y) -> assume (Z.compare y Z.zero <> 0); Z.equal (Z.rem x y) (old_rem x y) )) From c7f94ff3dc56c116f1835f027ad338dfaebfcb30 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 15:54:14 +0200 Subject: [PATCH 154/233] Remove Basetype dependency on Lattice --- src/common/cdomains/basetype.ml | 12 ------------ src/domains/boolDomain.ml | 8 +++++++- src/domains/queries.ml | 6 +++++- src/framework/constraints.ml | 2 +- 4 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/common/cdomains/basetype.ml b/src/common/cdomains/basetype.ml index da6c2bc100..1b846309aa 100644 --- a/src/common/cdomains/basetype.ml +++ b/src/common/cdomains/basetype.ml @@ -33,12 +33,6 @@ struct let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) end -module Strings: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = - Lattice.Flat (RawStrings) (struct - let top_name = "?" - let bot_name = "-" - end) - module RawBools: Printable.S with type t = bool = struct include Printable.StdLeaf @@ -50,12 +44,6 @@ struct let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) end -module Bools: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = - Lattice.Flat (RawBools) (struct - let top_name = "?" - let bot_name = "-" - end) - module CilExp = struct include CilType.Exp diff --git a/src/domains/boolDomain.ml b/src/domains/boolDomain.ml index e088c3605c..43e15e1405 100644 --- a/src/domains/boolDomain.ml +++ b/src/domains/boolDomain.ml @@ -38,4 +38,10 @@ struct let widen = (&&) let meet = (||) let narrow = (||) -end \ No newline at end of file +end + +module FlatBool: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = + Lattice.Flat (Bool) (struct + let top_name = "?" + let bot_name = "-" + end) diff --git a/src/domains/queries.ml b/src/domains/queries.ml index b9fa28f5be..228320bef3 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -32,7 +32,11 @@ module FlatYojson = Lattice.Flat (Printable.Yojson) (struct let bot_name = "bot yojson" end) -module SD = Basetype.Strings +module SD: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = + Lattice.Flat (Basetype.RawStrings) (struct + let top_name = "?" + let bot_name = "-" + end) module VD = ValueDomain.Compound module AD = ValueDomain.AD diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index b6046d023b..329b3b6415 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1344,7 +1344,7 @@ struct module EM = struct - include MapDomain.MapBot (Basetype.CilExp) (Basetype.Bools) + include MapDomain.MapBot (Basetype.CilExp) (BoolDomain.FlatBool) let name () = "branches" end From 983a226c7872c528897e0f70f4c631eef8aa7ff5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:03:38 +0200 Subject: [PATCH 155/233] Remove Lattice dependency on GobConfig --- src/common/domains/lattice.ml | 10 +++------- src/domains/mapDomain.ml | 2 +- src/framework/constraints.ml | 11 ++++++++--- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/common/domains/lattice.ml b/src/common/domains/lattice.ml index 51306d637f..9ea3f74635 100644 --- a/src/common/domains/lattice.ml +++ b/src/common/domains/lattice.ml @@ -148,18 +148,14 @@ struct end (* HAS SIDE-EFFECTS ---- PLEASE INSTANCIATE ONLY ONCE!!! *) -module HConsed (Base:S) = +module HConsed (Base:S) (Arg: sig val assume_idempotent: bool end) = struct include Printable.HConsed (Base) - (* We do refine int values on narrow and meet {!IntDomain.IntDomTupleImpl}, which can lead to fixpoint issues if we assume x op x = x *) - (* see https://github.com/goblint/analyzer/issues/1005 *) - let int_refine_active = GobConfig.get_string "ana.int.refinement" <> "never" - let lift_f2 f x y = f (unlift x) (unlift y) - let narrow x y = if (not int_refine_active) && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.narrow x y) + let narrow x y = if Arg.assume_idempotent && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.narrow x y) let widen x y = if x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.widen x y) - let meet x y = if (not int_refine_active) && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.meet x y) + let meet x y = if Arg.assume_idempotent && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.meet x y) let join x y = if x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.join x y) let leq x y = (x.BatHashcons.tag == y.BatHashcons.tag) || lift_f2 Base.leq x y let is_top = lift_f Base.is_top diff --git a/src/domains/mapDomain.ml b/src/domains/mapDomain.ml index 76dec6f0d2..4972da7d26 100644 --- a/src/domains/mapDomain.ml +++ b/src/domains/mapDomain.ml @@ -263,7 +263,7 @@ module HConsed (M: S) : S with type key = M.key and type value = M.value = struct - include Lattice.HConsed (M) + include Lattice.HConsed (M) (struct let assume_idempotent = false end) type key = M.key type value = M.value diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 329b3b6415..2763835e71 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -12,12 +12,17 @@ module M = Messages (** Lifts a [Spec] so that the domain is [Hashcons]d *) module HashconsLifter (S:Spec) - : Spec with module D = Lattice.HConsed (S.D) - and module G = S.G + : Spec with module G = S.G and module C = S.C = struct - module D = Lattice.HConsed (S.D) + module HConsedArg = + struct + (* We do refine int values on narrow and meet {!IntDomain.IntDomTupleImpl}, which can lead to fixpoint issues if we assume x op x = x *) + (* see https://github.com/goblint/analyzer/issues/1005 *) + let assume_idempotent = GobConfig.get_string "ana.int.refinement" = "never" + end + module D = Lattice.HConsed (S.D) (HConsedArg) module G = S.G module C = S.C module V = S.V From a4f9689b173d8a071e9575c24c8567e708143d31 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:10:01 +0200 Subject: [PATCH 156/233] Fix unittest compilation --- unittest/dune | 2 +- unittest/util/intOpsTest.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/unittest/dune b/unittest/dune index 7313aa964b..a08a4b2323 100644 --- a/unittest/dune +++ b/unittest/dune @@ -2,7 +2,7 @@ (test (name mainTest) - (libraries ounit2 qcheck-ounit goblint.lib goblint.sites.dune goblint.build-info.dune) + (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.sites.dune goblint.build-info.dune) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall)) diff --git a/unittest/util/intOpsTest.ml b/unittest/util/intOpsTest.ml index 006c66e13f..307d9e84b0 100644 --- a/unittest/util/intOpsTest.ml +++ b/unittest/util/intOpsTest.ml @@ -1,4 +1,5 @@ open OUnit2 +open Goblint_std open Goblint_lib (* If the first operand of a div is negative, Zarith rounds the result away from zero. From 19bcd3a753f21b679d4789f597eb26c0c79b4339 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:14:57 +0200 Subject: [PATCH 157/233] Extract Lattice to goblint_domain dune library --- src/common/common.mld | 1 - src/domain/domain.mld | 9 +++++++++ src/domain/dune | 19 +++++++++++++++++++ src/{common/domains => domain}/lattice.ml | 0 src/dune | 2 +- src/index.mld | 3 +++ 6 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 src/domain/domain.mld create mode 100644 src/domain/dune rename src/{common/domains => domain}/lattice.ml (100%) diff --git a/src/common/common.mld b/src/common/common.mld index bf3f4d62e1..d8b8604b0b 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -30,7 +30,6 @@ Options {1 Domains} {!modules: Printable -Lattice } {2 Analysis-specific} diff --git a/src/domain/domain.mld b/src/domain/domain.mld new file mode 100644 index 0000000000..43d650abdd --- /dev/null +++ b/src/domain/domain.mld @@ -0,0 +1,9 @@ +{0 Library goblint.domain} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Domains} +{!modules: +Lattice +} diff --git a/src/domain/dune b/src/domain/dune new file mode 100644 index 0000000000..45345b5946 --- /dev/null +++ b/src/domain/dune @@ -0,0 +1,19 @@ +(include_subdirs unqualified) + +(library + (name goblint_domain) + (public_name goblint.domain) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson))) + +(documentation) diff --git a/src/common/domains/lattice.ml b/src/domain/lattice.ml similarity index 100% rename from src/common/domains/lattice.ml rename to src/domain/lattice.ml diff --git a/src/dune b/src/dune index d3fe6bdd0d..b57de472d3 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common goblint_domain ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/index.mld b/src/index.mld index 2afbbc97ae..393323286b 100644 --- a/src/index.mld +++ b/src/index.mld @@ -10,6 +10,9 @@ This library currently contains the majority of Goblint and is in the process of {2 Library goblint.common} This {{!page-common}unwrapped library} contains various common modules extracted from {!Goblint_lib}. +{2 Library goblint.domain} +This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. + {1 Library extensions} The following libraries provide extensions to other OCaml libraries. From 5937314efc456f84625e5b97c9312526a87f23b0 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:20:52 +0200 Subject: [PATCH 158/233] Move general domains to goblint_domain library --- src/{domains => domain}/boolDomain.ml | 0 src/{domains => domain}/disjointDomain.ml | 0 src/domain/domain.mld | 12 ++++++++++++ src/{domains => domain}/flagHelper.ml | 0 src/{domains => domain}/hoareDomain.ml | 0 src/{domains => domain}/mapDomain.ml | 0 src/{domains => domain}/partitionDomain.ml | 0 src/{domains => domain}/setDomain.ml | 0 src/{domains => domain}/trieDomain.ml | 0 9 files changed, 12 insertions(+) rename src/{domains => domain}/boolDomain.ml (100%) rename src/{domains => domain}/disjointDomain.ml (100%) rename src/{domains => domain}/flagHelper.ml (100%) rename src/{domains => domain}/hoareDomain.ml (100%) rename src/{domains => domain}/mapDomain.ml (100%) rename src/{domains => domain}/partitionDomain.ml (100%) rename src/{domains => domain}/setDomain.ml (100%) rename src/{domains => domain}/trieDomain.ml (100%) diff --git a/src/domains/boolDomain.ml b/src/domain/boolDomain.ml similarity index 100% rename from src/domains/boolDomain.ml rename to src/domain/boolDomain.ml diff --git a/src/domains/disjointDomain.ml b/src/domain/disjointDomain.ml similarity index 100% rename from src/domains/disjointDomain.ml rename to src/domain/disjointDomain.ml diff --git a/src/domain/domain.mld b/src/domain/domain.mld index 43d650abdd..ce7e1a5859 100644 --- a/src/domain/domain.mld +++ b/src/domain/domain.mld @@ -7,3 +7,15 @@ For better context, see {!Goblint_lib} which also documents these modules. {!modules: Lattice } + +{2 General} +{!modules: +BoolDomain +SetDomain +MapDomain +TrieDomain +DisjointDomain +HoareDomain +PartitionDomain +FlagHelper +} diff --git a/src/domains/flagHelper.ml b/src/domain/flagHelper.ml similarity index 100% rename from src/domains/flagHelper.ml rename to src/domain/flagHelper.ml diff --git a/src/domains/hoareDomain.ml b/src/domain/hoareDomain.ml similarity index 100% rename from src/domains/hoareDomain.ml rename to src/domain/hoareDomain.ml diff --git a/src/domains/mapDomain.ml b/src/domain/mapDomain.ml similarity index 100% rename from src/domains/mapDomain.ml rename to src/domain/mapDomain.ml diff --git a/src/domains/partitionDomain.ml b/src/domain/partitionDomain.ml similarity index 100% rename from src/domains/partitionDomain.ml rename to src/domain/partitionDomain.ml diff --git a/src/domains/setDomain.ml b/src/domain/setDomain.ml similarity index 100% rename from src/domains/setDomain.ml rename to src/domain/setDomain.ml diff --git a/src/domains/trieDomain.ml b/src/domain/trieDomain.ml similarity index 100% rename from src/domains/trieDomain.ml rename to src/domain/trieDomain.ml From 1eb7af8e3e68abaeb60aca9056b15161f24f4679 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:46:21 +0200 Subject: [PATCH 159/233] Remove Tracing dependency on CilType --- src/common/util/messages.ml | 18 ++++++++++++++++++ src/common/util/tracing.ml | 17 ----------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/common/util/messages.ml b/src/common/util/messages.ml index 42a3118978..c9a08e8177 100644 --- a/src/common/util/messages.ml +++ b/src/common/util/messages.ml @@ -340,3 +340,21 @@ let msg_final severity ?(tags=[]) ?(category=Category.Unknown) fmt = GobPretty.igprintf () fmt include Tracing + +open Pretty + +let tracel sys ?var fmt = + let loc = !current_loc in + let docloc sys doc = + printtrace sys (dprintf "(%a)@?" CilType.Location.pretty loc ++ indent 2 doc); + in + gtrace true docloc sys var ~loc ignore fmt + +let traceli sys ?var ?(subsys=[]) fmt = + let loc = !current_loc in + let g () = activate sys subsys in + let docloc sys doc: unit = + printtrace sys (dprintf "(%a)" CilType.Location.pretty loc ++ indent 2 doc); + traceIndent () + in + gtrace true docloc sys var ~loc g fmt diff --git a/src/common/util/tracing.ml b/src/common/util/tracing.ml index ad8892c396..e4167d83a8 100644 --- a/src/common/util/tracing.ml +++ b/src/common/util/tracing.ml @@ -67,13 +67,6 @@ let trace sys ?var fmt = gtrace true printtrace sys var ignore fmt * c: continue/normal print w/o indent-change *) -let tracel sys ?var fmt = - let loc = !current_loc in - let docloc sys doc = - printtrace sys (dprintf "(%a)@?" CilType.Location.pretty loc ++ indent 2 doc); - in - gtrace true docloc sys var ~loc ignore fmt - let tracei (sys:string) ?var ?(subsys=[]) fmt = let f sys d = printtrace sys d; traceIndent () in let g () = activate sys subsys in @@ -85,13 +78,3 @@ let traceu sys fmt = let f sys d = printtrace sys d; traceOutdent () in let g () = deactivate sys in gtrace true f sys None g fmt - - -let traceli sys ?var ?(subsys=[]) fmt = - let loc = !current_loc in - let g () = activate sys subsys in - let docloc sys doc: unit = - printtrace sys (dprintf "(%a)" CilType.Location.pretty loc ++ indent 2 doc); - traceIndent () - in - gtrace true docloc sys var ~loc g fmt From 1ac6baf4b5a2239e7b0d6aaf48496a36502efce6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 16:56:01 +0200 Subject: [PATCH 160/233] Extract Tracing to goblint_tracing dune library --- src/analyses/basePriv.ml | 4 ++-- src/analyses/extractPthread.ml | 2 +- src/analyses/stackTrace.ml | 4 ++-- src/cdomains/valueDomain.ml | 2 +- src/common/common.mld | 1 - src/common/dune | 1 + src/common/util/gobConfig.ml | 9 ++++----- src/common/util/messages.ml | 3 ++- src/dune | 2 +- src/framework/constraints.ml | 12 ++++++------ src/framework/control.ml | 10 +++++----- src/goblint_lib.ml | 1 - src/index.mld | 3 +++ src/maingoblint.ml | 6 +++--- src/util/tracing/dune | 9 +++++++++ .../tracing.ml => util/tracing/goblint_tracing.ml} | 1 + 16 files changed, 41 insertions(+), 29 deletions(-) create mode 100644 src/util/tracing/dune rename src/{common/util/tracing.ml => util/tracing/goblint_tracing.ml} (99%) diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index e42cd5a309..f9a4a22f44 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -230,7 +230,7 @@ struct CPA.find x st.cpa (* let read_global ask getg cpa x = let (cpa', v) as r = read_global ask getg cpa x in - ignore (Pretty.printf "READ GLOBAL %a (%a, %B) = %a\n" CilType.Varinfo.pretty x CilType.Location.pretty !Tracing.current_loc (is_unprotected ask x) VD.pretty v); + ignore (Pretty.printf "READ GLOBAL %a (%a, %B) = %a\n" CilType.Varinfo.pretty x CilType.Location.pretty !Goblint_tracing.current_loc (is_unprotected ask x) VD.pretty v); r *) let write_global ?(invariant=false) ask getg sideg (st: BaseComponents (D).t) x v = let cpa' = CPA.add x v st.cpa in @@ -1665,7 +1665,7 @@ struct let read_global ask getg st x = let v = Priv.read_global ask getg st x in if !AnalysisState.postsolving && !is_dumping then - LVH.modify_def (VD.bot ()) (!Tracing.current_loc, x) (VD.join v) lvh; + LVH.modify_def (VD.bot ()) (!Goblint_tracing.current_loc, x) (VD.join v) lvh; v let dump () = diff --git a/src/analyses/extractPthread.ml b/src/analyses/extractPthread.ml index f084a21edb..8412a65683 100644 --- a/src/analyses/extractPthread.ml +++ b/src/analyses/extractPthread.ml @@ -220,7 +220,7 @@ module Tbls = struct let make_new_val table k = (* TODO: all same key occurrences instead *) let line = -5 - all_keys_count table in - let loc = { !Tracing.current_loc with line } in + let loc = { !Goblint_tracing.current_loc with line } in MyCFG.Statement { (mkStmtOneInstr @@ Set (var dummyFunDec.svar, zero, loc, loc)) with sid = new_sid () diff --git a/src/analyses/stackTrace.ml b/src/analyses/stackTrace.ml index 3c3bd56640..dd2cedf871 100644 --- a/src/analyses/stackTrace.ml +++ b/src/analyses/stackTrace.ml @@ -36,7 +36,7 @@ struct (* transfer functions *) let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, D.push !Tracing.current_loc ctx.local] + [ctx.local, D.push !Goblint_tracing.current_loc ctx.local] let combine_env ctx lval fexp f args fc au f_ask = ctx.local (* keep local as opposed to IdentitySpec *) @@ -46,7 +46,7 @@ struct let exitstate v = D.top () let threadenter ctx ~multiple lval f args = - [D.push !Tracing.current_loc ctx.local] + [D.push !Goblint_tracing.current_loc ctx.local] end diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index cba4b04c18..e6f3122cb0 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -502,7 +502,7 @@ struct let warn_type op x y = if GobConfig.get_bool "dbg.verbose" then - ignore @@ printf "warn_type %s: incomparable abstr. values %s and %s at %a: %a and %a\n" op (tag_name (x:t)) (tag_name (y:t)) CilType.Location.pretty !Tracing.current_loc pretty x pretty y + ignore @@ printf "warn_type %s: incomparable abstr. values %s and %s at %a: %a and %a\n" op (tag_name (x:t)) (tag_name (y:t)) CilType.Location.pretty !Goblint_tracing.current_loc pretty x pretty y let rec leq x y = match (x,y) with diff --git a/src/common/common.mld b/src/common/common.mld index d8b8604b0b..3106933602 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -41,7 +41,6 @@ Printable {1 I/O} {!modules: Messages -Tracing } diff --git a/src/common/dune b/src/common/dune index c8f1564782..dc9fd61f77 100644 --- a/src/common/dune +++ b/src/common/dune @@ -8,6 +8,7 @@ batteries.unthreaded zarith goblint_std + goblint_tracing goblint-cil fpath yojson diff --git a/src/common/util/gobConfig.ml b/src/common/util/gobConfig.ml index c517ba150d..24a1701ce6 100644 --- a/src/common/util/gobConfig.ml +++ b/src/common/util/gobConfig.ml @@ -21,7 +21,6 @@ *) open Batteries -open Tracing open Printf exception ConfigError of string @@ -300,7 +299,7 @@ struct try let st = String.trim st in let x = get_value !json_conf (parse_path st) in - if tracing then trace "conf-reads" "Reading '%s', it is %a.\n" st GobYojson.pretty x; + if Goblint_tracing.tracing then Goblint_tracing.trace "conf-reads" "Reading '%s', it is %a.\n" st GobYojson.pretty x; try f x with Yojson.Safe.Util.Type_error (s, _) -> eprintf "The value for '%s' has the wrong type: %s\n" st s; @@ -332,7 +331,7 @@ struct let wrap_get f x = (* self-observe options, which Spec construction depends on *) - if !building_spec && Tracing.tracing then Tracing.trace "config" "get during building_spec: %s\n" x; + if !building_spec && Goblint_tracing.tracing then Goblint_tracing.trace "config" "get during building_spec: %s\n" x; (* TODO: blacklist such building_spec option from server mode modification since it will have no effect (spec is already built) *) f x @@ -352,7 +351,7 @@ struct (** Helper function for writing values. Handles the tracing. *) let set_path_string st v = - if tracing then trace "conf" "Setting '%s' to %a.\n" st GobYojson.pretty v; + if Goblint_tracing.tracing then Goblint_tracing.trace "conf" "Setting '%s' to %a.\n" st GobYojson.pretty v; set_value v json_conf (parse_path st) let set_json st j = @@ -402,7 +401,7 @@ struct | Some fn -> let v = Yojson.Safe.from_channel % BatIO.to_input_channel |> File.with_file_in (Fpath.to_string fn) in merge v; - if tracing then trace "conf" "Merging with '%a', resulting\n%a.\n" GobFpath.pretty fn GobYojson.pretty !json_conf + if Goblint_tracing.tracing then Goblint_tracing.trace "conf" "Merging with '%a', resulting\n%a.\n" GobFpath.pretty fn GobYojson.pretty !json_conf | None -> raise (Sys_error (Printf.sprintf "%s: No such file or diretory" (Fpath.to_string fn))) end diff --git a/src/common/util/messages.ml b/src/common/util/messages.ml index c9a08e8177..d7afec43c5 100644 --- a/src/common/util/messages.ml +++ b/src/common/util/messages.ml @@ -339,7 +339,8 @@ let msg_final severity ?(tags=[]) ?(category=Category.Unknown) fmt = else GobPretty.igprintf () fmt -include Tracing + +include Goblint_tracing open Pretty diff --git a/src/dune b/src/dune index b57de472d3..ffc387447e 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common goblint_domain + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common goblint_domain goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 2763835e71..bdb4370b39 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -825,13 +825,13 @@ struct ) let tf var getl sidel getg sideg prev_node (_,edge) d (f,t) = - let old_loc = !Tracing.current_loc in - let old_loc2 = !Tracing.next_loc in - Tracing.current_loc := f; - Tracing.next_loc := t; + let old_loc = !Goblint_tracing.current_loc in + let old_loc2 = !Goblint_tracing.next_loc in + Goblint_tracing.current_loc := f; + Goblint_tracing.next_loc := t; Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> - Tracing.current_loc := old_loc; - Tracing.next_loc := old_loc2 + Goblint_tracing.current_loc := old_loc; + Goblint_tracing.next_loc := old_loc2 ) (fun () -> let d = tf var getl sidel getg sideg prev_node edge d in d diff --git a/src/framework/control.ml b/src/framework/control.ml index 0c9b61739b..00a6034e27 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -142,12 +142,12 @@ struct if List.mem "termination" @@ get_string_list "ana.activated" then ( (* check if we have upjumping gotos *) let open Cilfacade in - let warn_for_upjumps fundec gotos = + let warn_for_upjumps fundec gotos = if FunSet.mem live_funs fundec then ( (* set nortermiantion flag *) AnalysisState.svcomp_may_not_terminate := true; (* iterate through locations to produce warnings *) - LocSet.iter (fun l _ -> + LocSet.iter (fun l _ -> M.warn ~loc:(M.Location.CilLocation l) ~category:Termination "The program might not terminate! (Upjumping Goto)" ) gotos ) @@ -313,7 +313,7 @@ struct if M.tracing then M.trace "con" "Initializer %a\n" CilType.Location.pretty loc; (*incr count; if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) - Tracing.current_loc := loc; + Goblint_tracing.current_loc := loc; match edge with | MyCFG.Entry func -> if M.tracing then M.trace "global_inits" "Entry %a\n" d_lval (var func.svar); @@ -335,9 +335,9 @@ struct in let with_externs = do_extern_inits ctx file in (*if (get_bool "dbg.verbose") then Printf.printf "Number of init. edges : %d\nWorking:" (List.length edges); *) - let old_loc = !Tracing.current_loc in + let old_loc = !Goblint_tracing.current_loc in let result : Spec.D.t = List.fold_left transfer_func with_externs edges in - Tracing.current_loc := old_loc; + Goblint_tracing.current_loc := old_loc; if M.tracing then M.trace "global_inits" "startstate: %a\n" Spec.D.pretty result; result, !funs in diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index e448d23775..3c7dcf41a5 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -325,7 +325,6 @@ module SolverBox = SolverBox Various input/output interfaces and formats. *) module Messages = Messages -module Tracing = Tracing (** {2 Front-end} diff --git a/src/index.mld b/src/index.mld index 393323286b..bad756a8f1 100644 --- a/src/index.mld +++ b/src/index.mld @@ -46,6 +46,9 @@ The following libraries provide utilities which are completely independent of Go {2 Library goblint.timing} {!modules:Goblint_timing} +{2 Library goblint.tracing} +{!modules:Goblint_tracing} + {1 Vendored} The following libraries are vendored in Goblint. diff --git a/src/maingoblint.ml b/src/maingoblint.ml index dcee9abb13..2c7d353594 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -53,7 +53,7 @@ let rec option_spec_list: Arg_complete.speclist Lazy.t = lazy ( let add_string l = let f str = l := str :: !l in Arg_complete.String (f, Arg_complete.empty) in let add_int l = let f str = l := str :: !l in Arg_complete.Int (f, Arg_complete.empty) in let set_trace sys = - if Messages.tracing then Tracing.addsystem sys + if Messages.tracing then Goblint_tracing.addsystem sys else (prerr_endline "Goblint has been compiled without tracing, recompile in trace profile (./scripts/trace_on.sh)"; raise Stdlib.Exit) in let configure_html () = @@ -112,8 +112,8 @@ let rec option_spec_list: Arg_complete.speclist Lazy.t = lazy ( ; "--print_options" , Arg_complete.Unit (fun () -> Options.print_options (); exit 0), "" ; "--print_all_options" , Arg_complete.Unit (fun () -> Options.print_all_options (); exit 0), "" ; "--trace" , Arg_complete.String (set_trace, Arg_complete.empty), "" - ; "--tracevars" , add_string Tracing.tracevars, "" - ; "--tracelocs" , add_int Tracing.tracelocs, "" + ; "--tracevars" , add_string Goblint_tracing.tracevars, "" + ; "--tracelocs" , add_int Goblint_tracing.tracelocs, "" ; "--help" , Arg_complete.Unit (fun _ -> print_help stdout),"" ; "--html" , Arg_complete.Unit (fun _ -> configure_html ()),"" ; "--sarif" , Arg_complete.Unit (fun _ -> configure_sarif ()),"" diff --git a/src/util/tracing/dune b/src/util/tracing/dune new file mode 100644 index 0000000000..7e37139567 --- /dev/null +++ b/src/util/tracing/dune @@ -0,0 +1,9 @@ +(include_subdirs no) + +(library + (name goblint_tracing) + (public_name goblint.tracing) + (libraries + goblint_std + goblint-cil + goblint_build_info)) diff --git a/src/common/util/tracing.ml b/src/util/tracing/goblint_tracing.ml similarity index 99% rename from src/common/util/tracing.ml rename to src/util/tracing/goblint_tracing.ml index e4167d83a8..0e5580b036 100644 --- a/src/common/util/tracing.ml +++ b/src/util/tracing/goblint_tracing.ml @@ -4,6 +4,7 @@ * large domains we output. The original code generated the document object * even when the subsystem is not activated. *) +open Goblint_std open GoblintCil open Pretty From 54d7fdf5dd0f2494fa41a7d55764ec73b54330e3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:08:30 +0200 Subject: [PATCH 161/233] Extract configuration to goblint_config dune library --- .github/workflows/options.yml | 6 ++--- .readthedocs.yaml | 2 +- docs/user-guide/configuring.md | 2 +- src/common/common.mld | 8 ------- src/common/dune | 9 ++------ src/{common/util => config}/afterConfig.ml | 0 src/config/config.mld | 14 +++++++++++ src/config/dune | 23 +++++++++++++++++++ src/{common/util => config}/gobConfig.ml | 0 src/{common/util => config}/jsonSchema.ml | 0 src/{common/util => config}/options.ml | 2 +- .../util => config}/options.schema.json | 0 src/dune | 2 +- src/goblint_lib.ml | 2 +- src/index.mld | 3 +++ 15 files changed, 50 insertions(+), 23 deletions(-) rename src/{common/util => config}/afterConfig.ml (100%) create mode 100644 src/config/config.mld create mode 100644 src/config/dune rename src/{common/util => config}/gobConfig.ml (100%) rename src/{common/util => config}/jsonSchema.ml (100%) rename src/{common/util => config}/options.ml (98%) rename src/{common/util => config}/options.schema.json (100%) diff --git a/.github/workflows/options.yml b/.github/workflows/options.yml index 94c49e4bf6..7ef8b6929e 100644 --- a/.github/workflows/options.yml +++ b/.github/workflows/options.yml @@ -26,10 +26,10 @@ jobs: run: npm install -g ajv-cli - name: Migrate schema # https://github.com/ajv-validator/ajv-cli/issues/199 - run: ajv migrate -s src/common/util/options.schema.json + run: ajv migrate -s src/config/options.schema.json - name: Validate conf - run: ajv validate -s src/common/util/options.schema.json -d "conf/**/*.json" + run: ajv validate -s src/config/options.schema.json -d "conf/**/*.json" - name: Validate incremental tests - run: ajv validate -s src/common/util/options.schema.json -d "tests/incremental/*/*.json" + run: ajv validate -s src/config/options.schema.json -d "tests/incremental/*/*.json" diff --git a/.readthedocs.yaml b/.readthedocs.yaml index 08044d195c..22f9c86121 100644 --- a/.readthedocs.yaml +++ b/.readthedocs.yaml @@ -20,4 +20,4 @@ build: - pip install json-schema-for-humans post_build: - mkdir _readthedocs/html/jsfh/ - - generate-schema-doc --config-file jsfh.yml src/common/util/options.schema.json _readthedocs/html/jsfh/ + - generate-schema-doc --config-file jsfh.yml src/config/options.schema.json _readthedocs/html/jsfh/ diff --git a/docs/user-guide/configuring.md b/docs/user-guide/configuring.md index 9a32a14a4c..cae57fc8cd 100644 --- a/docs/user-guide/configuring.md +++ b/docs/user-guide/configuring.md @@ -24,7 +24,7 @@ In `.vscode/settings.json` add the following: "/conf/*.json", "/tests/incremental/*/*.json" ], - "url": "/src/common/util/options.schema.json" + "url": "/src/config/options.schema.json" } ] } diff --git a/src/common/common.mld b/src/common/common.mld index 3106933602..a1cc9a261a 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -18,14 +18,6 @@ AnalysisState ControlSpecC } -{2 Configuration} -{!modules: -GobConfig -AfterConfig -JsonSchema -Options -} - {1 Domains} {!modules: diff --git a/src/common/dune b/src/common/dune index dc9fd61f77..7994798579 100644 --- a/src/common/dune +++ b/src/common/dune @@ -8,23 +8,18 @@ batteries.unthreaded zarith goblint_std + goblint_config goblint_tracing goblint-cil fpath yojson - json-data-encoding - cpu goblint_timing - goblint_build_info - goblint.sites qcheck-core.runner) (flags :standard -open Goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson - ppx_blob)) - (preprocessor_deps (file util/options.schema.json))) + ppx_deriving_yojson))) (documentation) diff --git a/src/common/util/afterConfig.ml b/src/config/afterConfig.ml similarity index 100% rename from src/common/util/afterConfig.ml rename to src/config/afterConfig.ml diff --git a/src/config/config.mld b/src/config/config.mld new file mode 100644 index 0000000000..160eaa9a11 --- /dev/null +++ b/src/config/config.mld @@ -0,0 +1,14 @@ +{0 Library goblint.config} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Framework} + +{2 Configuration} +{!modules: +GobConfig +AfterConfig +JsonSchema +Options +} diff --git a/src/config/dune b/src/config/dune new file mode 100644 index 0000000000..b4dfea5c18 --- /dev/null +++ b/src/config/dune @@ -0,0 +1,23 @@ +(include_subdirs unqualified) + +(library + (name goblint_config) + (public_name goblint.config) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_tracing + fpath + yojson + json-data-encoding + cpu + goblint.sites + qcheck-core.runner) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_blob)) + (preprocessor_deps (file options.schema.json))) + +(documentation) diff --git a/src/common/util/gobConfig.ml b/src/config/gobConfig.ml similarity index 100% rename from src/common/util/gobConfig.ml rename to src/config/gobConfig.ml diff --git a/src/common/util/jsonSchema.ml b/src/config/jsonSchema.ml similarity index 100% rename from src/common/util/jsonSchema.ml rename to src/config/jsonSchema.ml diff --git a/src/common/util/options.ml b/src/config/options.ml similarity index 98% rename from src/common/util/options.ml rename to src/config/options.ml index 3046f70809..125da3330b 100644 --- a/src/common/util/options.ml +++ b/src/config/options.ml @@ -1,4 +1,4 @@ -(** [src/common/util/options.schema.json] low-level access. *) +(** [src/config/options.schema.json] low-level access. *) open Json_schema diff --git a/src/common/util/options.schema.json b/src/config/options.schema.json similarity index 100% rename from src/common/util/options.schema.json rename to src/config/options.schema.json diff --git a/src/dune b/src/dune index ffc387447e..6738398e59 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common goblint_domain goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 3c7dcf41a5..fee35c1ec9 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -51,7 +51,7 @@ module VarQuery = VarQuery (** {2 Configuration} Runtime configuration is represented as JSON. - Options are specified and documented by the JSON schema [src/common/util/options.schema.json]. *) + Options are specified and documented by the JSON schema [src/config/options.schema.json]. *) module GobConfig = GobConfig module AfterConfig = AfterConfig diff --git a/src/index.mld b/src/index.mld index bad756a8f1..eb7907f6fe 100644 --- a/src/index.mld +++ b/src/index.mld @@ -7,6 +7,9 @@ The following libraries make up Goblint's main codebase. {!modules:Goblint_lib} This library currently contains the majority of Goblint and is in the process of being split into smaller libraries. +{2 Library goblint.config} +This {{!page-config}unwrapped library} contains various configuration modules extracted from {!Goblint_lib}. + {2 Library goblint.common} This {{!page-common}unwrapped library} contains various common modules extracted from {!Goblint_lib}. From b5f6272dc15df99311ec2ad9d32c69ecf33b70ce Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:18:15 +0200 Subject: [PATCH 162/233] Update Gobview dependencies on Goblint libraries --- gobview | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gobview b/gobview index d4eb66b9eb..3de13d7412 160000 --- a/gobview +++ b/gobview @@ -1 +1 @@ -Subproject commit d4eb66b9eb277349a75141cb01899dbab9d3ef5d +Subproject commit 3de13d74124ab7bc30d8be299f02570d8f498b84 From 036a016d3f1f219fc360fb5ba48e46bfc6f45364 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:33:13 +0200 Subject: [PATCH 163/233] Remove CfgTools dependency on IntDomain via Offset --- src/cdomains/offset.ml | 2 +- src/common/util/cilfacade.ml | 8 +++++++- src/framework/cfgTools.ml | 2 +- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/cdomains/offset.ml b/src/cdomains/offset.ml index eca85e08a4..52cfe9eb41 100644 --- a/src/cdomains/offset.ml +++ b/src/cdomains/offset.ml @@ -22,7 +22,7 @@ struct include CilType.Exp let name () = "exp index" - let any = CastE (TInt (Cilfacade.ptrdiff_ikind (), []), mkString "any_index") + let any = Cilfacade.any_index_exp let all = CastE (TInt (Cilfacade.ptrdiff_ikind (), []), mkString "all_index") (* Override output *) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 26a2f082a4..929dce6c25 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -706,4 +706,10 @@ let add_function_declarations (file: Cil.file): unit = in let fun_decls = List.filter_map declaration_from_GFun functions in let globals = upto_last_type @ fun_decls @ non_types @ functions in - file.globals <- globals \ No newline at end of file + file.globals <- globals + + +(** Special index expression for some unknown index. + Weakly updates array in assignment. + Used for [exp.fast_global_inits]. *) +let any_index_exp = CastE (TInt (ptrdiff_ikind (), []), mkString "any_index") diff --git a/src/framework/cfgTools.ml b/src/framework/cfgTools.ml index 8f98a48e84..af887da432 100644 --- a/src/framework/cfgTools.ml +++ b/src/framework/cfgTools.ml @@ -685,7 +685,7 @@ let getGlobalInits (file: file) : edges = lval in let rec any_index_offset = function - | Index (e,o) -> Index (Offset.Index.Exp.any, any_index_offset o) + | Index (e,o) -> Index (Cilfacade.any_index_exp, any_index_offset o) | Field (f,o) -> Field (f, any_index_offset o) | NoOffset -> NoOffset in From dbec9e8df27b1b12f8c2bfae3ebf032686a8c483 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:38:03 +0200 Subject: [PATCH 164/233] Remove CompareCFG dependency on CfgTools --- src/common/util/cilfacade.ml | 6 ++++++ src/framework/cfgTools.ml | 6 +----- src/framework/constraints.ml | 2 +- src/incremental/compareCFG.ml | 2 +- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 929dce6c25..0fb9bd32b5 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -531,6 +531,12 @@ let stmt_fundecs: fundec StmtH.t ResettableLazy.t = h ) + +let get_pseudo_return_id fd = + let start_id = 10_000_000_000 in (* TODO get max_sid? *) + let sid = Hashtbl.hash fd.svar.vid in (* Need pure sid instead of Cil.new_sid for incremental, similar to vid in Cilfacade.create_var. We only add one return stmt per loop, so the hash from the functions vid should be unique. *) + if sid < start_id then sid + start_id else sid + let pseudo_return_to_fun = StmtH.create 113 (** Find [fundec] which the [stmt] is in. *) diff --git a/src/framework/cfgTools.ml b/src/framework/cfgTools.ml index af887da432..1afdb69514 100644 --- a/src/framework/cfgTools.ml +++ b/src/framework/cfgTools.ml @@ -122,10 +122,6 @@ let rec pretty_edges () = function | [_,x] -> Edge.pretty_plain () x | (_,x)::xs -> Pretty.dprintf "%a; %a" Edge.pretty_plain x pretty_edges xs -let get_pseudo_return_id fd = - let start_id = 10_000_000_000 in (* TODO get max_sid? *) - let sid = Hashtbl.hash fd.svar.vid in (* Need pure sid instead of Cil.new_sid for incremental, similar to vid in Cilfacade.create_var. We only add one return stmt per loop, so the hash from the functions vid should be unique. *) - if sid < start_id then sid + start_id else sid let node_scc_global = NH.create 113 @@ -260,7 +256,7 @@ let createCFG (file: file) = if Messages.tracing then Messages.trace "cfg" "adding pseudo-return to the function %s.\n" fd.svar.vname; let fd_end_loc = {fd_loc with line = fd_loc.endLine; byte = fd_loc.endByte; column = fd_loc.endColumn} in let newst = mkStmt (Return (None, fd_end_loc)) in - newst.sid <- get_pseudo_return_id fd; + newst.sid <- Cilfacade.get_pseudo_return_id fd; Cilfacade.StmtH.add Cilfacade.pseudo_return_to_fun newst fd; Cilfacade.IntH.replace Cilfacade.pseudo_return_stmt_sids newst.sid newst; let newst_node = Statement newst in diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index bdb4370b39..77d3a38186 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1004,7 +1004,7 @@ struct let dummy_pseudo_return_node f = (* not the same as in CFG, but compares equal because of sid *) - Node.Statement ({Cil.dummyStmt with sid = CfgTools.get_pseudo_return_id f}) + Node.Statement ({Cil.dummyStmt with sid = Cilfacade.get_pseudo_return_id f}) in let add_nodes_of_fun (functions: fundec list) (withEntry: fundec -> bool) = let add_stmts (f: fundec) = diff --git a/src/incremental/compareCFG.ml b/src/incremental/compareCFG.ml index 225cbb1c76..55b3fa8fc5 100644 --- a/src/incremental/compareCFG.ml +++ b/src/incremental/compareCFG.ml @@ -17,7 +17,7 @@ let (&&<>) (prev_result: bool * rename_mapping) f : bool * rename_mapping = let eq_node (x, fun1) (y, fun2) ~rename_mapping = let isPseudoReturn f sid = - let pid = CfgTools.get_pseudo_return_id f in + let pid = Cilfacade.get_pseudo_return_id f in sid == pid in match x,y with | Statement s1, Statement s2 -> From 3dd355154a57853a477e0726daf393fee2d21e55 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:43:16 +0200 Subject: [PATCH 165/233] Move CfgTools to goblint_common --- src/common/common.mld | 1 + src/{ => common}/framework/cfgTools.ml | 0 2 files changed, 1 insertion(+) rename src/{ => common}/framework/cfgTools.ml (100%) diff --git a/src/common/common.mld b/src/common/common.mld index a1cc9a261a..2ad88c3758 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -10,6 +10,7 @@ For better context, see {!Goblint_lib} which also documents these modules. Node Edge MyCFG +CfgTools } {2 Specification} diff --git a/src/framework/cfgTools.ml b/src/common/framework/cfgTools.ml similarity index 100% rename from src/framework/cfgTools.ml rename to src/common/framework/cfgTools.ml From deb727b36cc59ecb946208d1d0fac439085d05a1 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 17:49:03 +0200 Subject: [PATCH 166/233] Extract incremental to goblint_incremental dune library --- src/dune | 2 +- src/{util => incremental}/cilMaps.ml | 0 src/incremental/dune | 22 ++++++++++++++++++++++ src/incremental/incremental.mld | 16 ++++++++++++++++ src/index.mld | 3 +++ 5 files changed, 42 insertions(+), 1 deletion(-) rename src/{util => incremental}/cilMaps.ml (100%) create mode 100644 src/incremental/dune create mode 100644 src/incremental/incremental.mld diff --git a/src/dune b/src/dune index 6738398e59..e40a58fcbd 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/util/cilMaps.ml b/src/incremental/cilMaps.ml similarity index 100% rename from src/util/cilMaps.ml rename to src/incremental/cilMaps.ml diff --git a/src/incremental/dune b/src/incremental/dune new file mode 100644 index 0000000000..a664c78ea7 --- /dev/null +++ b/src/incremental/dune @@ -0,0 +1,22 @@ +(include_subdirs unqualified) + +(library + (name goblint_incremental) + (public_name goblint.incremental) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + zarith + goblint_std + goblint_config + goblint_common + goblint-cil + fpath) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson))) + +(documentation) diff --git a/src/incremental/incremental.mld b/src/incremental/incremental.mld new file mode 100644 index 0000000000..bf9b6e6a58 --- /dev/null +++ b/src/incremental/incremental.mld @@ -0,0 +1,16 @@ +{0 Library goblint.incremental} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Incremental} + +{!modules: +CompareCIL +CompareAST +CompareCFG +UpdateCil +MaxIdUtil +Serialize +CilMaps +} diff --git a/src/index.mld b/src/index.mld index eb7907f6fe..755a736e6c 100644 --- a/src/index.mld +++ b/src/index.mld @@ -16,6 +16,9 @@ This {{!page-common}unwrapped library} contains various common modules extracted {2 Library goblint.domain} This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. +{2 Library goblint.incremental} +This {{!page-incremental}unwrapped library} contains various incremental modules extracted from {!Goblint_lib}. + {1 Library extensions} The following libraries provide extensions to other OCaml libraries. From 9261b71573b38f8b9e56d9121a9b1025325a13ec Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 7 Dec 2023 10:53:43 +0200 Subject: [PATCH 167/233] Extract library specificaton to goblint_library dune library --- src/dune | 2 +- src/index.mld | 3 +++ src/{domains => util/library}/accessKind.ml | 0 src/util/library/dune | 18 ++++++++++++++++++ src/util/library/library.mld | 14 ++++++++++++++ src/{analyses => util/library}/libraryDesc.ml | 0 src/{analyses => util/library}/libraryDsl.ml | 0 src/{analyses => util/library}/libraryDsl.mli | 0 .../library}/libraryFunctions.ml | 0 .../library}/libraryFunctions.mli | 0 10 files changed, 36 insertions(+), 1 deletion(-) rename src/{domains => util/library}/accessKind.ml (100%) create mode 100644 src/util/library/dune create mode 100644 src/util/library/library.mld rename src/{analyses => util/library}/libraryDesc.ml (100%) rename src/{analyses => util/library}/libraryDsl.ml (100%) rename src/{analyses => util/library}/libraryDsl.mli (100%) rename src/{analyses => util/library}/libraryFunctions.ml (100%) rename src/{analyses => util/library}/libraryFunctions.mli (100%) diff --git a/src/dune b/src/dune index e40a58fcbd..8ad1b3aa4c 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_incremental goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_library goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/index.mld b/src/index.mld index 755a736e6c..76b9d230dd 100644 --- a/src/index.mld +++ b/src/index.mld @@ -16,6 +16,9 @@ This {{!page-common}unwrapped library} contains various common modules extracted {2 Library goblint.domain} This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. +{2 Library goblint.library} +This {{!page-library}unwrapped library} contains various library specification modules extracted from {!Goblint_lib}. + {2 Library goblint.incremental} This {{!page-incremental}unwrapped library} contains various incremental modules extracted from {!Goblint_lib}. diff --git a/src/domains/accessKind.ml b/src/util/library/accessKind.ml similarity index 100% rename from src/domains/accessKind.ml rename to src/util/library/accessKind.ml diff --git a/src/util/library/dune b/src/util/library/dune new file mode 100644 index 0000000000..075c01c35d --- /dev/null +++ b/src/util/library/dune @@ -0,0 +1,18 @@ +(include_subdirs no) + +(library + (name goblint_library) + (public_name goblint.library) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_common + goblint_domain + goblint_config + goblint-cil) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash))) + +(documentation) diff --git a/src/util/library/library.mld b/src/util/library/library.mld new file mode 100644 index 0000000000..f55db3f2ff --- /dev/null +++ b/src/util/library/library.mld @@ -0,0 +1,14 @@ +{0 Library goblint.library} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Utilities} + +{2 Library specification} +{!modules: +AccessKind +LibraryDesc +LibraryDsl +LibraryFunctions +} diff --git a/src/analyses/libraryDesc.ml b/src/util/library/libraryDesc.ml similarity index 100% rename from src/analyses/libraryDesc.ml rename to src/util/library/libraryDesc.ml diff --git a/src/analyses/libraryDsl.ml b/src/util/library/libraryDsl.ml similarity index 100% rename from src/analyses/libraryDsl.ml rename to src/util/library/libraryDsl.ml diff --git a/src/analyses/libraryDsl.mli b/src/util/library/libraryDsl.mli similarity index 100% rename from src/analyses/libraryDsl.mli rename to src/util/library/libraryDsl.mli diff --git a/src/analyses/libraryFunctions.ml b/src/util/library/libraryFunctions.ml similarity index 100% rename from src/analyses/libraryFunctions.ml rename to src/util/library/libraryFunctions.ml diff --git a/src/analyses/libraryFunctions.mli b/src/util/library/libraryFunctions.mli similarity index 100% rename from src/analyses/libraryFunctions.mli rename to src/util/library/libraryFunctions.mli From 5662024232f32fe74dd25c9317dee4436ecb212d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 7 Dec 2023 11:07:00 +0200 Subject: [PATCH 168/233] Fix LibraryFunctions.invalidate_actions indentation --- src/util/library/libraryFunctions.ml | 164 +++++++++++++-------------- 1 file changed, 82 insertions(+), 82 deletions(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index 8152e5b886..2c65f7ae61 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -1233,88 +1233,88 @@ open Invalidate * We assume that no known functions that are reachable are executed/spawned. For that we use ThreadCreate above. *) (* WTF: why are argument numbers 1-indexed (in partition)? *) let invalidate_actions = [ - "__printf_chk", readsAll;(*safe*) - "printk", readsAll;(*safe*) - "__mutex_init", readsAll;(*safe*) - "__builtin___snprintf_chk", writes [1];(*keep [1]*) - "__vfprintf_chk", writes [1];(*keep [1]*) - "__builtin_va_arg", readsAll;(*safe*) - "__builtin_va_end", readsAll;(*safe*) - "__builtin_va_start", readsAll;(*safe*) - "__ctype_b_loc", readsAll;(*safe*) - "__errno", readsAll;(*safe*) - "__errno_location", readsAll;(*safe*) - "__strdup", readsAll;(*safe*) - "strtoul__extinline", readsAll;(*safe*) - "readdir_r", writesAll;(*unsafe*) - "atoi__extinline", readsAll;(*safe*) - "_IO_getc", writesAll;(*unsafe*) - "pipe", writesAll;(*unsafe*) - "strerror_r", writesAll;(*unsafe*) - "raise", writesAll;(*unsafe*) - "_strlen", readsAll;(*safe*) - "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) - "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) - "waitpid", readsAll;(*safe*) - "__open_alias", readsAll;(*safe*) - "__open_2", readsAll;(*safe*) - "ioctl", writesAll;(*unsafe*) - "fstat__extinline", writesAll;(*unsafe*) - "scandir", writes [1;3;4];(*keep [1;3;4]*) - "bindtextdomain", readsAll;(*safe*) - "textdomain", readsAll;(*safe*) - "dcgettext", readsAll;(*safe*) - "putw", readsAll;(*safe*) - "__getdelim", writes [3];(*keep [3]*) - "__h_errno_location", readsAll;(*safe*) - "__fxstat", readsAll;(*safe*) - "openlog", readsAll;(*safe*) - "umask", readsAll;(*safe*) - "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) - "svctcp_create", readsAll;(*safe*) - "clntudp_bufcreate", writesAll;(*unsafe*) - "authunix_create_default", readsAll;(*safe*) - "clnt_broadcast", writesAll;(*unsafe*) - "clnt_sperrno", readsAll;(*safe*) - "pmap_unset", writesAll;(*unsafe*) - "svcudp_create", readsAll;(*safe*) - "svc_register", writesAll;(*unsafe*) - "svc_run", writesAll;(*unsafe*) - "dup", readsAll; (*safe*) - "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) - "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) - "__error", readsAll; (*safe*) - "__maskrune", writesAll; (*unsafe*) - "times", writesAll; (*unsafe*) - "timespec_get", writes [1]; - "__tolower", readsAll; (*safe*) - "signal", writesAll; (*unsafe*) - "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) - "BZ2_bzBuffToBuffDecompress", writes [3;4]; (*keep [3;4]*) - "uncompress", writes [3;4]; (*keep [3;4]*) - "__xstat", writes [3]; (*keep [1]*) - "__lxstat", writes [3]; (*keep [1]*) - "remove", readsAll; - "BZ2_bzBuffToBuffCompress", writes [3;4]; (*keep [3;4]*) - "compress2", writes [3]; (*keep [3]*) - "__toupper", readsAll; (*safe*) - "BF_set_key", writes [3]; (*keep [3]*) - "PL_NewHashTable", readsAll; (*safe*) - "assert_failed", readsAll; (*safe*) - "munmap", readsAll;(*safe*) - "mmap", readsAll;(*safe*) - "__builtin_va_arg_pack_len", readsAll; - "__open_too_many_args", readsAll; - "usb_submit_urb", readsAll; (* first argument is written to but according to specification must not be read from anymore *) - "dev_driver_string", readsAll; - "__spin_lock_init", writes [1]; - "kmem_cache_create", readsAll; - "idr_pre_get", readsAll; - "zil_replay", writes [1;2;3;5]; - (* ddverify *) - "sema_init", readsAll; - "__goblint_assume_join", readsAll; - ] + "__printf_chk", readsAll;(*safe*) + "printk", readsAll;(*safe*) + "__mutex_init", readsAll;(*safe*) + "__builtin___snprintf_chk", writes [1];(*keep [1]*) + "__vfprintf_chk", writes [1];(*keep [1]*) + "__builtin_va_arg", readsAll;(*safe*) + "__builtin_va_end", readsAll;(*safe*) + "__builtin_va_start", readsAll;(*safe*) + "__ctype_b_loc", readsAll;(*safe*) + "__errno", readsAll;(*safe*) + "__errno_location", readsAll;(*safe*) + "__strdup", readsAll;(*safe*) + "strtoul__extinline", readsAll;(*safe*) + "readdir_r", writesAll;(*unsafe*) + "atoi__extinline", readsAll;(*safe*) + "_IO_getc", writesAll;(*unsafe*) + "pipe", writesAll;(*unsafe*) + "strerror_r", writesAll;(*unsafe*) + "raise", writesAll;(*unsafe*) + "_strlen", readsAll;(*safe*) + "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) + "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) + "waitpid", readsAll;(*safe*) + "__open_alias", readsAll;(*safe*) + "__open_2", readsAll;(*safe*) + "ioctl", writesAll;(*unsafe*) + "fstat__extinline", writesAll;(*unsafe*) + "scandir", writes [1;3;4];(*keep [1;3;4]*) + "bindtextdomain", readsAll;(*safe*) + "textdomain", readsAll;(*safe*) + "dcgettext", readsAll;(*safe*) + "putw", readsAll;(*safe*) + "__getdelim", writes [3];(*keep [3]*) + "__h_errno_location", readsAll;(*safe*) + "__fxstat", readsAll;(*safe*) + "openlog", readsAll;(*safe*) + "umask", readsAll;(*safe*) + "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) + "svctcp_create", readsAll;(*safe*) + "clntudp_bufcreate", writesAll;(*unsafe*) + "authunix_create_default", readsAll;(*safe*) + "clnt_broadcast", writesAll;(*unsafe*) + "clnt_sperrno", readsAll;(*safe*) + "pmap_unset", writesAll;(*unsafe*) + "svcudp_create", readsAll;(*safe*) + "svc_register", writesAll;(*unsafe*) + "svc_run", writesAll;(*unsafe*) + "dup", readsAll; (*safe*) + "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) + "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) + "__error", readsAll; (*safe*) + "__maskrune", writesAll; (*unsafe*) + "times", writesAll; (*unsafe*) + "timespec_get", writes [1]; + "__tolower", readsAll; (*safe*) + "signal", writesAll; (*unsafe*) + "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) + "BZ2_bzBuffToBuffDecompress", writes [3;4]; (*keep [3;4]*) + "uncompress", writes [3;4]; (*keep [3;4]*) + "__xstat", writes [3]; (*keep [1]*) + "__lxstat", writes [3]; (*keep [1]*) + "remove", readsAll; + "BZ2_bzBuffToBuffCompress", writes [3;4]; (*keep [3;4]*) + "compress2", writes [3]; (*keep [3]*) + "__toupper", readsAll; (*safe*) + "BF_set_key", writes [3]; (*keep [3]*) + "PL_NewHashTable", readsAll; (*safe*) + "assert_failed", readsAll; (*safe*) + "munmap", readsAll;(*safe*) + "mmap", readsAll;(*safe*) + "__builtin_va_arg_pack_len", readsAll; + "__open_too_many_args", readsAll; + "usb_submit_urb", readsAll; (* first argument is written to but according to specification must not be read from anymore *) + "dev_driver_string", readsAll; + "__spin_lock_init", writes [1]; + "kmem_cache_create", readsAll; + "idr_pre_get", readsAll; + "zil_replay", writes [1;2;3;5]; + (* ddverify *) + "sema_init", readsAll; + "__goblint_assume_join", readsAll; +] let invalidate_actions = let tbl = Hashtbl.create 113 in From a6095e7d3990dc518d3f7f14dbae6dc9ed8ddb8d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 7 Dec 2023 12:09:00 +0200 Subject: [PATCH 169/233] Use (include_subdirs no) for new dune libraries --- src/config/dune | 2 +- src/domain/dune | 2 +- src/incremental/dune | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/config/dune b/src/config/dune index b4dfea5c18..1508e2553e 100644 --- a/src/config/dune +++ b/src/config/dune @@ -1,4 +1,4 @@ -(include_subdirs unqualified) +(include_subdirs no) (library (name goblint_config) diff --git a/src/domain/dune b/src/domain/dune index 45345b5946..169f4a1d5c 100644 --- a/src/domain/dune +++ b/src/domain/dune @@ -1,4 +1,4 @@ -(include_subdirs unqualified) +(include_subdirs no) (library (name goblint_domain) diff --git a/src/incremental/dune b/src/incremental/dune index a664c78ea7..595dba22f7 100644 --- a/src/incremental/dune +++ b/src/incremental/dune @@ -1,4 +1,4 @@ -(include_subdirs unqualified) +(include_subdirs no) (library (name goblint_incremental) From 029c1e93daa47624cce2dd94d4ed2c600ed1cc07 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 7 Dec 2023 11:22:05 +0100 Subject: [PATCH 170/233] Add newline back for ocamldoc Co-authored-by: Simmo Saan --- src/cdomains/apron/relationDomain.apron.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomains/apron/relationDomain.apron.ml b/src/cdomains/apron/relationDomain.apron.ml index aca2346820..48720b0382 100644 --- a/src/cdomains/apron/relationDomain.apron.ml +++ b/src/cdomains/apron/relationDomain.apron.ml @@ -1,6 +1,7 @@ (** Signatures for relational value domains. See {!ApronDomain} and {!AffineEqualityDomain}. *) + open GobApron open Batteries open GoblintCil From 4fae8c62af777b3199cd63525cb88ae212206d8e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 7 Dec 2023 11:22:34 +0100 Subject: [PATCH 171/233] Directly use `Apron.Var.t` Co-authored-by: Simmo Saan --- src/analyses/apron/apronAnalysis.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/apron/apronAnalysis.apron.ml b/src/analyses/apron/apronAnalysis.apron.ml index 72dc81c121..0ba17cdb35 100644 --- a/src/analyses/apron/apronAnalysis.apron.ml +++ b/src/analyses/apron/apronAnalysis.apron.ml @@ -14,7 +14,7 @@ let spec_module: (module MCPSpec) Lazy.t = struct module V = ApronDomain.V include AD - type var = GobApron.Var.t + type var = Apron.Var.t end in let module Priv = (val RelationPriv.get_priv ()) in From 5f5c1c8cd90b4b3811e37ce46286698dfa103a65 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 7 Dec 2023 11:22:44 +0100 Subject: [PATCH 172/233] Directly use `Apron.Var.t` Co-authored-by: Simmo Saan --- src/analyses/apron/relationAnalysis.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index b401b58e93..b794c4d70b 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -285,7 +285,7 @@ struct (* there should be smarter ways to do this, e.g. by keeping track of which values are written etc. ... *) (* See, e.g, Beckschulze E, Kowalewski S, Brauer J (2012) Access-based localization for octagons. Electron Notes Theor Comput Sci 287:29–40 *) (* Also, a local *) - let vname = GobApron.Var.to_string var in + let vname = Apron.Var.to_string var in let locals = fundec.sformals @ fundec.slocals in match List.find_opt (fun v -> VM.var_name (Local v) = vname) locals with (* TODO: optimize *) | None -> true From 129b9c3538c84d72cf70099d367766ececb89cd8 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 7 Dec 2023 17:24:31 +0100 Subject: [PATCH 173/233] Switch `GobApron.Var` to `Apron.Var` --- src/analyses/apron/relationAnalysis.apron.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index b794c4d70b..5e128ffc30 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -318,7 +318,7 @@ struct RD.remove_filter_with new_rel (fun var -> match RV.find_metadata var with | Some (Local _) when not (pass_to_callee fundec any_local_reachable var) -> true (* remove caller locals provided they are unreachable *) - | Some (Arg _) when not (List.mem_cmp GobApron.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) + | Some (Arg _) when not (List.mem_cmp Apron.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) | _ -> false (* keep everything else (just added args, globals, global privs) *) ); if M.tracing then M.tracel "combine" "relation enter newd: %a\n" RD.pretty new_rel; @@ -404,7 +404,7 @@ struct in let any_local_reachable = any_local_reachable fundec reachable_from_args in let arg_vars = f.sformals |> List.filter (RD.Tracked.varinfo_tracked) |> List.map RV.arg in - if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (GobApron.Var.to_string v))) arg_vars; + if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (Apron.Var.to_string v))) arg_vars; RD.remove_vars_with new_fun_rel arg_vars; (* fine to remove arg vars that also exist in caller because unify from new_rel adds them back with proper constraints *) let tainted = f_ask.f Queries.MayBeTainted in let tainted_vars = TaintPartialContexts.conv_varset tainted in From c2e0e169bbc132a401795f781691e257ec2df62a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 7 Dec 2023 20:09:23 +0100 Subject: [PATCH 174/233] Add `GobApron` to goblint_lib.ml #1283 --- src/goblint_lib.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index cdb37b1256..08691fa273 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -441,6 +441,7 @@ module WideningThresholds = WideningThresholds module VectorMatrix = VectorMatrix module SharedFunctions = SharedFunctions +module GobApron = GobApron (** {2 Precision comparison} *) From fd0d9ff2e904b7ea1bcddd673c953d1153125e84 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 8 Dec 2023 10:25:59 +0200 Subject: [PATCH 175/233] Add TODOs (PR #1288) --- src/common/util/cilfacade.ml | 2 +- src/domain/mapDomain.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 0fb9bd32b5..eff97da404 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -718,4 +718,4 @@ let add_function_declarations (file: Cil.file): unit = (** Special index expression for some unknown index. Weakly updates array in assignment. Used for [exp.fast_global_inits]. *) -let any_index_exp = CastE (TInt (ptrdiff_ikind (), []), mkString "any_index") +let any_index_exp = CastE (TInt (ptrdiff_ikind (), []), mkString "any_index") (* TODO: move back to Offset *) diff --git a/src/domain/mapDomain.ml b/src/domain/mapDomain.ml index 4972da7d26..9013b036e5 100644 --- a/src/domain/mapDomain.ml +++ b/src/domain/mapDomain.ml @@ -259,6 +259,7 @@ struct end (* TODO: this is very slow because every add/remove in a fold-loop relifts *) +(* TODO: currently hardcoded to assume_idempotent *) module HConsed (M: S) : S with type key = M.key and type value = M.value = From 54bcf607850d2e8c4dc21310abbba0a32c8959d5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 8 Dec 2023 10:52:39 +0200 Subject: [PATCH 176/233] Add TODO about shallow ThreadJoin invalidate --- src/analyses/base.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 2e0002dd55..078799bea6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2397,6 +2397,7 @@ struct (* handling thread joins... sort of *) | ThreadJoin { thread = id; ret_var }, _ -> let st' = + (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) match (eval_rv (Analyses.ask_of_ctx ctx) gs st ret_var) with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> From 3b82569d92be73112cfbe4677ec5e35f2ad7ed2b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 8 Dec 2023 10:54:47 +0200 Subject: [PATCH 177/233] Ignore Goblint_tracing in Goblint_lib modules check --- scripts/goblint-lib-modules.py | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 6c264a117b..ec0e78e440 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -35,6 +35,7 @@ "Goblint_std", "Goblint_timing", "Goblint_backtrace", + "Goblint_tracing", "Goblint_sites", "Goblint_build_info", "Dune_build_info", From cb908119d50ad31b1d846bac1de3b759fc7f5427 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 8 Dec 2023 10:57:30 +0200 Subject: [PATCH 178/233] Fix indentation in goblint_domain --- src/domain/boolDomain.ml | 8 ++++---- src/domain/hoareDomain.ml | 22 ++++++++++++---------- src/domain/mapDomain.ml | 4 ++-- 3 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/domain/boolDomain.ml b/src/domain/boolDomain.ml index 43e15e1405..08be66a602 100644 --- a/src/domain/boolDomain.ml +++ b/src/domain/boolDomain.ml @@ -4,10 +4,10 @@ module Bool = struct include Basetype.RawBools (* type t = bool - let equal = Bool.equal - let compare = Bool.compare - let relift x = x - let arbitrary () = QCheck.bool *) + let equal = Bool.equal + let compare = Bool.compare + let relift x = x + let arbitrary () = QCheck.bool *) let pretty_diff () (x,y) = GoblintCil.Pretty.dprintf "%s: %a not leq %a" (name ()) pretty x pretty y end diff --git a/src/domain/hoareDomain.ml b/src/domain/hoareDomain.ml index 23b1a92240..37b8231b92 100644 --- a/src/domain/hoareDomain.ml +++ b/src/domain/hoareDomain.ml @@ -134,13 +134,15 @@ struct let equal x y = leq x y && leq y x let hash xs = fold (fun v a -> a + E.hash v) xs 0 let compare x y = - if equal x y - then 0 + if equal x y then + 0 + else ( + let caridnality_comp = compare (cardinal x) (cardinal y) in + if caridnality_comp <> 0 then + caridnality_comp else - let caridnality_comp = compare (cardinal x) (cardinal y) in - if caridnality_comp <> 0 - then caridnality_comp - else Map.compare (List.compare E.compare) x y + Map.compare (List.compare E.compare) x y + ) let show x : string = let all_elems : string list = List.map E.show (elements x) in Printable.get_short_list "{" "}" all_elems @@ -234,8 +236,8 @@ struct ) s2 nil with Not_found -> dprintf "choose failed b/c of empty set s1: %d s2: %d" - (cardinal s1) - (cardinal s2) + (cardinal s1) + (cardinal s2) end end @@ -339,8 +341,8 @@ struct ) s2 nil with Not_found -> dprintf "choose failed b/c of empty set s1: %d s2: %d" - (cardinal s1) - (cardinal s2) + (cardinal s1) + (cardinal s2) end end [@@deprecated] diff --git a/src/domain/mapDomain.ml b/src/domain/mapDomain.ml index 9013b036e5..740da9969e 100644 --- a/src/domain/mapDomain.ml +++ b/src/domain/mapDomain.ml @@ -718,8 +718,8 @@ struct let singleton k v = `Lifted (M.singleton k v) let empty () = `Lifted (M.empty ()) let is_empty = function - | `Bot -> false - | `Lifted x -> M.is_empty x + | `Bot -> false + | `Lifted x -> M.is_empty x let exists f = function | `Bot -> raise (Fn_over_All "exists") | `Lifted x -> M.exists f x From a432e47951b2c54660e23e6356917ef259d965e9 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 8 Dec 2023 19:46:59 +0100 Subject: [PATCH 179/233] Port 6 specs --- src/util/library/libraryFunctions.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index 2c65f7ae61..d91ee61d12 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -159,6 +159,8 @@ let c_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("wscanf", unknown (drop "fmt" [r] :: VarArgs (drop' [w]))); ("fwscanf", unknown (drop "stream" [r_deep; w_deep] :: drop "fmt" [r] :: VarArgs (drop' [w]))); ("swscanf", unknown (drop "buffer" [r] :: drop "fmt" [r] :: VarArgs (drop' [w]))); + ("remove", unknown [drop "pathname" [r]]); + ("raise", unknown [drop "sig" []]); (* safe-ish, we don't handle signal handlers for now *) ] (** C POSIX library functions. @@ -418,6 +420,10 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("random", special [] Rand); ("posix_memalign", unknown [drop "memptr" [w]; drop "alignment" []; drop "size" []]); (* TODO: Malloc *) ("stpcpy", unknown [drop "dest" [w]; drop "src" [r]]); + ("dup", unknown [drop "oldfd" []]); + ("readdir_r", unknown [drop "dirp" [r_deep]; drop "entry" [r_deep]; drop "result" [w]]); + ("pipe", unknown [drop "pipefd" [w_deep]]); + ("waitpid", unknown [drop "pid" []; drop "wstatus" [w]; drop "options" []]); ] (** Pthread functions. *) @@ -1246,16 +1252,12 @@ let invalidate_actions = [ "__errno_location", readsAll;(*safe*) "__strdup", readsAll;(*safe*) "strtoul__extinline", readsAll;(*safe*) - "readdir_r", writesAll;(*unsafe*) "atoi__extinline", readsAll;(*safe*) "_IO_getc", writesAll;(*unsafe*) - "pipe", writesAll;(*unsafe*) "strerror_r", writesAll;(*unsafe*) - "raise", writesAll;(*unsafe*) "_strlen", readsAll;(*safe*) "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) - "waitpid", readsAll;(*safe*) "__open_alias", readsAll;(*safe*) "__open_2", readsAll;(*safe*) "ioctl", writesAll;(*unsafe*) @@ -1280,7 +1282,6 @@ let invalidate_actions = [ "svcudp_create", readsAll;(*safe*) "svc_register", writesAll;(*unsafe*) "svc_run", writesAll;(*unsafe*) - "dup", readsAll; (*safe*) "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) "__error", readsAll; (*safe*) @@ -1294,7 +1295,6 @@ let invalidate_actions = [ "uncompress", writes [3;4]; (*keep [3;4]*) "__xstat", writes [3]; (*keep [1]*) "__lxstat", writes [3]; (*keep [1]*) - "remove", readsAll; "BZ2_bzBuffToBuffCompress", writes [3;4]; (*keep [3;4]*) "compress2", writes [3]; (*keep [3]*) "__toupper", readsAll; (*safe*) From 1823684fa70be0993a62363f7285840e6396c552 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 8 Dec 2023 20:12:48 +0100 Subject: [PATCH 180/233] Port 5 specs --- src/util/library/libraryFunctions.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index d91ee61d12..4866f2aa17 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -424,6 +424,9 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("readdir_r", unknown [drop "dirp" [r_deep]; drop "entry" [r_deep]; drop "result" [w]]); ("pipe", unknown [drop "pipefd" [w_deep]]); ("waitpid", unknown [drop "pid" []; drop "wstatus" [w]; drop "options" []]); + ("strerror_r", unknown [drop "errnum" []; drop "buff" [w]; drop "buflen" []]); + ("umask", unknown [drop "mask" []]); + ("openlog", unknown [drop "ident" [r]; drop "option" []; drop "facility" []]); ] (** Pthread functions. *) @@ -644,6 +647,7 @@ let glibc_desc_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("strchrnul", unknown [drop "s" [r]; drop "c" []]); ("getdtablesize", unknown []); ("daemon", unknown [drop "nochdir" []; drop "noclose" []]); + ("putw", unknown [drop "w" []; drop "stream" [r_deep; w_deep]]); ] let linux_userspace_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ @@ -741,6 +745,7 @@ let linux_kernel_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("__kmalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Malloc size); ("kzalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Calloc {count = Cil.one; size}); ("usb_alloc_urb", special [__ "iso_packets" []; drop "mem_flags" []] @@ fun iso_packets -> Malloc MyCFG.unknown_exp); + ("ioctl", unknown (drop "fd" [] :: drop "request" [] :: VarArgs (drop' [r]))); ] (** Goblint functions. *) @@ -1254,24 +1259,19 @@ let invalidate_actions = [ "strtoul__extinline", readsAll;(*safe*) "atoi__extinline", readsAll;(*safe*) "_IO_getc", writesAll;(*unsafe*) - "strerror_r", writesAll;(*unsafe*) "_strlen", readsAll;(*safe*) "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) "__open_alias", readsAll;(*safe*) "__open_2", readsAll;(*safe*) - "ioctl", writesAll;(*unsafe*) "fstat__extinline", writesAll;(*unsafe*) "scandir", writes [1;3;4];(*keep [1;3;4]*) "bindtextdomain", readsAll;(*safe*) "textdomain", readsAll;(*safe*) "dcgettext", readsAll;(*safe*) - "putw", readsAll;(*safe*) "__getdelim", writes [3];(*keep [3]*) "__h_errno_location", readsAll;(*safe*) "__fxstat", readsAll;(*safe*) - "openlog", readsAll;(*safe*) - "umask", readsAll;(*safe*) "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) "svctcp_create", readsAll;(*safe*) "clntudp_bufcreate", writesAll;(*unsafe*) From 7d50626caa4883cbcb625a41016cbca7cf166941 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 8 Dec 2023 20:20:07 +0100 Subject: [PATCH 181/233] Port 2 more specs --- src/util/library/libraryFunctions.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index 4866f2aa17..bb2b89c364 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -161,6 +161,7 @@ let c_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("swscanf", unknown (drop "buffer" [r] :: drop "fmt" [r] :: VarArgs (drop' [w]))); ("remove", unknown [drop "pathname" [r]]); ("raise", unknown [drop "sig" []]); (* safe-ish, we don't handle signal handlers for now *) + ("timespec_get", unknown [drop "ts" [w]; drop "base" []]); ] (** C POSIX library functions. @@ -427,6 +428,7 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("strerror_r", unknown [drop "errnum" []; drop "buff" [w]; drop "buflen" []]); ("umask", unknown [drop "mask" []]); ("openlog", unknown [drop "ident" [r]; drop "option" []; drop "facility" []]); + ("times", unknown [drop "buf" [w]]) ] (** Pthread functions. *) @@ -1272,6 +1274,7 @@ let invalidate_actions = [ "__getdelim", writes [3];(*keep [3]*) "__h_errno_location", readsAll;(*safe*) "__fxstat", readsAll;(*safe*) + (* RPC library start *) "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) "svctcp_create", readsAll;(*safe*) "clntudp_bufcreate", writesAll;(*unsafe*) @@ -1282,12 +1285,11 @@ let invalidate_actions = [ "svcudp_create", readsAll;(*safe*) "svc_register", writesAll;(*unsafe*) "svc_run", writesAll;(*unsafe*) + (* RPC library end *) "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) "__error", readsAll; (*safe*) "__maskrune", writesAll; (*unsafe*) - "times", writesAll; (*unsafe*) - "timespec_get", writes [1]; "__tolower", readsAll; (*safe*) "signal", writesAll; (*unsafe*) "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) From 80b4f825d00cca340ebe8fb44784a76ca67c276e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 8 Dec 2023 20:27:07 +0100 Subject: [PATCH 182/233] Port 3 more specs --- src/util/library/libraryFunctions.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index bb2b89c364..ee8d58d886 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -162,6 +162,7 @@ let c_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("remove", unknown [drop "pathname" [r]]); ("raise", unknown [drop "sig" []]); (* safe-ish, we don't handle signal handlers for now *) ("timespec_get", unknown [drop "ts" [w]; drop "base" []]); + ("signal", unknown [drop "signum" []; drop "handler" [s]]); ] (** C POSIX library functions. @@ -428,7 +429,9 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("strerror_r", unknown [drop "errnum" []; drop "buff" [w]; drop "buflen" []]); ("umask", unknown [drop "mask" []]); ("openlog", unknown [drop "ident" [r]; drop "option" []; drop "facility" []]); - ("times", unknown [drop "buf" [w]]) + ("times", unknown [drop "buf" [w]]); + ("mmap", unknown [drop "addr" []; drop "length" []; drop "prot" []; drop "flags" []; drop "fd" []; drop "offset" []]); + ("munmap", unknown [drop "addr" []; drop "length" []]); ] (** Pthread functions. *) @@ -1291,7 +1294,6 @@ let invalidate_actions = [ "__error", readsAll; (*safe*) "__maskrune", writesAll; (*unsafe*) "__tolower", readsAll; (*safe*) - "signal", writesAll; (*unsafe*) "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) "BZ2_bzBuffToBuffDecompress", writes [3;4]; (*keep [3;4]*) "uncompress", writes [3;4]; (*keep [3;4]*) @@ -1303,8 +1305,6 @@ let invalidate_actions = [ "BF_set_key", writes [3]; (*keep [3]*) "PL_NewHashTable", readsAll; (*safe*) "assert_failed", readsAll; (*safe*) - "munmap", readsAll;(*safe*) - "mmap", readsAll;(*safe*) "__builtin_va_arg_pack_len", readsAll; "__open_too_many_args", readsAll; "usb_submit_urb", readsAll; (* first argument is written to but according to specification must not be read from anymore *) From 77b4f67b71e878d6e67a20b5181f6b1972c8908c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 11 Dec 2023 10:50:15 +0200 Subject: [PATCH 183/233] Fix invalid free in 73-strings/03-string_basics --- tests/regression/73-strings/03-string_basics.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index 7b913ea767..e4d6c5c5e4 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -84,7 +84,7 @@ int main() { cmp = strstr(s1, "0"); __goblint_check(cmp == NULL); // UNKNOWN - free(s1); + free(s5); return 0; } From f2fdb622997b9508908415639838500a7eadfa9c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 11 Dec 2023 10:54:24 +0200 Subject: [PATCH 184/233] Add TODOs related to null byte array domain --- src/analyses/base.ml | 5 ++++- src/cdomains/valueDomain.ml | 1 + 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 01b27847ac..9e79eeec2b 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2191,6 +2191,7 @@ struct in let address_from_value (v:value) = match v with | Address a -> + (* TODO: is it fine to just drop the last index unconditionally? https://github.com/goblint/analyzer/pull/1076#discussion_r1408975611 *) let rec lo = function | `Index (i, `NoOffset) -> `NoOffset | `NoOffset -> `NoOffset @@ -2210,6 +2211,7 @@ struct let s2_a = address_from_value s2_v in let s2_typ = AD.type_of s2_a in (* compute value in string literals domain if s1 and s2 are both string literals *) + (* TODO: is this reliable? there could be a char* which isn't StrPtr *) if CilType.Typ.equal s1_typ charPtrType && CilType.Typ.equal s2_typ charPtrType then begin match lv, op_addr with | Some lv_val, Some f -> @@ -2304,7 +2306,8 @@ struct let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) - if AD.type_of a = charPtrType then + (* TODO: is this reliable? there could be a char* which isn't StrPtr *) + if CilType.Typ.equal (AD.type_of a) charPtrType then Int (AD.to_string_length a) (* else compute strlen in array domain *) else diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 4a83447e97..774bced523 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -733,6 +733,7 @@ struct | _, Bot -> Bot (* Leave uninitialized value (from malloc) alone in free to avoid trashing everything. TODO: sound? *) | t , _ -> top_value t + (* TODO: why is this separately needed? *) let rec invalidate_abstract_value = function | Top -> Top | Int i -> Int (ID.top_of (ID.ikind i)) From 0d299f40809e29c11f0579f424762e5a4a5b2854 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 12 Dec 2023 10:43:12 +0200 Subject: [PATCH 185/233] Add NullByteSet to API documentation (PR #1076) --- src/cdomains/nullByteSet.ml | 18 ++++++++++-------- src/goblint_lib.ml | 1 + 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 38fe5cbda9..6a16b0b592 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -1,3 +1,5 @@ +(** Abstract domains for tracking [NULL] bytes in C arrays. *) + module MustSet = struct module M = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) include M @@ -109,7 +111,7 @@ module MustMaySet = struct | Definitely -> MustSet.interval_mem (l,u) musts | Possibly -> failwith "not implemented" - let remove mode i (musts, mays) min_size = + let remove mode i (musts, mays) min_size = match mode with | Definitely -> (MustSet.remove i musts min_size, MaySet.remove i mays min_size) | Possibly -> (MustSet.remove i musts min_size, mays) @@ -133,7 +135,7 @@ module MustMaySet = struct in let mays = match maxfull with - | Some Some maxfull when Z.equal l Z.zero && Z.geq u maxfull -> + | Some Some maxfull when Z.equal l Z.zero && Z.geq u maxfull -> MaySet.top () | _ -> add_indexes l u mays @@ -141,12 +143,12 @@ module MustMaySet = struct match mode with | Definitely -> (add_indexes l u musts, mays) | Possibly -> (musts, mays) - + let remove_interval mode (l,u) min_size (musts, mays) = match mode with | Definitely -> failwith "todo" | Possibly -> - if Z.equal l Z.zero && Z.geq u min_size then + if Z.equal l Z.zero && Z.geq u min_size then (MustSet.top (), mays) else (MustSet.filter ~min_size (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts, mays) @@ -164,8 +166,8 @@ module MustMaySet = struct let is_full_set mode (musts, mays) = match mode with | Definitely -> MustSet.is_bot musts - | Possibly -> MaySet.is_top mays - + | Possibly -> MaySet.is_top mays + let get_set mode (musts, mays) = match mode with | Definitely -> musts @@ -174,10 +176,10 @@ module MustMaySet = struct let elements ?max_size ?min_size mode (musts, mays) = match mode with | Definitely ->failwith "todo" - | Possibly -> MaySet.elements ?max_size mays + | Possibly -> MaySet.elements ?max_size mays let union_mays (must,mays) (_,mays2) = (must, MaySet.join mays mays2) - + let precise_singleton i = (MustSet.singleton i, MaySet.singleton i) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 5a2e0d3e0e..e402cc33fe 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -219,6 +219,7 @@ module AddressDomain = AddressDomain module StructDomain = StructDomain module UnionDomain = UnionDomain module ArrayDomain = ArrayDomain +module NullByteSet = NullByteSet module JmpBufDomain = JmpBufDomain (** {5 Combined} From 6500d35f26e8800c83f562368b8f1f355b3ddfde Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 12 Dec 2023 10:46:46 +0200 Subject: [PATCH 186/233] Fix NULL byte domain indentation (PR #1076) --- src/analyses/base.ml | 30 ++--- src/cdomains/arrayDomain.ml | 238 ++++++++++++++++++------------------ src/cdomains/nullByteSet.ml | 8 +- 3 files changed, 138 insertions(+), 138 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 993df9a26a..7cc937b201 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2215,21 +2215,21 @@ struct if CilType.Typ.equal s1_typ charPtrType && CilType.Typ.equal s2_typ charPtrType then begin match lv, op_addr with | Some lv_val, Some f -> - (* when whished types coincide, compute result of operation op_addr, otherwise use top *) - let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in - let lv_typ = Cilfacade.typeOfLval lv_val in - if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) - else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) - else - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + (* when whished types coincide, compute result of operation op_addr, otherwise use top *) + let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_typ = Cilfacade.typeOfLval lv_val in + if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + else + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) | _ -> (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) let _ = AD.string_writing_defined s1_a in set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end - (* else compute value in array domain *) + (* else compute value in array domain *) else let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val @@ -2326,11 +2326,11 @@ struct if needle is substring, assign the substring of haystack starting at the first occurrence of needle to dest, if it surely isn't, assign a null_ptr *) string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) - (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with - | CArrays.IsNotSubstr -> Address (AD.null_ptr) - | CArrays.IsSubstrAtIndex0 -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st - (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) + (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with + | CArrays.IsNotSubstr -> Address (AD.null_ptr) + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end | Strcmp { s1; s2; n }, _ -> diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 6c47f1e87a..d4d5a46e98 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -1074,21 +1074,21 @@ struct (* if size has no upper limit *) | None -> (match Val.is_null v with - | NotNull -> - Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size - (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) - | Null -> - Nulls.add (if i <. min_size then Definitely else Possibly) i nulls - (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) - (* i >= minimal size and value = null, add i only to may_nulls_set *) - | Maybe -> - let removed = Nulls.remove Possibly i nulls min_size in - Nulls.add Possibly i removed) + | NotNull -> + Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size + (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) + | Null -> + Nulls.add (if i <. min_size then Definitely else Possibly) i nulls + (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + (* i >= minimal size and value = null, add i only to may_nulls_set *) + | Maybe -> + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed) | Some max_size -> (match Val.is_null v with | NotNull -> Nulls.remove Definitely i nulls min_size - (* if value <> null, remove i from must_nulls_set and may_nulls_set *) + (* if value <> null, remove i from must_nulls_set and may_nulls_set *) | Null when i <. min_size -> Nulls.add Definitely i nulls | Null when i <. max_size -> @@ -1114,43 +1114,43 @@ struct (* warn if index is (potentially) out of bounds *) array_oob_check (module Idx) (Nulls.get_set Possibly, size) (e, i); let nulls = match max_i with - (* if no maximum number in index interval *) - | None -> - (* ..., value = null *) - (if Val.is_null v = Null && Idx.maximal size = None then - match Idx.maximal size with - (* ... and there is no maximal size, modify may_nulls_set to top *) - | None -> Nulls.add_all Possibly nulls - (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) - | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls - (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) - else if Val.is_null v = NotNull then - Nulls.filter_musts (Z.gt min_i) min_size nulls - (*..., value unknown *) - else - match Idx.minimal size, Idx.maximal size with - (* ... and size unknown, modify both sets to top *) - | None, None -> Nulls.top () - (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) - | Some min_size, None -> - let nulls = Nulls.add_all Possibly nulls in - Nulls.filter_musts (Z.gt min_size) min_size nulls - (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) - | None, Some max_size -> - let nulls = Nulls.remove_all Possibly nulls in - Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls - (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) - | Some min_size, Some max_size -> - let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in - Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls - ) - | Some max_i when max_i >=. Z.zero -> - if min_i =. max_i then - set_exact_nulls min_i - else - set_interval min_i max_i - (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) - | _ -> nulls + (* if no maximum number in index interval *) + | None -> + (* ..., value = null *) + (if Val.is_null v = Null && Idx.maximal size = None then + match Idx.maximal size with + (* ... and there is no maximal size, modify may_nulls_set to top *) + | None -> Nulls.add_all Possibly nulls + (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) + | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) + else if Val.is_null v = NotNull then + Nulls.filter_musts (Z.gt min_i) min_size nulls + (*..., value unknown *) + else + match Idx.minimal size, Idx.maximal size with + (* ... and size unknown, modify both sets to top *) + | None, None -> Nulls.top () + (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) + | Some min_size, None -> + let nulls = Nulls.add_all Possibly nulls in + Nulls.filter_musts (Z.gt min_size) min_size nulls + (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) + | None, Some max_size -> + let nulls = Nulls.remove_all Possibly nulls in + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) + | Some min_size, Some max_size -> + let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + ) + | Some max_i when max_i >=. Z.zero -> + if min_i =. max_i then + set_exact_nulls min_i + else + set_interval min_i max_i + (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) + | _ -> nulls in (nulls, size) @@ -1236,7 +1236,7 @@ struct let nulls = if min_must_null =. min_may_null then Nulls.precise_singleton min_must_null - (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) else match Idx.maximal size with | Some max_size -> @@ -1263,59 +1263,59 @@ struct M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" else (match min_must_null with - | Some min_must_null when not (min_must_null >=. n || min_must_null >. min_may_null) -> () - | _ -> - M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" + | Some min_must_null when not (min_must_null >=. n || min_must_null >. min_may_null) -> () + | _ -> + M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" ) in (match Idx.minimal size, Idx.maximal size with - | Some min_size, Some max_size -> - if n >. max_size then - warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" - else if n >. min_size then - warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | Some min_size, None -> - if n >. min_size then - warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" - | None, Some max_size -> - if n >. max_size then - warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" - | None, None -> ()); + | Some min_size, Some max_size -> + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" + else if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | Some min_size, None -> + if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | None, Some max_size -> + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" + | None, None -> ()); let nulls = - (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) - if Nulls.is_empty Definitely nulls then - (warn_past_end - "Resulting string might not be null-terminated because src doesn't contain a null byte"; - match Idx.maximal size with - (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) - | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls - | _ -> nulls) - (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; - * warn as in any case, resulting array not guaranteed to contain null byte *) - else if Nulls.is_empty Possibly nulls then - let min_may_null = Nulls.min_elem Possibly nulls in - warn_no_null None min_may_null; - if min_may_null =. Z.zero then - Nulls.add_all Possibly nulls - else - let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in - Nulls.filter (fun x -> x <. n) nulls - else - let min_must_null = Nulls.min_elem Definitely nulls in - let min_may_null = Nulls.min_elem Possibly nulls in - (* warn if resulting array may not contain null byte *) - warn_no_null (Some min_must_null) min_may_null; - (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) - if min_must_null =. min_may_null then - if min_must_null =. Z.zero then - Nulls.full_set () + (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) + if Nulls.is_empty Definitely nulls then + (warn_past_end + "Resulting string might not be null-terminated because src doesn't contain a null byte"; + match Idx.maximal size with + (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) + | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls + | _ -> nulls) + (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; + * warn as in any case, resulting array not guaranteed to contain null byte *) + else if Nulls.is_empty Possibly nulls then + let min_may_null = Nulls.min_elem Possibly nulls in + warn_no_null None min_may_null; + if min_may_null =. Z.zero then + Nulls.add_all Possibly nulls else - let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in Nulls.filter (fun x -> x <. n) nulls - else if min_may_null =. Z.zero then + else + let min_must_null = Nulls.min_elem Definitely nulls in + let min_may_null = Nulls.min_elem Possibly nulls in + (* warn if resulting array may not contain null byte *) + warn_no_null (Some min_must_null) min_may_null; + (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) + if min_must_null =. min_may_null then + if min_must_null =. Z.zero then + Nulls.full_set () + else + let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls + else if min_may_null =. Z.zero then Nulls.top () - else + else let nulls = Nulls.remove_all Possibly nulls in let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in Nulls.filter (fun x -> x <. n) nulls @@ -1328,11 +1328,11 @@ struct (warn_past_end "Array doesn't contain a null byte: buffer overflow"; Idx.starting !Cil.kindOfSizeOf (BatOption.default Z.zero (Idx.minimal size)) ) - (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) else if Nulls.is_empty Possibly nulls then (warn_past_end "Array might not contain a null byte: potential buffer overflow"; Idx.starting !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls)) - (* else return interval [minimal may null, minimal must null] *) + (* else return interval [minimal may null, minimal must null] *) else Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) @@ -1441,13 +1441,13 @@ struct let update_sets min_size1 max_size1 minlen1 maxlen1 minlen2 (maxlen2: Z.t option) nulls2' = (* track any potential buffer overflow and issue warning if needed *) (if GobOption.exists (fun x -> x <=. (minlen1 +. minlen2)) max_size1 then - warn_past_end + warn_past_end "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" else - (match maxlen1, maxlen2 with - | Some maxlen1, Some maxlen2 when min_size1 >. (maxlen1 +. maxlen2) -> () - | _ -> warn_past_end - "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest") + (match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 when min_size1 >. (maxlen1 +. maxlen2) -> () + | _ -> warn_past_end + "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest") ); (* if any must_nulls_set empty, result must_nulls_set also empty; * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set @@ -1473,21 +1473,21 @@ struct (r, size1) | None when Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 -> (match maxlen1, maxlen2 with - | Some maxlen1, Some maxlen2-> - let nulls1_no_must = Nulls.remove_all Possibly nulls1 in - let r = - nulls1_no_must - (* filter ensures we have the concete representation *) - |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) - |> Nulls.elements Possibly - |> BatList.cartesian_product (Nulls.elements Possibly nulls2') - |> List.map (fun (i1, i2) -> i1 +. i2) - |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) - in - (r, size1) - | _ -> (Nulls.top (), size1)) + | Some maxlen1, Some maxlen2-> + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) + |> Nulls.elements Possibly + |> BatList.cartesian_product (Nulls.elements Possibly nulls2') + |> List.map (fun (i1, i2) -> i1 +. i2) + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + in + (r, size1) + | _ -> (Nulls.top (), size1)) | _ -> (Nulls.top (), size1) - (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) else if Nulls.min_elem_precise nulls1 && Nulls.min_elem_precise nulls2' then let min_i1 = Nulls.min_elem Definitely nulls1 in let min_i2 = Nulls.min_elem Definitely nulls2' in @@ -1616,14 +1616,14 @@ struct let min_must1 = Nulls.min_elem Definitely nulls1 in let min_must2 = Nulls.min_elem Definitely nulls2 in if not (min_must1 =. min_must2) - && min_must1 =.(Nulls.min_elem Possibly nulls1) - && min_must2 =. (Nulls.min_elem Possibly nulls2) - && (BatOption.map_default (fun x -> min_must1 <. x || min_must2 <. x) true n) + && min_must1 =.(Nulls.min_elem Possibly nulls1) + && min_must2 =. (Nulls.min_elem Possibly nulls2) + && (BatOption.map_default (fun x -> min_must1 <. x || min_must2 <. x) true n) then (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) Idx.of_excl_list IInt [Z.zero] else - Idx.top_of IInt + Idx.top_of IInt with Not_found -> Idx.top_of IInt in diff --git a/src/cdomains/nullByteSet.ml b/src/cdomains/nullByteSet.ml index 6a16b0b592..ff5d0270e0 100644 --- a/src/cdomains/nullByteSet.ml +++ b/src/cdomains/nullByteSet.ml @@ -148,10 +148,10 @@ module MustMaySet = struct match mode with | Definitely -> failwith "todo" | Possibly -> - if Z.equal l Z.zero && Z.geq u min_size then - (MustSet.top (), mays) - else - (MustSet.filter ~min_size (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts, mays) + if Z.equal l Z.zero && Z.geq u min_size then + (MustSet.top (), mays) + else + (MustSet.filter ~min_size (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts, mays) let add_all mode (musts, mays) = match mode with From ea83c30f1db59c6f0cd7922a25e225ef1e4c4475 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 13 Dec 2023 16:11:38 +0100 Subject: [PATCH 187/233] Be more conservative for `ioctl` --- src/util/library/libraryFunctions.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index ee8d58d886..d260ebb070 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -750,7 +750,7 @@ let linux_kernel_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("__kmalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Malloc size); ("kzalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Calloc {count = Cil.one; size}); ("usb_alloc_urb", special [__ "iso_packets" []; drop "mem_flags" []] @@ fun iso_packets -> Malloc MyCFG.unknown_exp); - ("ioctl", unknown (drop "fd" [] :: drop "request" [] :: VarArgs (drop' [r]))); + ("ioctl", unknown (drop "fd" [] :: drop "request" [] :: VarArgs (drop' [r_deep; w_deep]))); ] (** Goblint functions. *) From 7b38a7353750b8bb9ae94fd966b0107ddb36728b Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Wed, 13 Dec 2023 20:56:35 +0000 Subject: [PATCH 188/233] Bump github/codeql-action from 2 to 3 Bumps [github/codeql-action](https://github.com/github/codeql-action) from 2 to 3. - [Release notes](https://github.com/github/codeql-action/releases) - [Changelog](https://github.com/github/codeql-action/blob/main/CHANGELOG.md) - [Commits](https://github.com/github/codeql-action/compare/v2...v3) --- updated-dependencies: - dependency-name: github/codeql-action dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/semgrep.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/semgrep.yml b/.github/workflows/semgrep.yml index bd2dfd285c..c22eee5181 100644 --- a/.github/workflows/semgrep.yml +++ b/.github/workflows/semgrep.yml @@ -22,7 +22,7 @@ jobs: run: semgrep scan --config .semgrep/ --sarif > semgrep.sarif - name: Upload SARIF file to GitHub Advanced Security Dashboard - uses: github/codeql-action/upload-sarif@v2 + uses: github/codeql-action/upload-sarif@v3 with: sarif_file: semgrep.sarif if: always() From 8a2a977ff5bf5807e800a836a0479d5f356e6608 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 11:47:04 +0200 Subject: [PATCH 189/233] Do not use plain CIL printers in user messages --- src/analyses/base.ml | 2 +- src/analyses/baseInvariant.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7cc937b201..46a54af2ba 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1878,7 +1878,7 @@ struct let invalidate ?(deep=true) ~ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; - if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_plainexp) exps; + if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let invalidate_address st a = diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 304d3e55ad..2c783edcf9 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -243,7 +243,7 @@ struct refine_lv_fallback ctx a gs st lval value tv | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; - M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_plainexp exp; + M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; st let invariant ctx a gs st exp tv: D.t = From 4b77174ca1a21bf8c58a99b0f2e8de6d9a12455e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 11:47:27 +0200 Subject: [PATCH 190/233] Make BaseInvariant fallback reason printing lazy --- src/analyses/baseInvariant.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 2c783edcf9..f18eeed24f 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -248,7 +248,7 @@ struct let invariant ctx a gs st exp tv: D.t = let fallback reason st = - if M.tracing then M.tracel "inv" "Can't handle %a.\n%s\n" d_plainexp exp reason; + if M.tracing then M.tracel "inv" "Can't handle %a.\n%t\n" d_plainexp exp reason; invariant_fallback ctx a gs st exp tv in (* inverse values for binary operation a `op` b == c *) @@ -689,7 +689,7 @@ struct (* Mixed Float and Int cases should never happen, as there are no binary operators with one float and one int parameter ?!*) | Int _, Float _ | Float _, Int _ -> failwith "ill-typed program"; (* | Address a, Address b -> ... *) - | a1, a2 -> fallback (GobPretty.sprintf "binop: got abstract values that are not Int: %a and %a" VD.pretty a1 VD.pretty a2) st) + | a1, a2 -> fallback (fun () -> Pretty.dprintf "binop: got abstract values that are not Int: %a and %a" VD.pretty a1 VD.pretty a2) st) (* use closures to avoid unused casts *) in (match c_typed with | Int c -> invert_binary_op c ID.pretty (fun ik -> ID.cast_to ik c) (fun fk -> FD.of_int fk c) @@ -778,7 +778,7 @@ struct | TFloat (fk, _), FLongDouble | TFloat (FDouble as fk, _), FDouble | TFloat (FFloat as fk, _), FFloat -> inv_exp (Float (FD.cast_to fk c)) e st - | _ -> fallback ("CastE: incompatible types") st) + | _ -> fallback (fun () -> Pretty.text "CastE: incompatible types") st) | CastE ((TInt (ik, _)) as t, e), Int c | CastE ((TEnum ({ekind = ik; _ }, _)) as t, e), Int c -> (* Can only meet the t part of an Lval in e with c (unless we meet with all overflow possibilities)! Since there is no good way to do this, we only continue if e has no values outside of t. *) (match eval e st with @@ -791,11 +791,11 @@ struct let c' = ID.cast_to ik_e (ID.meet c (ID.cast_to ik (ID.top_of ik_e))) in (* TODO: cast without overflow, is this right for normal invariant? *) if M.tracing then M.tracel "inv" "cast: %a from %a to %a: i = %a; cast c = %a to %a = %a\n" d_exp e d_ikind ik_e d_ikind ik ID.pretty i ID.pretty c d_ikind ik_e ID.pretty c'; inv_exp (Int c') e st - | x -> fallback (GobPretty.sprintf "CastE: e did evaluate to Int, but the type did not match %a" CilType.Typ.pretty t) st + | x -> fallback (fun () -> Pretty.dprintf "CastE: e did evaluate to Int, but the type did not match %a" CilType.Typ.pretty t) st else - fallback (GobPretty.sprintf "CastE: %a evaluates to %a which is bigger than the type it is cast to which is %a" d_plainexp e ID.pretty i CilType.Typ.pretty t) st - | v -> fallback (GobPretty.sprintf "CastE: e did not evaluate to Int, but %a" VD.pretty v) st) - | e, _ -> fallback (GobPretty.sprintf "%a not implemented" d_plainexp e) st + fallback (fun () -> Pretty.dprintf "CastE: %a evaluates to %a which is bigger than the type it is cast to which is %a" d_plainexp e ID.pretty i CilType.Typ.pretty t) st + | v -> fallback (fun () -> Pretty.dprintf "CastE: e did not evaluate to Int, but %a" VD.pretty v) st) + | e, _ -> fallback (fun () -> Pretty.dprintf "%a not implemented" d_plainexp e) st in if eval_bool exp st = Some (not tv) then contra st (* we already know that the branch is dead *) else From 0dd43968f8bf44993bb52360b2eb830ce0adc9c4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 12:07:08 +0200 Subject: [PATCH 191/233] Make Offset.Type_of_error string construction lazy --- src/cdomains/offset.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/cdomains/offset.ml b/src/cdomains/offset.ml index 52cfe9eb41..62bab39eb7 100644 --- a/src/cdomains/offset.ml +++ b/src/cdomains/offset.ml @@ -142,15 +142,11 @@ struct | TPtr (t,_), `Index (i,o) -> type_of ~base:t o | TComp (ci,_), `Field (f,o) -> let fi = try getCompField ci f.fname - with Not_found -> - let s = GobPretty.sprintf "Addr.type_offset: field %s not found in type %a" f.fname d_plaintype t in - raise (Type_of_error (t, s)) + with Not_found -> raise (Type_of_error (t, show o)) in type_of ~base:fi.ftype o (* TODO: Why? Imprecise on zstd-thread-pool regression tests. *) (* | TComp _, `Index (_,o) -> type_of ~base:t o (* this happens (hmmer, perlbench). safe? *) *) - | t,o -> - let s = GobPretty.sprintf "Addr.type_offset: could not follow offset in type. type: %a, offset: %a" d_plaintype t pretty o in - raise (Type_of_error (t, s)) + | t, o -> raise (Type_of_error (t, show o)) let rec prefix (x: t) (y: t): t option = match x,y with | `Index (x, xs), `Index (y, ys) when Idx.equal x y -> prefix xs ys @@ -261,3 +257,9 @@ struct | `Index (i,o) -> Index (i, to_cil o) | `Field (f,o) -> Field (f, to_cil o) end + + +let () = Printexc.register_printer (function + | Type_of_error (t, o) -> Some (GobPretty.sprintf "Offset.Type_of_error(%a, %s)" d_plaintype t o) + | _ -> None (* for other exceptions *) + ) From 86ab2390a4fd2a84c0944b99e9e755d5ea329b7b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 12:41:36 +0200 Subject: [PATCH 192/233] Promote cram tests after invalidating expressions output change --- tests/regression/04-mutex/49-type-invariants.t | 8 ++++---- tests/regression/04-mutex/77-type-nested-fields.t | 4 ++-- tests/regression/04-mutex/79-type-nested-fields-deep1.t | 4 ++-- tests/regression/04-mutex/80-type-nested-fields-deep2.t | 4 ++-- tests/regression/04-mutex/90-distribute-fields-type-1.t | 4 ++-- tests/regression/04-mutex/91-distribute-fields-type-2.t | 4 ++-- .../regression/04-mutex/92-distribute-fields-type-deep.t | 4 ++-- .../04-mutex/93-distribute-fields-type-global.t | 4 ++-- 8 files changed, 18 insertions(+), 18 deletions(-) diff --git a/tests/regression/04-mutex/49-type-invariants.t b/tests/regression/04-mutex/49-type-invariants.t index 4b8118eec1..b6c43d21bc 100644 --- a/tests/regression/04-mutex/49-type-invariants.t +++ b/tests/regression/04-mutex/49-type-invariants.t @@ -16,8 +16,8 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (49-type-invariants.c:21:3-21:21) [Info][Imprecise] INVALIDATING ALL GLOBALS! (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & s (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & tmp (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing for getS (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing @@ -39,7 +39,7 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (49-type-invariants.c:21:3-21:21) [Info][Imprecise] INVALIDATING ALL GLOBALS! (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & s (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & tmp (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing for getS (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/77-type-nested-fields.t b/tests/regression/04-mutex/77-type-nested-fields.t index 68d9cdb779..0ecf051578 100644 --- a/tests/regression/04-mutex/77-type-nested-fields.t +++ b/tests/regression/04-mutex/77-type-nested-fields.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (77-type-nested-fields.c:31:3-31:20) [Info][Unsound] Write to unknown address: privatization is unsound. (77-type-nested-fields.c:38:3-38:22) [Info][Imprecise] INVALIDATING ALL GLOBALS! (77-type-nested-fields.c:31:3-31:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (77-type-nested-fields.c:31:3-31:20) + [Info][Imprecise] Invalidating expressions: & tmp (77-type-nested-fields.c:31:3-31:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (77-type-nested-fields.c:38:3-38:22) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (77-type-nested-fields.c:38:3-38:22) + [Info][Imprecise] Invalidating expressions: & tmp (77-type-nested-fields.c:38:3-38:22) [Error][Imprecise][Unsound] Function definition missing for getS (77-type-nested-fields.c:31:3-31:20) [Error][Imprecise][Unsound] Function definition missing for getT (77-type-nested-fields.c:38:3-38:22) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/79-type-nested-fields-deep1.t b/tests/regression/04-mutex/79-type-nested-fields-deep1.t index 85f7bfb709..611a70a7c3 100644 --- a/tests/regression/04-mutex/79-type-nested-fields-deep1.t +++ b/tests/regression/04-mutex/79-type-nested-fields-deep1.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (79-type-nested-fields-deep1.c:36:3-36:20) [Info][Unsound] Write to unknown address: privatization is unsound. (79-type-nested-fields-deep1.c:43:3-43:24) [Info][Imprecise] INVALIDATING ALL GLOBALS! (79-type-nested-fields-deep1.c:36:3-36:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (79-type-nested-fields-deep1.c:36:3-36:20) + [Info][Imprecise] Invalidating expressions: & tmp (79-type-nested-fields-deep1.c:36:3-36:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (79-type-nested-fields-deep1.c:43:3-43:24) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (79-type-nested-fields-deep1.c:43:3-43:24) + [Info][Imprecise] Invalidating expressions: & tmp (79-type-nested-fields-deep1.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing for getS (79-type-nested-fields-deep1.c:36:3-36:20) [Error][Imprecise][Unsound] Function definition missing for getU (79-type-nested-fields-deep1.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/80-type-nested-fields-deep2.t b/tests/regression/04-mutex/80-type-nested-fields-deep2.t index a2e9e2ab15..7ddbdc4fd7 100644 --- a/tests/regression/04-mutex/80-type-nested-fields-deep2.t +++ b/tests/regression/04-mutex/80-type-nested-fields-deep2.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (80-type-nested-fields-deep2.c:36:3-36:22) [Info][Unsound] Write to unknown address: privatization is unsound. (80-type-nested-fields-deep2.c:43:3-43:24) [Info][Imprecise] INVALIDATING ALL GLOBALS! (80-type-nested-fields-deep2.c:36:3-36:22) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (80-type-nested-fields-deep2.c:36:3-36:22) + [Info][Imprecise] Invalidating expressions: & tmp (80-type-nested-fields-deep2.c:36:3-36:22) [Info][Imprecise] INVALIDATING ALL GLOBALS! (80-type-nested-fields-deep2.c:43:3-43:24) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (80-type-nested-fields-deep2.c:43:3-43:24) + [Info][Imprecise] Invalidating expressions: & tmp (80-type-nested-fields-deep2.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing for getT (80-type-nested-fields-deep2.c:36:3-36:22) [Error][Imprecise][Unsound] Function definition missing for getU (80-type-nested-fields-deep2.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/90-distribute-fields-type-1.t b/tests/regression/04-mutex/90-distribute-fields-type-1.t index a3b5faf083..587e943b36 100644 --- a/tests/regression/04-mutex/90-distribute-fields-type-1.t +++ b/tests/regression/04-mutex/90-distribute-fields-type-1.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (90-distribute-fields-type-1.c:31:3-31:20) [Info][Unsound] Write to unknown address: privatization is unsound. (90-distribute-fields-type-1.c:39:3-39:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (90-distribute-fields-type-1.c:31:3-31:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (90-distribute-fields-type-1.c:31:3-31:20) + [Info][Imprecise] Invalidating expressions: & tmp (90-distribute-fields-type-1.c:31:3-31:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (90-distribute-fields-type-1.c:39:3-39:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (90-distribute-fields-type-1.c:39:3-39:17) + [Info][Imprecise] Invalidating expressions: & tmp (90-distribute-fields-type-1.c:39:3-39:17) [Error][Imprecise][Unsound] Function definition missing for getS (90-distribute-fields-type-1.c:31:3-31:20) [Error][Imprecise][Unsound] Function definition missing for getT (90-distribute-fields-type-1.c:39:3-39:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/91-distribute-fields-type-2.t b/tests/regression/04-mutex/91-distribute-fields-type-2.t index 5773245114..afb01fdced 100644 --- a/tests/regression/04-mutex/91-distribute-fields-type-2.t +++ b/tests/regression/04-mutex/91-distribute-fields-type-2.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (91-distribute-fields-type-2.c:32:3-32:17) [Info][Unsound] Write to unknown address: privatization is unsound. (91-distribute-fields-type-2.c:40:3-40:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (91-distribute-fields-type-2.c:32:3-32:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (91-distribute-fields-type-2.c:32:3-32:17) + [Info][Imprecise] Invalidating expressions: & tmp (91-distribute-fields-type-2.c:32:3-32:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (91-distribute-fields-type-2.c:40:3-40:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (91-distribute-fields-type-2.c:40:3-40:17) + [Info][Imprecise] Invalidating expressions: & tmp (91-distribute-fields-type-2.c:40:3-40:17) [Error][Imprecise][Unsound] Function definition missing for getS (91-distribute-fields-type-2.c:32:3-32:17) [Error][Imprecise][Unsound] Function definition missing for getT (91-distribute-fields-type-2.c:40:3-40:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/92-distribute-fields-type-deep.t b/tests/regression/04-mutex/92-distribute-fields-type-deep.t index 798374d63c..1748b245e2 100644 --- a/tests/regression/04-mutex/92-distribute-fields-type-deep.t +++ b/tests/regression/04-mutex/92-distribute-fields-type-deep.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (92-distribute-fields-type-deep.c:36:3-36:20) [Info][Unsound] Write to unknown address: privatization is unsound. (92-distribute-fields-type-deep.c:44:3-44:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (92-distribute-fields-type-deep.c:36:3-36:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (92-distribute-fields-type-deep.c:36:3-36:20) + [Info][Imprecise] Invalidating expressions: & tmp (92-distribute-fields-type-deep.c:36:3-36:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (92-distribute-fields-type-deep.c:44:3-44:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (92-distribute-fields-type-deep.c:44:3-44:17) + [Info][Imprecise] Invalidating expressions: & tmp (92-distribute-fields-type-deep.c:44:3-44:17) [Error][Imprecise][Unsound] Function definition missing for getS (92-distribute-fields-type-deep.c:36:3-36:20) [Error][Imprecise][Unsound] Function definition missing for getU (92-distribute-fields-type-deep.c:44:3-44:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/93-distribute-fields-type-global.t b/tests/regression/04-mutex/93-distribute-fields-type-global.t index 07999854ff..50c72aa289 100644 --- a/tests/regression/04-mutex/93-distribute-fields-type-global.t +++ b/tests/regression/04-mutex/93-distribute-fields-type-global.t @@ -18,7 +18,7 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (93-distribute-fields-type-global.c:13:3-13:29) [Info][Imprecise] INVALIDATING ALL GLOBALS! (93-distribute-fields-type-global.c:13:3-13:29) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (93-distribute-fields-type-global.c:13:3-13:29) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (93-distribute-fields-type-global.c:13:3-13:29) + [Info][Imprecise] Invalidating expressions: & s (93-distribute-fields-type-global.c:13:3-13:29) + [Info][Imprecise] Invalidating expressions: & tmp (93-distribute-fields-type-global.c:13:3-13:29) [Error][Imprecise][Unsound] Function definition missing for getS (93-distribute-fields-type-global.c:13:3-13:29) [Error][Imprecise][Unsound] Function definition missing From f4d6197ee0ea2520b71036557e56e8f90cb635d5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 15:12:09 +0200 Subject: [PATCH 193/233] Add Printable.EitherConf --- src/analyses/commonPriv.ml | 2 +- src/common/domains/printable.ml | 34 ++++++++++++++++++++++++--------- src/framework/analyses.ml | 4 ++-- src/framework/constraints.ml | 2 +- 4 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 73a2e75de1..87490a814a 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -173,7 +173,7 @@ struct module V = struct - include Printable.Either (MutexGlobals.V) (TID) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (MutexGlobals.V) (TID) let mutex x = `Left (MutexGlobals.V.mutex x) let mutex_inits = `Left MutexGlobals.V.mutex_inits let global x = `Left (MutexGlobals.V.global x) diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index cc01718ee8..a1f33efdad 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -244,35 +244,51 @@ struct ] (* S TODO: decide frequencies *) end -module Either (Base1: S) (Base2: S) = +module type EitherConf = +sig + val expand1: bool + val expand2: bool +end + +module EitherConf (Conf: EitherConf) (Base1: S) (Base2: S) = struct type t = [`Left of Base1.t | `Right of Base2.t] [@@deriving eq, ord, hash] include Std let pretty () (state:t) = match state with - | `Left n -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n - | `Right n -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Left n when Conf.expand1 -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n + | `Left n -> Base1.pretty () n + | `Right n when Conf.expand2 -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Right n -> Base2.pretty () n let show state = match state with - | `Left n -> (Base1.name ()) ^ ":" ^ Base1.show n - | `Right n -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Left n when Conf.expand1 -> (Base1.name ()) ^ ":" ^ Base1.show n + | `Left n -> Base1.show n + | `Right n when Conf.expand2 -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Right n -> Base2.show n let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () let printXml f = function - | `Left x -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x - | `Right x -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base2.printXml x + | `Left x when Conf.expand1 -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x + | `Left x -> Base1.printXml f x + | `Right x when Conf.expand2 -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base2.printXml x + | `Right x -> Base2.printXml f x let to_yojson = function - | `Left x -> `Assoc [ Base1.name (), Base1.to_yojson x ] - | `Right x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Left x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] + | `Left x -> Base1.to_yojson x + | `Right x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Right x -> Base2.to_yojson x let relift = function | `Left x -> `Left (Base1.relift x) | `Right x -> `Right (Base2.relift x) end +module Either = EitherConf (struct let expand1 = true let expand2 = true end) + module Either3 (Base1: S) (Base2: S) (Base3: S) = struct type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index a37a3043c2..44f1f1894e 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -74,7 +74,7 @@ end module GVarF (V: SpecSysVar) = struct - include Printable.Either (V) (CilType.Fundec) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (V) (CilType.Fundec) let name () = "FromSpec" let spec x = `Left x let contexts x = `Right x @@ -90,7 +90,7 @@ end module GVarFC (V:SpecSysVar) (C:Printable.S) = struct - include Printable.Either (V) (Printable.Prod (CilType.Fundec) (C)) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (V) (Printable.Prod (CilType.Fundec) (C)) let name () = "FromSpec" let spec x = `Left x let call (x, c) = `Right (x, c) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 77d3a38186..25b2060e0c 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1338,7 +1338,7 @@ struct module V = struct - include Printable.Either (S.V) (Node) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (S.V) (Node) let name () = "DeadBranch" let s x = `Left x let node x = `Right x From 2509d22f2b4254ca69e19dcd0f6cca9a026985aa Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 15:29:53 +0200 Subject: [PATCH 194/233] Add Printable.Either3Conf --- src/common/domains/printable.ml | 46 +++++++++++++++++++++++---------- src/framework/constraints.ml | 2 +- 2 files changed, 34 insertions(+), 14 deletions(-) diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index a1f33efdad..8311dd2ef0 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -289,33 +289,51 @@ end module Either = EitherConf (struct let expand1 = true let expand2 = true end) -module Either3 (Base1: S) (Base2: S) (Base3: S) = +module type Either3Conf = +sig + include EitherConf + val expand3: bool +end + +module Either3Conf (Conf: Either3Conf) (Base1: S) (Base2: S) (Base3: S) = struct type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] include Std let pretty () (state:t) = match state with - | `Left n -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n - | `Middle n -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n - | `Right n -> Pretty.dprintf "%s:%a" (Base3.name ()) Base3.pretty n + | `Left n when Conf.expand1 -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n + | `Left n -> Base1.pretty () n + | `Middle n when Conf.expand2 -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Middle n -> Base2.pretty () n + | `Right n when Conf.expand3 -> Pretty.dprintf "%s:%a" (Base3.name ()) Base3.pretty n + | `Right n -> Base3.pretty () n let show state = match state with - | `Left n -> (Base1.name ()) ^ ":" ^ Base1.show n - | `Middle n -> (Base2.name ()) ^ ":" ^ Base2.show n - | `Right n -> (Base3.name ()) ^ ":" ^ Base3.show n + | `Left n when Conf.expand1 -> (Base1.name ()) ^ ":" ^ Base1.show n + | `Left n -> Base1.show n + | `Middle n when Conf.expand2 -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Middle n -> Base2.show n + | `Right n when Conf.expand3 -> (Base3.name ()) ^ ":" ^ Base3.show n + | `Right n -> Base3.show n let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () ^ " or " ^ Base3.name () let printXml f = function - | `Left x -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x - | `Middle x -> BatPrintf.fprintf f "\n\nMiddle\n\n%a\n\n" Base2.printXml x - | `Right x -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base3.printXml x + | `Left x when Conf.expand1 -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x + | `Left x -> Base1.printXml f x + | `Middle x when Conf.expand2 -> BatPrintf.fprintf f "\n\nMiddle\n\n%a\n\n" Base2.printXml x + | `Middle x -> Base2.printXml f x + | `Right x when Conf.expand3 -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base3.printXml x + | `Right x -> Base3.printXml f x let to_yojson = function - | `Left x -> `Assoc [ Base1.name (), Base1.to_yojson x ] - | `Middle x -> `Assoc [ Base2.name (), Base2.to_yojson x ] - | `Right x -> `Assoc [ Base3.name (), Base3.to_yojson x ] + | `Left x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] + | `Left x -> Base1.to_yojson x + | `Middle x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Middle x -> Base2.to_yojson x + | `Right x when Conf.expand3 -> `Assoc [ Base3.name (), Base3.to_yojson x ] + | `Right x -> Base3.to_yojson x let relift = function | `Left x -> `Left (Base1.relift x) @@ -323,6 +341,8 @@ struct | `Right x -> `Right (Base3.relift x) end +module Either3 = Either3Conf (struct let expand1 = true let expand2 = true let expand3 = true end) + module Option (Base: S) (N: Name) = struct type t = Base.t option [@@deriving eq, ord, hash] diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 25b2060e0c..ee1ea00a01 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1472,7 +1472,7 @@ struct module V = struct - include Printable.Either3 (S.V) (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C)) + include Printable.Either3Conf (struct let expand1 = false let expand2 = true let expand3 = true end) (S.V) (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C)) let name () = "longjmp" let s x = `Left x let longjmpto x = `Middle x From 38942f96edb2cca3143ff66d19d2ba12ecc0b2fa Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 15:32:20 +0200 Subject: [PATCH 195/233] Remove variant name duplication in privatizations --- src/analyses/basePriv.ml | 12 +----------- src/analyses/commonPriv.ml | 2 -- 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 0126449413..72854d474d 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -544,7 +544,7 @@ struct ) ) else ( - if ConcDomain.ThreadSet.is_top tids then + if ConcDomain.ThreadSet.is_top tids then st else match ConcDomain.ThreadSet.elements tids with @@ -660,21 +660,11 @@ struct struct include VarinfoV (* [g]' *) let name () = "unprotected" - let show x = show x ^ ":unprotected" (* distinguishable variant names for html *) - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) end module VProt = struct include VarinfoV (* [g] *) let name () = "protected" - let show x = show x ^ ":protected" (* distinguishable variant names for html *) - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) end module V = struct diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 87490a814a..0453862bc0 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -74,14 +74,12 @@ struct struct include LockDomain.Addr let name () = "mutex" - let show x = show x ^ ":mutex" (* distinguishable variant names for html *) end module VMutexInits = Printable.UnitConf (struct let name = "MUTEX_INITS" end) module VGlobal = struct include VarinfoV let name () = "global" - let show x = show x ^ ":global" (* distinguishable variant names for html *) end module V = struct From 3d5c65db7de3912c889193132208846d2c990ff9 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 15:48:07 +0200 Subject: [PATCH 196/233] Add Lattice.Lift2Conf --- src/analyses/base.ml | 2 +- src/analyses/basePriv.ml | 2 +- src/analyses/commonPriv.ml | 2 +- src/analyses/mutexAnalysis.ml | 2 +- src/analyses/raceAnalysis.ml | 2 +- src/common/domains/printable.ml | 18 +++++++++++++----- src/domain/lattice.ml | 6 ++++-- 7 files changed, 22 insertions(+), 12 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7cc937b201..8c4bb67b0b 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -54,7 +54,7 @@ struct module G = struct - include Lattice.Lift2 (Priv.G) (VD) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (Priv.G) (VD) (Printable.DefaultNames) let priv = function | `Bot -> Priv.G.bot () diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 72854d474d..b486dfd552 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -799,7 +799,7 @@ struct struct (* weak: G -> (2^M -> WeakRange) *) (* sync: M -> (2^M -> SyncRange) *) - include Lattice.Lift2 (GWeak) (GSync) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GWeak) (GSync) (Printable.DefaultNames) let weak = function | `Bot -> GWeak.bot () diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 0453862bc0..1bf03581c2 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -198,7 +198,7 @@ struct module G = struct - include Lattice.Lift2 (GMutex) (GThread) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GMutex) (GThread) (Printable.DefaultNames) let mutex = function | `Bot -> GMutex.bot () diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index ee050f55ca..1b52f5dd40 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -132,7 +132,7 @@ struct module G = struct - include Lattice.Lift2 (GProtecting) (GProtected) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GProtecting) (GProtected) (Printable.DefaultNames) let protecting = function | `Bot -> GProtecting.bot () diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 9c2272fabb..241bcb14f8 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -194,7 +194,7 @@ struct module G = struct - include Lattice.Lift2 (OffsetTrie) (MemoSet) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (OffsetTrie) (MemoSet) (Printable.DefaultNames) let access = function | `Bot -> OffsetTrie.bot () diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index 8311dd2ef0..882cb30bf5 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -370,7 +370,7 @@ struct let relift = Option.map Base.relift end -module Lift2 (Base1: S) (Base2: S) (N: LiftingNames) = +module Lift2Conf (Conf: EitherConf) (Base1: S) (Base2: S) (N: LiftingNames) = struct type t = [`Bot | `Lifted1 of Base1.t | `Lifted2 of Base2.t | `Top] [@@deriving eq, ord, hash] include Std @@ -378,6 +378,7 @@ struct let pretty () (state:t) = match state with + (* TODO: expand *) | `Lifted1 n -> Base1.pretty () n | `Lifted2 n -> Base2.pretty () n | `Bot -> text bot_name @@ -385,6 +386,7 @@ struct let show state = match state with + (* TODO: expand *) | `Lifted1 n -> Base1.show n | `Lifted2 n -> Base2.show n | `Bot -> bot_name @@ -399,16 +401,22 @@ struct let printXml f = function | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.bot_name | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.top_name - | `Lifted1 x -> BatPrintf.fprintf f "\n\n\nLifted1\n\n%a\n\n" Base1.printXml x - | `Lifted2 x -> BatPrintf.fprintf f "\n\n\nLifted2\n\n%a\n\n" Base2.printXml x + | `Lifted1 x when Conf.expand1 -> BatPrintf.fprintf f "\n\n\nLifted1\n\n%a\n\n" Base1.printXml x + | `Lifted1 x -> Base1.printXml f x + | `Lifted2 x when Conf.expand2 -> BatPrintf.fprintf f "\n\n\nLifted2\n\n%a\n\n" Base2.printXml x + | `Lifted2 x -> Base2.printXml f x let to_yojson = function | `Bot -> `String N.bot_name | `Top -> `String N.top_name - | `Lifted1 x -> `Assoc [ Base1.name (), Base1.to_yojson x ] - | `Lifted2 x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Lifted1 x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] + | `Lifted1 x -> Base1.to_yojson x + | `Lifted2 x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Lifted2 x -> Base2.to_yojson x end +module Lift2 = Lift2Conf (struct let expand1 = true let expand2 = true end) + module type ProdConfiguration = sig val expand_fst: bool diff --git a/src/domain/lattice.ml b/src/domain/lattice.ml index 9ea3f74635..448f801ec1 100644 --- a/src/domain/lattice.ml +++ b/src/domain/lattice.ml @@ -336,9 +336,9 @@ struct | _ -> x end -module Lift2 (Base1: S) (Base2: S) (N: Printable.LiftingNames) = +module Lift2Conf (Conf: Printable.EitherConf) (Base1: S) (Base2: S) (N: Printable.LiftingNames) = struct - include Printable.Lift2 (Base1) (Base2) (N) + include Printable.Lift2Conf (Conf) (Base1) (Base2) (N) let bot () = `Bot let is_bot x = x = `Bot @@ -408,6 +408,8 @@ struct end +module Lift2 = Lift2Conf (struct let expand1 = true let expand2 = true end) + module ProdConf (C: Printable.ProdConfiguration) (Base1: S) (Base2: S) = struct include Printable.ProdConf (C) (Base1) (Base2) From b71518c7d51ab0bf9444d062ff305895ede10e73 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 16:18:03 +0200 Subject: [PATCH 197/233] Refactor Printable.LiftingNames --- src/analyses/base.ml | 2 +- src/analyses/basePriv.ml | 2 +- src/analyses/commonPriv.ml | 2 +- src/analyses/loopTermination.ml | 2 +- src/analyses/mCPRegistry.ml | 2 +- src/analyses/mutexAnalysis.ml | 2 +- src/analyses/raceAnalysis.ml | 2 +- src/analyses/threadId.ml | 2 +- src/analyses/tutorials/signs.ml | 2 +- src/analyses/wrapperFunctionAnalysis0.ml | 5 +- src/cdomains/intDomain.ml | 10 ++-- src/cdomains/mutexAttrDomain.ml | 2 +- src/cdomains/regionDomain.ml | 2 +- src/cdomains/stackDomain.ml | 2 +- src/cdomains/threadIdDomain.ml | 5 +- src/cdomains/unionDomain.ml | 5 +- src/common/domains/printable.ml | 60 ++++++++++++++---------- src/domain/boolDomain.ml | 5 +- src/domain/lattice.ml | 18 +++---- src/domains/invariant.ml | 3 +- src/domains/queries.ml | 15 +++--- src/domains/valueDomainQueries.ml | 2 +- src/framework/analyses.ml | 9 ++-- src/framework/constraints.ml | 12 ++--- src/util/library/libraryDesc.ml | 5 +- src/witness/observerAnalysis.ml | 2 +- 26 files changed, 101 insertions(+), 79 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 8c4bb67b0b..92ddf3f12b 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -54,7 +54,7 @@ struct module G = struct - include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (Priv.G) (VD) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (Priv.G) (VD) let priv = function | `Bot -> Priv.G.bot () diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index b486dfd552..10deaa4d16 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -799,7 +799,7 @@ struct struct (* weak: G -> (2^M -> WeakRange) *) (* sync: M -> (2^M -> SyncRange) *) - include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GWeak) (GSync) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GWeak) (GSync) let weak = function | `Bot -> GWeak.bot () diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 1bf03581c2..35b801e32b 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -198,7 +198,7 @@ struct module G = struct - include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GMutex) (GThread) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GMutex) (GThread) let mutex = function | `Bot -> GMutex.bot () diff --git a/src/analyses/loopTermination.ml b/src/analyses/loopTermination.ml index 10e0f5c5f4..66cbd5772f 100644 --- a/src/analyses/loopTermination.ml +++ b/src/analyses/loopTermination.ml @@ -19,7 +19,7 @@ let check_bounded ctx varinfo = (** We want to record termination information of loops and use the loop * statements for that. We use this lifting because we need to have a * lattice. *) -module Statements = Lattice.Flat (CilType.Stmt) (Printable.DefaultNames) +module Statements = Lattice.Flat (Printable.DefaultConf) (CilType.Stmt) (** The termination analysis considering loops and gotos *) module Spec : Analyses.MCPSpec = diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index 5d0174d44c..a685b31798 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -426,7 +426,7 @@ end module DomVariantLattice (DLSpec : DomainListLatticeSpec) = struct - include Lattice.Lift (DomVariantLattice0 (DLSpec)) (Printable.DefaultNames) + include Lattice.Lift (Printable.DefaultConf) (DomVariantLattice0 (DLSpec)) let name () = "MCP.G" end diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index 1b52f5dd40..a13c8d6bfd 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -132,7 +132,7 @@ struct module G = struct - include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (GProtecting) (GProtected) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GProtecting) (GProtected) let protecting = function | `Bot -> GProtecting.bot () diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 241bcb14f8..f35e6756a1 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -194,7 +194,7 @@ struct module G = struct - include Lattice.Lift2Conf (struct let expand1 = false let expand2 = false end) (OffsetTrie) (MemoSet) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (OffsetTrie) (MemoSet) let access = function | `Bot -> OffsetTrie.bot () diff --git a/src/analyses/threadId.ml b/src/analyses/threadId.ml index da2c688ad1..f954077836 100644 --- a/src/analyses/threadId.ml +++ b/src/analyses/threadId.ml @@ -31,7 +31,7 @@ struct module N = struct - include Lattice.Flat (VNI) (struct let bot_name = "unknown node" let top_name = "unknown node" end) + include Lattice.Flat (struct include Printable.DefaultConf let bot_name = "unknown node" let top_name = "unknown node" end) (VNI) let name () = "wrapper call" end module TD = Thread.D diff --git a/src/analyses/tutorials/signs.ml b/src/analyses/tutorials/signs.ml index 31168df86a..6ba720d0ea 100644 --- a/src/analyses/tutorials/signs.ml +++ b/src/analyses/tutorials/signs.ml @@ -36,7 +36,7 @@ end * We then lift the above operations to the lattice. *) module SL = struct - include Lattice.Flat (Signs) (Printable.DefaultNames) + include Lattice.Flat (Printable.DefaultConf) (Signs) let of_int i = `Lifted (Signs.of_int i) let lt x y = match x, y with diff --git a/src/analyses/wrapperFunctionAnalysis0.ml b/src/analyses/wrapperFunctionAnalysis0.ml index 9ea9c0c9aa..ba04c7ed7f 100644 --- a/src/analyses/wrapperFunctionAnalysis0.ml +++ b/src/analyses/wrapperFunctionAnalysis0.ml @@ -36,7 +36,8 @@ module ThreadCreateUniqueCount = MakeUniqueCount (val unique_count_args_from_config "ana.thread.unique_thread_id_count") (* since the query also references NodeFlatLattice, it also needs to reside here *) -module NodeFlatLattice = Lattice.Flat (Node) (struct +module NodeFlatLattice = Lattice.Flat (struct + include Printable.DefaultConf let top_name = "Unknown node" let bot_name = "Unreachable node" - end) + end) (Node) diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 5d5174744f..23f4d88e25 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -1713,10 +1713,11 @@ end module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) struct type int_t = Base.int_t - include Lattice.Flat (Base) (struct + include Lattice.Flat (struct + include Printable.DefaultConf let top_name = "Unknown int" let bot_name = "Error int" - end) + end) (Base) let top_of ik = top () let bot_of ik = bot () @@ -1792,10 +1793,11 @@ end module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) struct - include Lattice.LiftPO (Base) (struct + include Lattice.LiftPO (struct + include Printable.DefaultConf let top_name = "MaxInt" let bot_name = "MinInt" - end) + end) (Base) type int_t = Base.int_t let top_of ik = top () let bot_of ik = bot () diff --git a/src/cdomains/mutexAttrDomain.ml b/src/cdomains/mutexAttrDomain.ml index 748ede0ff5..b7c18a3cae 100644 --- a/src/cdomains/mutexAttrDomain.ml +++ b/src/cdomains/mutexAttrDomain.ml @@ -18,7 +18,7 @@ struct end) end -include Lattice.Flat(MutexKind) (struct let bot_name = "Uninitialized" let top_name = "Top" end) +include Lattice.Flat (struct include Printable.DefaultConf let bot_name = "Uninitialized" let top_name = "Top" end) (MutexKind) (* Needed because OS X is weird and assigns different constants than normal systems... :( *) let recursive_int = lazy ( diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index 681eb79007..b0f8d5d57e 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -252,4 +252,4 @@ struct end (* TODO: remove Lift *) -module RegionDom = Lattice.Lift (RegMap) (struct let top_name = "Unknown" let bot_name = "Error" end) +module RegionDom = Lattice.Lift (struct include Printable.DefaultConf let top_name = "Unknown" let bot_name = "Error" end) (RegMap) diff --git a/src/cdomains/stackDomain.ml b/src/cdomains/stackDomain.ml index 3a83c78503..bd77a7d82f 100644 --- a/src/cdomains/stackDomain.ml +++ b/src/cdomains/stackDomain.ml @@ -30,7 +30,7 @@ struct module VarLat = Lattice.Fake (Basetype.Variables) - module Var = Lattice.Lift (VarLat) (struct let top_name="top" let bot_name="⊥" end) + module Var = Lattice.Lift (struct include Printable.DefaultConf let top_name="top" let bot_name="⊥" end) (VarLat) include Lattice.Liszt (Var) let top () : t = [] diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index d0c3f7b61b..ed9ad2c854 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -196,12 +196,13 @@ struct end module ThreadLiftNames = struct + include Printable.DefaultConf let bot_name = "Bot Threads" let top_name = "Top Threads" end module Lift (Thread: S) = struct - include Lattice.Flat (Thread) (ThreadLiftNames) + include Lattice.Flat (ThreadLiftNames) (Thread) let name () = "Thread" end @@ -217,7 +218,7 @@ struct let name = "FlagConfiguredTID" end) - module D = Lattice.Lift2(H.D)(P.D)(struct let bot_name = "bot" let top_name = "top" end) + module D = Lattice.Lift2 (H.D) (P.D) let history_enabled () = match GobConfig.get_string "ana.thread.domain" with diff --git a/src/cdomains/unionDomain.ml b/src/cdomains/unionDomain.ml index ac25450c6a..9871b95e1b 100644 --- a/src/cdomains/unionDomain.ml +++ b/src/cdomains/unionDomain.ml @@ -16,10 +16,11 @@ sig end module Field = struct - include Lattice.Flat (CilType.Fieldinfo) (struct + include Lattice.Flat (struct + include Printable.DefaultConf let top_name = "Unknown field" let bot_name = "If you see this, you are special!" - end) + end) (CilType.Fieldinfo) let meet f g = if equal f g then diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index 882cb30bf5..d52f6a4d2a 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -103,18 +103,6 @@ struct end module Unit = UnitConf (struct let name = "()" end) -module type LiftingNames = -sig - val bot_name: string - val top_name: string -end - -module DefaultNames = -struct - let bot_name = "bot" - let top_name = "top" -end - (* HAS SIDE-EFFECTS ---- PLEASE INSTANCIATE ONLY ONCE!!! *) module HConsed (Base:S) = struct @@ -195,11 +183,27 @@ struct let tag = lift_f M.tag end -module Lift (Base: S) (N: LiftingNames) = + +module type LiftConf = +sig + val bot_name: string + val top_name: string + val expand1: bool +end + +module DefaultConf = +struct + let bot_name = "bot" + let top_name = "top" + let expand1 = true + let expand2 = true +end + +module LiftConf (Conf: LiftConf) (Base: S) = struct type t = [`Bot | `Lifted of Base.t | `Top] [@@deriving eq, ord, hash] include Std - include N + open Conf let lift x = `Lifted x @@ -217,13 +221,13 @@ struct let name () = "lifted " ^ Base.name () let printXml f = function - | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape N.bot_name) - | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape N.top_name) + | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape bot_name) + | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape top_name) | `Lifted x -> Base.printXml f x let to_yojson = function - | `Bot -> `String N.bot_name - | `Top -> `String N.top_name + | `Bot -> `String bot_name + | `Top -> `String top_name | `Lifted x -> Base.to_yojson x let relift x = match x with @@ -370,11 +374,17 @@ struct let relift = Option.map Base.relift end -module Lift2Conf (Conf: EitherConf) (Base1: S) (Base2: S) (N: LiftingNames) = +module type Lift2Conf = +sig + include LiftConf + val expand2: bool +end + +module Lift2Conf (Conf: Lift2Conf) (Base1: S) (Base2: S) = struct type t = [`Bot | `Lifted1 of Base1.t | `Lifted2 of Base2.t | `Top] [@@deriving eq, ord, hash] include Std - include N + open Conf let pretty () (state:t) = match state with @@ -399,23 +409,23 @@ struct let name () = "lifted " ^ Base1.name () ^ " and " ^ Base2.name () let printXml f = function - | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.bot_name - | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.top_name + | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" bot_name + | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" top_name | `Lifted1 x when Conf.expand1 -> BatPrintf.fprintf f "\n\n\nLifted1\n\n%a\n\n" Base1.printXml x | `Lifted1 x -> Base1.printXml f x | `Lifted2 x when Conf.expand2 -> BatPrintf.fprintf f "\n\n\nLifted2\n\n%a\n\n" Base2.printXml x | `Lifted2 x -> Base2.printXml f x let to_yojson = function - | `Bot -> `String N.bot_name - | `Top -> `String N.top_name + | `Bot -> `String bot_name + | `Top -> `String top_name | `Lifted1 x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] | `Lifted1 x -> Base1.to_yojson x | `Lifted2 x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] | `Lifted2 x -> Base2.to_yojson x end -module Lift2 = Lift2Conf (struct let expand1 = true let expand2 = true end) +module Lift2 = Lift2Conf (DefaultConf) module type ProdConfiguration = sig diff --git a/src/domain/boolDomain.ml b/src/domain/boolDomain.ml index 08be66a602..a4bd45c052 100644 --- a/src/domain/boolDomain.ml +++ b/src/domain/boolDomain.ml @@ -41,7 +41,8 @@ struct end module FlatBool: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = - Lattice.Flat (Bool) (struct + Lattice.Flat (struct + include Printable.DefaultConf let top_name = "?" let bot_name = "-" - end) + end) (Bool) diff --git a/src/domain/lattice.ml b/src/domain/lattice.ml index 448f801ec1..0d21a1a320 100644 --- a/src/domain/lattice.ml +++ b/src/domain/lattice.ml @@ -183,9 +183,9 @@ struct let pretty_diff () ((x:t),(y:t)): Pretty.doc = M.pretty_diff () (unlift x, unlift y) end -module Flat (Base: Printable.S) (N: Printable.LiftingNames) = +module Flat (Conf: Printable.LiftConf) (Base: Printable.S) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot let top () = `Top @@ -228,9 +228,9 @@ struct end -module Lift (Base: S) (N: Printable.LiftingNames) = +module Lift (Conf: Printable.LiftConf) (Base: S) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot @@ -278,9 +278,9 @@ struct | _ -> x end -module LiftPO (Base: PO) (N: Printable.LiftingNames) = +module LiftPO (Conf: Printable.LiftConf) (Base: PO) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot @@ -336,9 +336,9 @@ struct | _ -> x end -module Lift2Conf (Conf: Printable.EitherConf) (Base1: S) (Base2: S) (N: Printable.LiftingNames) = +module Lift2Conf (Conf: Printable.Lift2Conf) (Base1: S) (Base2: S) = struct - include Printable.Lift2Conf (Conf) (Base1) (Base2) (N) + include Printable.Lift2Conf (Conf) (Base1) (Base2) let bot () = `Bot let is_bot x = x = `Bot @@ -408,7 +408,7 @@ struct end -module Lift2 = Lift2Conf (struct let expand1 = true let expand2 = true end) +module Lift2 = Lift2Conf (Printable.DefaultConf) module ProdConf (C: Printable.ProdConfiguration) (Base1: S) (Base2: S) = struct diff --git a/src/domains/invariant.ml b/src/domains/invariant.ml index 1a0c3c033c..d719f8b9c1 100644 --- a/src/domains/invariant.ml +++ b/src/domains/invariant.ml @@ -28,11 +28,12 @@ end module N = struct + include Printable.DefaultConf let bot_name = "false" let top_name = "true" end -include Lattice.Lift (ExpLat) (N) +include Lattice.Lift (N) (ExpLat) let none = top () let of_exp = lift diff --git a/src/domains/queries.ml b/src/domains/queries.ml index 228320bef3..526e82cb5e 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -17,26 +17,29 @@ module TC = WrapperFunctionAnalysis0.ThreadCreateUniqueCount module ThreadNodeLattice = Lattice.Prod (NFL) (TC) module ML = LibraryDesc.MathLifted -module VI = Lattice.Flat (Basetype.Variables) (struct +module VI = Lattice.Flat (struct + include Printable.DefaultConf let top_name = "Unknown line" let bot_name = "Unreachable line" - end) + end) (Basetype.Variables) type iterprevvar = int -> (MyCFG.node * Obj.t * int) -> MyARG.inline_edge -> unit type itervar = int -> unit let compare_itervar _ _ = 0 let compare_iterprevvar _ _ = 0 -module FlatYojson = Lattice.Flat (Printable.Yojson) (struct +module FlatYojson = Lattice.Flat (struct + include Printable.DefaultConf let top_name = "top yojson" let bot_name = "bot yojson" - end) + end) (Printable.Yojson) module SD: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = - Lattice.Flat (Basetype.RawStrings) (struct + Lattice.Flat (struct + include Printable.DefaultConf let top_name = "?" let bot_name = "-" - end) + end) (Basetype.RawStrings) module VD = ValueDomain.Compound module AD = ValueDomain.AD diff --git a/src/domains/valueDomainQueries.ml b/src/domains/valueDomainQueries.ml index 8266582ac2..b7644a32ed 100644 --- a/src/domains/valueDomainQueries.ml +++ b/src/domains/valueDomainQueries.ml @@ -9,7 +9,7 @@ module AD = PreValueDomain.AD module ID = struct module I = IntDomain.IntDomTuple - include Lattice.Lift (I) (Printable.DefaultNames) + include Lattice.Lift (Printable.DefaultConf) (I) let lift op x = `Lifted (op x) let unlift op x = match x with diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 44f1f1894e..6734b67121 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -117,7 +117,7 @@ struct let name () = "contexts" end - include Lattice.Lift2 (G) (CSet) (Printable.DefaultNames) + include Lattice.Lift2 (G) (CSet) let spec = function | `Bot -> G.bot () @@ -142,10 +142,11 @@ exception Deadcode (** [Dom (D)] produces D lifted where bottom means dead-code *) module Dom (LD: Lattice.S) = struct - include Lattice.Lift (LD) (struct + include Lattice.Lift (struct + include Printable.DefaultConf let bot_name = "Dead code" let top_name = "Totally unknown and messed up" - end) + end) (LD) let lift (x:LD.t) : t = `Lifted x @@ -155,7 +156,7 @@ struct | _ -> raise Deadcode let printXml f = function - | `Top -> BatPrintf.fprintf f "%s" (XmlUtil.escape top_name) + | `Top -> BatPrintf.fprintf f "%s" (XmlUtil.escape Printable.DefaultConf.top_name) | `Bot -> () | `Lifted x -> LD.printXml f x end diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index ee1ea00a01..8039a867d8 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1075,15 +1075,15 @@ module EqIncrSolverFromEqSolver (Sol: GenericEqSolver): GenericEqIncrSolver = (** Translate a [GlobConstrSys] into a [EqConstrSys] *) module EqConstrSysFromGlobConstrSys (S:GlobConstrSys) : EqConstrSys with type v = Var2(S.LVar)(S.GVar).t - and type d = Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames).t + and type d = Lattice.Lift2(S.G)(S.D).t and module Var = Var2(S.LVar)(S.GVar) - and module Dom = Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames) + and module Dom = Lattice.Lift2(S.G)(S.D) = struct module Var = Var2(S.LVar)(S.GVar) module Dom = struct - include Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames) + include Lattice.Lift2 (S.G) (S.D) let printXml f = function | `Lifted1 a -> S.G.printXml f a | `Lifted2 a -> S.D.printXml f a @@ -1355,7 +1355,7 @@ struct module G = struct - include Lattice.Lift2 (S.G) (EM) (Printable.DefaultNames) + include Lattice.Lift2 (S.G) (EM) let name () = "deadbranch" let s = function @@ -1484,7 +1484,7 @@ struct module G = struct - include Lattice.Lift2 (S.G) (S.D) (Printable.DefaultNames) + include Lattice.Lift2 (S.G) (S.D) let s = function | `Bot -> S.G.bot () @@ -1737,7 +1737,7 @@ struct module G = struct - include Lattice.Lift2 (G) (CallerSet) (Printable.DefaultNames) + include Lattice.Lift2 (G) (CallerSet) let spec = function | `Bot -> G.bot () diff --git a/src/util/library/libraryDesc.ml b/src/util/library/libraryDesc.ml index 4997b306a9..a07c0ee27f 100644 --- a/src/util/library/libraryDesc.ml +++ b/src/util/library/libraryDesc.ml @@ -184,7 +184,8 @@ module MathPrintable = struct ) end -module MathLifted = Lattice.Flat (MathPrintable) (struct +module MathLifted = Lattice.Flat (struct + include Printable.DefaultConf let top_name = "Unknown or no math desc" let bot_name = "Nonexistent math desc" - end) + end) (MathPrintable) diff --git a/src/witness/observerAnalysis.ml b/src/witness/observerAnalysis.ml index e8daf56155..d4af989ebc 100644 --- a/src/witness/observerAnalysis.ml +++ b/src/witness/observerAnalysis.ml @@ -29,7 +29,7 @@ struct let n () = -1 let names x = "state " ^ string_of_int x end - module D = Lattice.Flat (Printable.Chain (ChainParams)) (Printable.DefaultNames) + module D = Lattice.Flat (Printable.DefaultConf) (Printable.Chain (ChainParams)) module C = D module P = IdentityP (D) (* fully path-sensitive *) From ea029bc5b13f1a50772c7d053ad0aec0e2cec8cc Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 14 Dec 2023 16:29:23 +0200 Subject: [PATCH 198/233] Simplify default Lattice.Flat usage --- src/analyses/loopTermination.ml | 2 +- src/analyses/mCPRegistry.ml | 2 +- src/analyses/threadId.ml | 2 +- src/analyses/tutorials/signs.ml | 2 +- src/analyses/wrapperFunctionAnalysis0.ml | 2 +- src/cdomains/intDomain.ml | 2 +- src/cdomains/mutexAttrDomain.ml | 2 +- src/cdomains/regionDomain.ml | 2 +- src/cdomains/stackDomain.ml | 2 +- src/cdomains/threadIdDomain.ml | 2 +- src/cdomains/unionDomain.ml | 2 +- src/common/domains/printable.ml | 7 +++---- src/domain/boolDomain.ml | 2 +- src/domain/lattice.ml | 8 ++++++-- src/domains/invariant.ml | 2 +- src/domains/queries.ml | 18 +++--------------- src/domains/valueDomainQueries.ml | 2 +- src/framework/analyses.ml | 2 +- src/util/library/libraryDesc.ml | 2 +- src/witness/observerAnalysis.ml | 2 +- 20 files changed, 29 insertions(+), 38 deletions(-) diff --git a/src/analyses/loopTermination.ml b/src/analyses/loopTermination.ml index 66cbd5772f..857b6189d0 100644 --- a/src/analyses/loopTermination.ml +++ b/src/analyses/loopTermination.ml @@ -19,7 +19,7 @@ let check_bounded ctx varinfo = (** We want to record termination information of loops and use the loop * statements for that. We use this lifting because we need to have a * lattice. *) -module Statements = Lattice.Flat (Printable.DefaultConf) (CilType.Stmt) +module Statements = Lattice.Flat (CilType.Stmt) (** The termination analysis considering loops and gotos *) module Spec : Analyses.MCPSpec = diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index a685b31798..663a1d8862 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -426,7 +426,7 @@ end module DomVariantLattice (DLSpec : DomainListLatticeSpec) = struct - include Lattice.Lift (Printable.DefaultConf) (DomVariantLattice0 (DLSpec)) + include Lattice.Lift (DomVariantLattice0 (DLSpec)) let name () = "MCP.G" end diff --git a/src/analyses/threadId.ml b/src/analyses/threadId.ml index f954077836..86e7f770a8 100644 --- a/src/analyses/threadId.ml +++ b/src/analyses/threadId.ml @@ -31,7 +31,7 @@ struct module N = struct - include Lattice.Flat (struct include Printable.DefaultConf let bot_name = "unknown node" let top_name = "unknown node" end) (VNI) + include Lattice.FlatConf (struct include Printable.DefaultConf let bot_name = "unknown node" let top_name = "unknown node" end) (VNI) let name () = "wrapper call" end module TD = Thread.D diff --git a/src/analyses/tutorials/signs.ml b/src/analyses/tutorials/signs.ml index 6ba720d0ea..2c26ad33b6 100644 --- a/src/analyses/tutorials/signs.ml +++ b/src/analyses/tutorials/signs.ml @@ -36,7 +36,7 @@ end * We then lift the above operations to the lattice. *) module SL = struct - include Lattice.Flat (Printable.DefaultConf) (Signs) + include Lattice.Flat (Signs) let of_int i = `Lifted (Signs.of_int i) let lt x y = match x, y with diff --git a/src/analyses/wrapperFunctionAnalysis0.ml b/src/analyses/wrapperFunctionAnalysis0.ml index ba04c7ed7f..cd5940011e 100644 --- a/src/analyses/wrapperFunctionAnalysis0.ml +++ b/src/analyses/wrapperFunctionAnalysis0.ml @@ -36,7 +36,7 @@ module ThreadCreateUniqueCount = MakeUniqueCount (val unique_count_args_from_config "ana.thread.unique_thread_id_count") (* since the query also references NodeFlatLattice, it also needs to reside here *) -module NodeFlatLattice = Lattice.Flat (struct +module NodeFlatLattice = Lattice.FlatConf (struct include Printable.DefaultConf let top_name = "Unknown node" let bot_name = "Unreachable node" diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 23f4d88e25..376dab71c2 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -1713,7 +1713,7 @@ end module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) struct type int_t = Base.int_t - include Lattice.Flat (struct + include Lattice.FlatConf (struct include Printable.DefaultConf let top_name = "Unknown int" let bot_name = "Error int" diff --git a/src/cdomains/mutexAttrDomain.ml b/src/cdomains/mutexAttrDomain.ml index b7c18a3cae..ea9696d26f 100644 --- a/src/cdomains/mutexAttrDomain.ml +++ b/src/cdomains/mutexAttrDomain.ml @@ -18,7 +18,7 @@ struct end) end -include Lattice.Flat (struct include Printable.DefaultConf let bot_name = "Uninitialized" let top_name = "Top" end) (MutexKind) +include Lattice.FlatConf (struct include Printable.DefaultConf let bot_name = "Uninitialized" let top_name = "Top" end) (MutexKind) (* Needed because OS X is weird and assigns different constants than normal systems... :( *) let recursive_int = lazy ( diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index b0f8d5d57e..26a89f1013 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -252,4 +252,4 @@ struct end (* TODO: remove Lift *) -module RegionDom = Lattice.Lift (struct include Printable.DefaultConf let top_name = "Unknown" let bot_name = "Error" end) (RegMap) +module RegionDom = Lattice.LiftConf (struct include Printable.DefaultConf let top_name = "Unknown" let bot_name = "Error" end) (RegMap) diff --git a/src/cdomains/stackDomain.ml b/src/cdomains/stackDomain.ml index bd77a7d82f..50864d6294 100644 --- a/src/cdomains/stackDomain.ml +++ b/src/cdomains/stackDomain.ml @@ -30,7 +30,7 @@ struct module VarLat = Lattice.Fake (Basetype.Variables) - module Var = Lattice.Lift (struct include Printable.DefaultConf let top_name="top" let bot_name="⊥" end) (VarLat) + module Var = Lattice.LiftConf (struct include Printable.DefaultConf let top_name="top" let bot_name="⊥" end) (VarLat) include Lattice.Liszt (Var) let top () : t = [] diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index ed9ad2c854..c21bb40628 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -202,7 +202,7 @@ module ThreadLiftNames = struct end module Lift (Thread: S) = struct - include Lattice.Flat (ThreadLiftNames) (Thread) + include Lattice.FlatConf (ThreadLiftNames) (Thread) let name () = "Thread" end diff --git a/src/cdomains/unionDomain.ml b/src/cdomains/unionDomain.ml index 9871b95e1b..ad5c531061 100644 --- a/src/cdomains/unionDomain.ml +++ b/src/cdomains/unionDomain.ml @@ -16,7 +16,7 @@ sig end module Field = struct - include Lattice.Flat (struct + include Lattice.FlatConf (struct include Printable.DefaultConf let top_name = "Unknown field" let bot_name = "If you see this, you are special!" diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index d52f6a4d2a..37dd88f9ac 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -197,6 +197,7 @@ struct let top_name = "top" let expand1 = true let expand2 = true + let expand3 = true end module LiftConf (Conf: LiftConf) (Base: S) = @@ -291,7 +292,7 @@ struct | `Right x -> `Right (Base2.relift x) end -module Either = EitherConf (struct let expand1 = true let expand2 = true end) +module Either = EitherConf (DefaultConf) module type Either3Conf = sig @@ -345,7 +346,7 @@ struct | `Right x -> `Right (Base3.relift x) end -module Either3 = Either3Conf (struct let expand1 = true let expand2 = true let expand3 = true end) +module Either3 = Either3Conf (DefaultConf) module Option (Base: S) (N: Name) = struct @@ -425,8 +426,6 @@ struct | `Lifted2 x -> Base2.to_yojson x end -module Lift2 = Lift2Conf (DefaultConf) - module type ProdConfiguration = sig val expand_fst: bool diff --git a/src/domain/boolDomain.ml b/src/domain/boolDomain.ml index a4bd45c052..d92d716d7a 100644 --- a/src/domain/boolDomain.ml +++ b/src/domain/boolDomain.ml @@ -41,7 +41,7 @@ struct end module FlatBool: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = - Lattice.Flat (struct + Lattice.FlatConf (struct include Printable.DefaultConf let top_name = "?" let bot_name = "-" diff --git a/src/domain/lattice.ml b/src/domain/lattice.ml index 0d21a1a320..99322c09d8 100644 --- a/src/domain/lattice.ml +++ b/src/domain/lattice.ml @@ -183,7 +183,7 @@ struct let pretty_diff () ((x:t),(y:t)): Pretty.doc = M.pretty_diff () (unlift x, unlift y) end -module Flat (Conf: Printable.LiftConf) (Base: Printable.S) = +module FlatConf (Conf: Printable.LiftConf) (Base: Printable.S) = struct include Printable.LiftConf (Conf) (Base) let bot () = `Bot @@ -227,8 +227,10 @@ struct end +module Flat = FlatConf (Printable.DefaultConf) -module Lift (Conf: Printable.LiftConf) (Base: S) = + +module LiftConf (Conf: Printable.LiftConf) (Base: S) = struct include Printable.LiftConf (Conf) (Base) @@ -278,6 +280,8 @@ struct | _ -> x end +module Lift = LiftConf (Printable.DefaultConf) + module LiftPO (Conf: Printable.LiftConf) (Base: PO) = struct include Printable.LiftConf (Conf) (Base) diff --git a/src/domains/invariant.ml b/src/domains/invariant.ml index d719f8b9c1..b281e8f7b3 100644 --- a/src/domains/invariant.ml +++ b/src/domains/invariant.ml @@ -33,7 +33,7 @@ struct let top_name = "true" end -include Lattice.Lift (N) (ExpLat) +include Lattice.LiftConf (N) (ExpLat) let none = top () let of_exp = lift diff --git a/src/domains/queries.ml b/src/domains/queries.ml index 526e82cb5e..24e5d45593 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -17,29 +17,17 @@ module TC = WrapperFunctionAnalysis0.ThreadCreateUniqueCount module ThreadNodeLattice = Lattice.Prod (NFL) (TC) module ML = LibraryDesc.MathLifted -module VI = Lattice.Flat (struct - include Printable.DefaultConf - let top_name = "Unknown line" - let bot_name = "Unreachable line" - end) (Basetype.Variables) +module VI = Lattice.Flat (Basetype.Variables) type iterprevvar = int -> (MyCFG.node * Obj.t * int) -> MyARG.inline_edge -> unit type itervar = int -> unit let compare_itervar _ _ = 0 let compare_iterprevvar _ _ = 0 -module FlatYojson = Lattice.Flat (struct - include Printable.DefaultConf - let top_name = "top yojson" - let bot_name = "bot yojson" - end) (Printable.Yojson) +module FlatYojson = Lattice.Flat (Printable.Yojson) module SD: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = - Lattice.Flat (struct - include Printable.DefaultConf - let top_name = "?" - let bot_name = "-" - end) (Basetype.RawStrings) + Lattice.Flat (Basetype.RawStrings) module VD = ValueDomain.Compound module AD = ValueDomain.AD diff --git a/src/domains/valueDomainQueries.ml b/src/domains/valueDomainQueries.ml index b7644a32ed..bafec3f8bd 100644 --- a/src/domains/valueDomainQueries.ml +++ b/src/domains/valueDomainQueries.ml @@ -9,7 +9,7 @@ module AD = PreValueDomain.AD module ID = struct module I = IntDomain.IntDomTuple - include Lattice.Lift (Printable.DefaultConf) (I) + include Lattice.Lift (I) let lift op x = `Lifted (op x) let unlift op x = match x with diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 6734b67121..405df5b6a6 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -142,7 +142,7 @@ exception Deadcode (** [Dom (D)] produces D lifted where bottom means dead-code *) module Dom (LD: Lattice.S) = struct - include Lattice.Lift (struct + include Lattice.LiftConf (struct include Printable.DefaultConf let bot_name = "Dead code" let top_name = "Totally unknown and messed up" diff --git a/src/util/library/libraryDesc.ml b/src/util/library/libraryDesc.ml index a07c0ee27f..78a72b1741 100644 --- a/src/util/library/libraryDesc.ml +++ b/src/util/library/libraryDesc.ml @@ -184,7 +184,7 @@ module MathPrintable = struct ) end -module MathLifted = Lattice.Flat (struct +module MathLifted = Lattice.FlatConf (struct include Printable.DefaultConf let top_name = "Unknown or no math desc" let bot_name = "Nonexistent math desc" diff --git a/src/witness/observerAnalysis.ml b/src/witness/observerAnalysis.ml index d4af989ebc..58b5b31fe4 100644 --- a/src/witness/observerAnalysis.ml +++ b/src/witness/observerAnalysis.ml @@ -29,7 +29,7 @@ struct let n () = -1 let names x = "state " ^ string_of_int x end - module D = Lattice.Flat (Printable.DefaultConf) (Printable.Chain (ChainParams)) + module D = Lattice.Flat (Printable.Chain (ChainParams)) module C = D module P = IdentityP (D) (* fully path-sensitive *) From 838a17baf93a1e3008fc0262f1921529ba03ab52 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Thu, 14 Dec 2023 20:57:46 +0000 Subject: [PATCH 199/233] Bump actions/upload-artifact from 3 to 4 Bumps [actions/upload-artifact](https://github.com/actions/upload-artifact) from 3 to 4. - [Release notes](https://github.com/actions/upload-artifact/releases) - [Commits](https://github.com/actions/upload-artifact/compare/v3...v4) --- updated-dependencies: - dependency-name: actions/upload-artifact dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/coverage.yml | 2 +- .github/workflows/locked.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 0208af7c7a..4b47a66e15 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -88,7 +88,7 @@ jobs: COVERALLS_REPO_TOKEN: ${{ secrets.COVERALLS_REPO_TOKEN }} PULL_REQUEST_NUMBER: ${{ github.event.number }} - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: always() with: name: suite_result diff --git a/.github/workflows/locked.yml b/.github/workflows/locked.yml index 8604e7f52c..ab9385c737 100644 --- a/.github/workflows/locked.yml +++ b/.github/workflows/locked.yml @@ -82,7 +82,7 @@ jobs: - name: Test incremental regression with cfg comparison run: ruby scripts/update_suite.rb -c - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: always() with: name: suite_result From dceb4bea539b167647066346679cab4a0e168987 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 10:56:20 +0200 Subject: [PATCH 200/233] Extract Printable.PrefixName functor to deduplicate expand code --- src/common/domains/printable.ml | 77 ++++++++++++++++++++++----------- 1 file changed, 51 insertions(+), 26 deletions(-) diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index 37dd88f9ac..7e08157898 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -184,6 +184,41 @@ struct end +module type PrefixNameConf = +sig + val expand: bool +end + +module PrefixName (Conf: PrefixNameConf) (Base: S): S with type t = Base.t = +struct + include Base + + let pretty () x = + if Conf.expand then + Pretty.dprintf "%s:%a" (Base.name ()) Base.pretty x + else + Base.pretty () x + + let show x = + if Conf.expand then + Base.name () ^ ":" ^ Base.show x + else + Base.show x + + let printXml f x = + if Conf.expand then + BatPrintf.fprintf f "\n\n%s\n\n%a\n\n" (Base.name ()) Base.printXml x + else + Base.printXml f x + + let to_yojson x = + if Conf.expand then + `Assoc [(Base.name (), Base.to_yojson x)] + else + Base.to_yojson x +end + + module type LiftConf = sig val bot_name: string @@ -257,34 +292,31 @@ end module EitherConf (Conf: EitherConf) (Base1: S) (Base2: S) = struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + end + type t = [`Left of Base1.t | `Right of Base2.t] [@@deriving eq, ord, hash] include Std let pretty () (state:t) = match state with - | `Left n when Conf.expand1 -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n | `Left n -> Base1.pretty () n - | `Right n when Conf.expand2 -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n | `Right n -> Base2.pretty () n let show state = match state with - | `Left n when Conf.expand1 -> (Base1.name ()) ^ ":" ^ Base1.show n | `Left n -> Base1.show n - | `Right n when Conf.expand2 -> (Base2.name ()) ^ ":" ^ Base2.show n | `Right n -> Base2.show n let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () let printXml f = function - | `Left x when Conf.expand1 -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x | `Left x -> Base1.printXml f x - | `Right x when Conf.expand2 -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base2.printXml x | `Right x -> Base2.printXml f x let to_yojson = function - | `Left x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] | `Left x -> Base1.to_yojson x - | `Right x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] | `Right x -> Base2.to_yojson x let relift = function @@ -302,42 +334,36 @@ end module Either3Conf (Conf: Either3Conf) (Base1: S) (Base2: S) (Base3: S) = struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + module Base3 = PrefixName (struct let expand = Conf.expand3 end) (Base3) + end + type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] include Std let pretty () (state:t) = match state with - | `Left n when Conf.expand1 -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n | `Left n -> Base1.pretty () n - | `Middle n when Conf.expand2 -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n | `Middle n -> Base2.pretty () n - | `Right n when Conf.expand3 -> Pretty.dprintf "%s:%a" (Base3.name ()) Base3.pretty n | `Right n -> Base3.pretty () n let show state = match state with - | `Left n when Conf.expand1 -> (Base1.name ()) ^ ":" ^ Base1.show n | `Left n -> Base1.show n - | `Middle n when Conf.expand2 -> (Base2.name ()) ^ ":" ^ Base2.show n | `Middle n -> Base2.show n - | `Right n when Conf.expand3 -> (Base3.name ()) ^ ":" ^ Base3.show n | `Right n -> Base3.show n let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () ^ " or " ^ Base3.name () let printXml f = function - | `Left x when Conf.expand1 -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x | `Left x -> Base1.printXml f x - | `Middle x when Conf.expand2 -> BatPrintf.fprintf f "\n\nMiddle\n\n%a\n\n" Base2.printXml x | `Middle x -> Base2.printXml f x - | `Right x when Conf.expand3 -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base3.printXml x | `Right x -> Base3.printXml f x let to_yojson = function - | `Left x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] | `Left x -> Base1.to_yojson x - | `Middle x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] | `Middle x -> Base2.to_yojson x - | `Right x when Conf.expand3 -> `Assoc [ Base3.name (), Base3.to_yojson x ] | `Right x -> Base3.to_yojson x let relift = function @@ -383,13 +409,17 @@ end module Lift2Conf (Conf: Lift2Conf) (Base1: S) (Base2: S) = struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + end + type t = [`Bot | `Lifted1 of Base1.t | `Lifted2 of Base2.t | `Top] [@@deriving eq, ord, hash] include Std open Conf let pretty () (state:t) = match state with - (* TODO: expand *) | `Lifted1 n -> Base1.pretty () n | `Lifted2 n -> Base2.pretty () n | `Bot -> text bot_name @@ -397,7 +427,6 @@ struct let show state = match state with - (* TODO: expand *) | `Lifted1 n -> Base1.show n | `Lifted2 n -> Base2.show n | `Bot -> bot_name @@ -412,17 +441,13 @@ struct let printXml f = function | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" bot_name | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" top_name - | `Lifted1 x when Conf.expand1 -> BatPrintf.fprintf f "\n\n\nLifted1\n\n%a\n\n" Base1.printXml x | `Lifted1 x -> Base1.printXml f x - | `Lifted2 x when Conf.expand2 -> BatPrintf.fprintf f "\n\n\nLifted2\n\n%a\n\n" Base2.printXml x | `Lifted2 x -> Base2.printXml f x let to_yojson = function | `Bot -> `String bot_name | `Top -> `String top_name - | `Lifted1 x when Conf.expand1 -> `Assoc [ Base1.name (), Base1.to_yojson x ] | `Lifted1 x -> Base1.to_yojson x - | `Lifted2 x when Conf.expand2 -> `Assoc [ Base2.name (), Base2.to_yojson x ] | `Lifted2 x -> Base2.to_yojson x end From cc39ddd112604c30aeffef657ae1c8e6b63064d5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:05:30 +0200 Subject: [PATCH 201/233] Use Conf in Printable.LiftConf --- src/analyses/mCPRegistry.ml | 2 +- src/common/domains/printable.ml | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index 663a1d8862..3961bc4d60 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -426,7 +426,7 @@ end module DomVariantLattice (DLSpec : DomainListLatticeSpec) = struct - include Lattice.Lift (DomVariantLattice0 (DLSpec)) + include Lattice.LiftConf (struct include Printable.DefaultConf let expand1 = false end) (DomVariantLattice0 (DLSpec)) let name () = "MCP.G" end diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index 7e08157898..0b1769e99c 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -237,6 +237,10 @@ end module LiftConf (Conf: LiftConf) (Base: S) = struct + open struct + module Base = PrefixName (struct let expand = Conf.expand1 end) (Base) + end + type t = [`Bot | `Lifted of Base.t | `Top] [@@deriving eq, ord, hash] include Std open Conf From 318f2c2d787d2f41f58528f6f95329396907bf8a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:19:06 +0200 Subject: [PATCH 202/233] Do not expand MUTEX_INITS unknown --- src/analyses/commonPriv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 35b801e32b..90e5b28f82 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -83,7 +83,7 @@ struct end module V = struct - include Printable.Either3 (VMutex) (VMutexInits) (VGlobal) + include Printable.Either3Conf (struct include Printable.DefaultConf let expand2 = false end) (VMutex) (VMutexInits) (VGlobal) let name () = "MutexGlobals" let mutex x: t = `Left x let mutex_inits: t = `Middle () From c1e1632a2641def5717602bf553c5086f70d4c90 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:19:21 +0200 Subject: [PATCH 203/233] Simplify RegionDomain.VFB printing --- src/cdomains/regionDomain.ml | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index 26a89f1013..cd9141876c 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -8,23 +8,9 @@ module B = Printable.UnitConf (struct let name = "•" end) module VFB = struct - include Printable.Either (VF) (B) + include Printable.EitherConf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (VF) (B) let name () = "region" - let pretty () = function - | `Right () -> Pretty.text "•" - | `Left x -> VF.pretty () x - - let show = function - | `Right () -> "•" - | `Left x -> VF.show x - - let printXml f = function - | `Right () -> - BatPrintf.fprintf f "\n\n•\n\n\n" - | `Left x -> - BatPrintf.fprintf f "\n\n%a\n\n\n" VF.printXml x - let collapse (x:t) (y:t): bool = match x,y with | `Right (), `Right () -> true From bbe86ae4fc521aa510a7fe7952f64f9295a60086 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:27:46 +0200 Subject: [PATCH 204/233] Simplify SymbLocks.A.E printing --- src/analyses/symbLocks.ml | 12 ++++++------ src/cdomains/symbLocksDomain.ml | 1 + 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index f6fdd96c2e..c237967a7a 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -106,13 +106,12 @@ struct module A = struct - module E = struct - include Printable.Either (CilType.Offset) (ILock) - - let pretty () = function - | `Left o -> Pretty.dprintf "p-lock:%a" (d_offset (text "*")) o - | `Right addr -> Pretty.dprintf "i-lock:%a" ILock.pretty addr + module PLock = + struct + include CilType.Offset + let name () = "p-lock" + let pretty = d_offset (text "*") include Printable.SimplePretty ( struct type nonrec t = t @@ -120,6 +119,7 @@ struct end ) end + module E = Printable.Either (PLock) (ILock) include SetDomain.Make (E) let name () = "symblock" diff --git a/src/cdomains/symbLocksDomain.ml b/src/cdomains/symbLocksDomain.ml index 4a44911a53..85578d5fad 100644 --- a/src/cdomains/symbLocksDomain.ml +++ b/src/cdomains/symbLocksDomain.ml @@ -306,6 +306,7 @@ struct end include AddressDomain.AddressPrintable (Mval.MakePrintable (Offset.MakePrintable (Idx))) + let name () = "i-lock" let rec conv_const_offset x = match x with From 152b54baa51e85b54452b82011e17178f7ce00ce Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:34:18 +0200 Subject: [PATCH 205/233] Do not expand lifted thread ID --- src/cdomains/threadIdDomain.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomains/threadIdDomain.ml index c21bb40628..85f9a0297b 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomains/threadIdDomain.ml @@ -199,6 +199,7 @@ module ThreadLiftNames = struct include Printable.DefaultConf let bot_name = "Bot Threads" let top_name = "Top Threads" + let expand1 = false end module Lift (Thread: S) = struct From 1a3e00852ac5dfb10ee39958adbcc4974c11e327 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 11:44:55 +0200 Subject: [PATCH 206/233] Make locked workflow artifact names unique --- .github/workflows/locked.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/locked.yml b/.github/workflows/locked.yml index ab9385c737..e25ccfcea1 100644 --- a/.github/workflows/locked.yml +++ b/.github/workflows/locked.yml @@ -85,7 +85,7 @@ jobs: - uses: actions/upload-artifact@v4 if: always() with: - name: suite_result + name: suite_result-${{ matrix.os }} path: tests/suite_result/ extraction: From 88d4d32f761d67489a918f310bcb6809c465c9d9 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 12:05:25 +0200 Subject: [PATCH 207/233] Move SV-COMP scripts to scripts/ --- docs/developer-guide/releasing.md | 6 +++--- {sv-comp => scripts/sv-comp}/archive.sh | 4 ++-- {sv-comp => scripts/sv-comp}/sv-comp-run-no-overflow.py | 0 {sv-comp => scripts/sv-comp}/sv-comp-run.py | 0 {sv-comp => scripts/sv-comp}/witness-isomorphism.py | 0 {sv-comp => scripts/sv-comp}/yed-sv-comp.cnfx | 0 6 files changed, 5 insertions(+), 5 deletions(-) rename {sv-comp => scripts/sv-comp}/archive.sh (93%) rename {sv-comp => scripts/sv-comp}/sv-comp-run-no-overflow.py (100%) rename {sv-comp => scripts/sv-comp}/sv-comp-run.py (100%) rename {sv-comp => scripts/sv-comp}/witness-isomorphism.py (100%) rename {sv-comp => scripts/sv-comp}/yed-sv-comp.cnfx (100%) diff --git a/docs/developer-guide/releasing.md b/docs/developer-guide/releasing.md index fcf69ea533..d875c0d3bf 100644 --- a/docs/developer-guide/releasing.md +++ b/docs/developer-guide/releasing.md @@ -70,7 +70,7 @@ This is required such that the created archive would have everything in a single directory called `goblint`. -4. Update SV-COMP year in `sv-comp/archive.sh`. +4. Update SV-COMP year in `scripts/sv-comp/archive.sh`. This includes: git tag name, git tag message and zipped conf file. @@ -83,9 +83,9 @@ 2. Make sure you have nothing valuable that would be deleted by `make clean`. 3. Delete git tag from previous prerun: `git tag -d svcompXY`. -4. Create archive: `./sv-comp/archive.sh`. +4. Create archive: `./scripts/sv-comp/archive.sh`. - The resulting archive is `sv-comp/goblint.zip`. + The resulting archive is `scripts/sv-comp/goblint.zip`. 5. Check unextracted archive in latest SV-COMP container image: . diff --git a/sv-comp/archive.sh b/scripts/sv-comp/archive.sh similarity index 93% rename from sv-comp/archive.sh rename to scripts/sv-comp/archive.sh index 5d8605dc70..37fa2758d9 100755 --- a/sv-comp/archive.sh +++ b/scripts/sv-comp/archive.sh @@ -23,9 +23,9 @@ wget -O lib/LICENSE.APRON https://raw.githubusercontent.com/antoinemine/apron/ma # done outside to ensure archive contains goblint/ directory cd .. -rm goblint/sv-comp/goblint.zip +rm goblint/scripts/sv-comp/goblint.zip -zip goblint/sv-comp/goblint.zip \ +zip goblint/scripts/sv-comp/goblint.zip \ goblint/goblint \ goblint/lib/libapron.so \ goblint/lib/liboctD.so \ diff --git a/sv-comp/sv-comp-run-no-overflow.py b/scripts/sv-comp/sv-comp-run-no-overflow.py similarity index 100% rename from sv-comp/sv-comp-run-no-overflow.py rename to scripts/sv-comp/sv-comp-run-no-overflow.py diff --git a/sv-comp/sv-comp-run.py b/scripts/sv-comp/sv-comp-run.py similarity index 100% rename from sv-comp/sv-comp-run.py rename to scripts/sv-comp/sv-comp-run.py diff --git a/sv-comp/witness-isomorphism.py b/scripts/sv-comp/witness-isomorphism.py similarity index 100% rename from sv-comp/witness-isomorphism.py rename to scripts/sv-comp/witness-isomorphism.py diff --git a/sv-comp/yed-sv-comp.cnfx b/scripts/sv-comp/yed-sv-comp.cnfx similarity index 100% rename from sv-comp/yed-sv-comp.cnfx rename to scripts/sv-comp/yed-sv-comp.cnfx From b98438306a97e0a7431130d9bf1985fab526a266 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 12:17:46 +0200 Subject: [PATCH 208/233] Move SV-COMP README to documentation --- docs/user-guide/inspecting.md | 17 +++++++++++++++++ docs/user-guide/running.md | 17 +++++++++++++++++ sv-comp/README.md | 28 ---------------------------- 3 files changed, 34 insertions(+), 28 deletions(-) delete mode 100644 sv-comp/README.md diff --git a/docs/user-guide/inspecting.md b/docs/user-guide/inspecting.md index f4f6036f1b..266a4866c6 100644 --- a/docs/user-guide/inspecting.md +++ b/docs/user-guide/inspecting.md @@ -23,3 +23,20 @@ To build GobView (also for development): `./_build/default/gobview/goblint-http-server/goblint_http.exe -with-goblint ../analyzer/goblint -goblint --set files[+] "../analyzer/tests/regression/00-sanity/01-assert.c"` 4. Visit + +## Witnesses + +### GraphML + +#### yEd + +1. Open (Ctrl+o) `witness.graphml` from Goblint root directory. +2. Click menu "Edit" → "Properties Mapper". + 1. _First time:_ Click button "Imports additional configurations" and open `scripts/sv-comp/yed-sv-comp.cnfx`. + 2. Select "SV-COMP (Node)" and click "Apply". + 3. Select "SV-COMP (Edge)" and click "Ok". +3. Click menu "Layout" → "Hierarchial" (Alt+shift+h). + 1. _First time:_ Click tab "Labeling", select "Hierarchic" in "Edge Labeling". + 2. Click "Ok". + +yEd manual for the Properties Mapper: . diff --git a/docs/user-guide/running.md b/docs/user-guide/running.md index 97d2587be8..aac1c21ca6 100644 --- a/docs/user-guide/running.md +++ b/docs/user-guide/running.md @@ -67,3 +67,20 @@ Here is a list of issues and workarounds for different compilation database gene #### bear 1. Bear 2.3.11 from Ubuntu 18.04 produces incomplete database (, ). * Bear 3.0.8 seems fine. + + +## SV-COMP +The most up-to-date SV-COMP configuration is in `conf/svcomp.json`. +There are also per-year configurations (e.g. `conf/svcomp24.json`) which try to reflect that year's submission using current option names. +Due to unconfigurable changes (e.g. bug fixes) these do not _exactly_ behave as that year's submission. +See SV-COMP submissions in GitHub releases for exact submitted versions. + +In SV-COMP Goblint is run as follows: +```console +./goblint --conf conf/svcomp.json --set ana.specification property.prp --set exp.architecture {32bit,64bit} input.c +``` + +Goblint YAML correctness witness validator is run as: +```console +./goblint --conf conf/svcomp.json --set ana.specification property.prp --set exp.architecture {32bit,64bit} --set witness.yaml.unassume witness.yml --set witness.yaml.validate witness.yml input.c +``` diff --git a/sv-comp/README.md b/sv-comp/README.md deleted file mode 100644 index 9f5c203213..0000000000 --- a/sv-comp/README.md +++ /dev/null @@ -1,28 +0,0 @@ -# Goblint for SV-COMP -All the SV-COMP configuration is in `conf/svcomp.json`. - -## Run Goblint in SV-COMP mode -### ReachSafety -``` -./goblint --conf conf/svcomp.json --set ana.specification ../sv-benchmarks/c/properties/unreach-call.prp ../sv-benchmarks/c/DIR/FILE.i -``` - -### NoDataRace -``` -./goblint --conf conf/svcomp.json --set ana.specification ../sv-benchmarks/c/properties/no-data-race.prp ../sv-benchmarks/c/DIR/FILE.i -``` - - -# Inspecting witnesses -## yEd - -1. Open (Ctrl+o) `witness.graphml` from Goblint root directory. -2. Click menu "Edit" → "Properties Mapper". - 1. _First time:_ Click button "Imports additional configurations" and open `yed-sv-comp.cnfx` from this directory. - 2. Select "SV-COMP (Node)" and click "Apply". - 3. Select "SV-COMP (Edge)" and click "Ok". -3. Click menu "Layout" → "Hierarchial" (Alt+shift+h). - 1. _First time:_ Click tab "Labeling", select "Hierarchic" in "Edge Labeling". - 2. Click "Ok". - -yEd manual for the Properties Mapper: https://yed.yworks.com/support/manual/properties_mapper.html. From cbece4fbafdf662aefbe3fd503df48e4cfc31392 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 12:18:36 +0200 Subject: [PATCH 209/233] Remove outdated my-bench-sv-comp --- sv-comp/my-bench-sv-comp/.gitignore | 1 - sv-comp/my-bench-sv-comp/README.md | 46 ------------ .../cpa-validate-correctness.xml | 25 ------- .../cpa-validate-violation.xml | 30 -------- sv-comp/my-bench-sv-comp/goblint-all-fast.sh | 26 ------- sv-comp/my-bench-sv-comp/goblint-all-fast.xml | 74 ------------------- sv-comp/my-bench-sv-comp/goblint-data-race.sh | 26 ------- .../my-bench-sv-comp/goblint-data-race.xml | 17 ----- sv-comp/my-bench-sv-comp/goblint-lint.sh | 42 ----------- sv-comp/my-bench-sv-comp/goblint-lint.xml | 68 ----------------- sv-comp/my-bench-sv-comp/goblint.sh | 63 ---------------- sv-comp/my-bench-sv-comp/goblint.xml | 38 ---------- .../table-generator-all-fast.xml | 17 ----- .../table-generator-data-race.xml | 13 ---- .../my-bench-sv-comp/table-generator-lint.xml | 16 ---- .../table-generator-witness.xml | 20 ----- .../uautomizer-validate-correctness.xml | 33 --------- .../uautomizer-validate-violation.xml | 32 -------- .../my-bench-sv-comp/witnesslint-validate.xml | 17 ----- .../witnesslint-validate2.xml | 31 -------- 20 files changed, 635 deletions(-) delete mode 100644 sv-comp/my-bench-sv-comp/.gitignore delete mode 100644 sv-comp/my-bench-sv-comp/README.md delete mode 100644 sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml delete mode 100644 sv-comp/my-bench-sv-comp/cpa-validate-violation.xml delete mode 100755 sv-comp/my-bench-sv-comp/goblint-all-fast.sh delete mode 100644 sv-comp/my-bench-sv-comp/goblint-all-fast.xml delete mode 100755 sv-comp/my-bench-sv-comp/goblint-data-race.sh delete mode 100644 sv-comp/my-bench-sv-comp/goblint-data-race.xml delete mode 100755 sv-comp/my-bench-sv-comp/goblint-lint.sh delete mode 100644 sv-comp/my-bench-sv-comp/goblint-lint.xml delete mode 100755 sv-comp/my-bench-sv-comp/goblint.sh delete mode 100644 sv-comp/my-bench-sv-comp/goblint.xml delete mode 100644 sv-comp/my-bench-sv-comp/table-generator-all-fast.xml delete mode 100644 sv-comp/my-bench-sv-comp/table-generator-data-race.xml delete mode 100644 sv-comp/my-bench-sv-comp/table-generator-lint.xml delete mode 100644 sv-comp/my-bench-sv-comp/table-generator-witness.xml delete mode 100644 sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml delete mode 100644 sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml delete mode 100644 sv-comp/my-bench-sv-comp/witnesslint-validate.xml delete mode 100644 sv-comp/my-bench-sv-comp/witnesslint-validate2.xml diff --git a/sv-comp/my-bench-sv-comp/.gitignore b/sv-comp/my-bench-sv-comp/.gitignore deleted file mode 100644 index 2eb047c8d6..0000000000 --- a/sv-comp/my-bench-sv-comp/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*-tmp.xml diff --git a/sv-comp/my-bench-sv-comp/README.md b/sv-comp/my-bench-sv-comp/README.md deleted file mode 100644 index b401a1898c..0000000000 --- a/sv-comp/my-bench-sv-comp/README.md +++ /dev/null @@ -1,46 +0,0 @@ -# my-bench-sv-comp -This directory contains BenchExec benchmark and table definitions for a number of use cases and shell scripts for running them. - -## goblint-all-fast -Run Goblint on a large number of reachability benchmarks with decreased timeout. - -Files: -* `goblint-all-fast.sh` -* `goblint-all-fast.xml` -* `table-generator-all-fast.xml` - - -## goblint-data-race -Run Goblint on data-race benchmarks. - -Files: -* `goblint-data-race.sh` -* `goblint-data-race.xml` -* `table-generator-data-race.xml` - - -## goblint-lint -Run Goblint and validate witnesses using witnesslinter. - -Files: -* `goblint-lint.sh` -* `goblint-lint.xml` -* `table-generator-lint.xml` -* `witnesslint-validate.xml` - - -## goblint -Run Goblint and validate witnesses using: -* CPAChecker, -* Ultimate Automizer, -* witnesslinter. - -Files: -* `cpa-validate-correctness.xml` -* `cpa-validate-violation.xml` -* `goblint.sh` -* `goblint.xml` -* `table-generator-witness.xml` -* `uautomizer-validate-correctness.xml` -* `uautomizer-validate-violation.xml` -* `witnesslint-validate2.xml` diff --git a/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml b/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml deleted file mode 100644 index dca5c52c6d..0000000000 --- a/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - **.graphml - - - - - - - RESULTSDIR/LOGDIR/${rundefinition_name}/${taskdef_name}/witness.graphml - - - - /home/simmo/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /home/simmo/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml b/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml deleted file mode 100644 index 8fcffd7321..0000000000 --- a/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml +++ /dev/null @@ -1,30 +0,0 @@ - - - - - - **.graphml - - - - - - - - - - - - RESULTSDIR/LOGDIR/${rundefinition_name}/${taskdef_name}/witness.graphml - - - - /home/simmo/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /home/simmo/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-all-fast.sh b/sv-comp/my-bench-sv-comp/goblint-all-fast.sh deleted file mode 100755 index c47ff10141..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-all-fast.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/70-all-fast-no-interval -GOBLINTPARALLEL=14 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-all-fast.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-all-fast.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-all-fast.xml b/sv-comp/my-bench-sv-comp/goblint-all-fast.xml deleted file mode 100644 index 6d4bb8fc3c..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-all-fast.xml +++ /dev/null @@ -1,74 +0,0 @@ - - - - - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/ConcurrencySafety-Main.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/pthread-wmm/* - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64Large-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-data-race.sh b/sv-comp/my-bench-sv-comp/goblint-data-race.sh deleted file mode 100755 index b42e69d5ce..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-data-race.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/data-race-results21-concurrencysafety-new -GOBLINTPARALLEL=14 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-data-race.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-data-race.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-data-race.xml b/sv-comp/my-bench-sv-comp/goblint-data-race.xml deleted file mode 100644 index f8c00b582a..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-data-race.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoDataRace-ConcurrencySafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-data-race.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-lint.sh b/sv-comp/my-bench-sv-comp/goblint-lint.sh deleted file mode 100755 index bbd1270a31..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-lint.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/new-results28-all-fast-systems-witness-linter -GOBLINTPARALLEL=15 -VALIDATEPARALLEL=15 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-lint.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Construct validation XMLs -cd $MYBENCHDIR -# witnesslint -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" witnesslint-validate.xml > witnesslint-validate-tmp.xml - -# Run validation -# witnesslint -cd /mnt/goblint-svcomp/benchexec/tools/witnesslint -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/witnesslint-validate-tmp.xml - -# Merge witness validation results -cd $RESULTSDIR -python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint*.results.!(*merged*).xml.bz2 witnesslint-validate-tmp.*.results.*.xml.bz2 - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-lint.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip -unzip -o witnesslint-validate-tmp.*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-lint.xml b/sv-comp/my-bench-sv-comp/goblint-lint.xml deleted file mode 100644 index 8cae0a2c69..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-lint.xml +++ /dev/null @@ -1,68 +0,0 @@ - - - - - - **.graphml - - - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint.sh b/sv-comp/my-bench-sv-comp/goblint.sh deleted file mode 100755 index eaf74350de..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint.sh +++ /dev/null @@ -1,63 +0,0 @@ -#!/bin/bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/new-results32-overflow -GOBLINTPARALLEL=15 -VALIDATEPARALLEL=4 # not enough memory for more - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint.*.files` -echo $LOGDIR - -# Construct validation XMLs -cd $MYBENCHDIR -# witnesslint -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" witnesslint-validate2.xml > witnesslint-validate2-tmp.xml -# CPAChecker -# sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" cpa-validate-correctness.xml > cpa-validate-correctness-tmp.xml -# sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" cpa-validate-violation.xml > cpa-validate-violation-tmp.xml -# Ultimate -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" uautomizer-validate-correctness.xml > uautomizer-validate-correctness-tmp.xml -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" uautomizer-validate-violation.xml > uautomizer-validate-violation-tmp.xml - -# Run validation -# witnesslint -cd /mnt/goblint-svcomp/benchexec/tools/witnesslint -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/witnesslint-validate2-tmp.xml -# CPAChecker -# cd /home/simmo/benchexec/tools/CPAchecker-1.9-unix -# benchexec --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/cpa-validate-correctness-tmp.xml -# benchexec --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/cpa-validate-violation-tmp.xml -# Ultimate -cd /mnt/goblint-svcomp/benchexec/tools/UAutomizer-linux -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/uautomizer-validate-correctness-tmp.xml -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/uautomizer-validate-violation-tmp.xml - -# Merge witness validation results -cd $RESULTSDIR -# python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.!(*merged*).xml.bz2 cpa-validate-correctness-tmp.*.results.*.xml.bz2 cpa-validate-violation-tmp.*.results.*.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 -# python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.!(*merged*).xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 witnesslint-validate2-tmp.*.results.*.xml.bz2 -python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.*no-overflow.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*no-overflow.xml.bz2 uautomizer-validate-violation-tmp.*.results.*no-overflow.xml.bz2 witnesslint-validate2-tmp.*.results.*no-overflow.xml.bz2 - -# Generate table with merged results and witness validation results -# table-generator goblint.*.results.*.xml.bz2.merged.xml.bz2 cpa-validate-correctness-tmp.*.results.*.xml.bz2 cpa-validate-violation-tmp.*.results.*.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-witness.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint.*.logfiles.zip -# unzip -o cpa-validate-correctness-tmp.*.logfiles.zip -# unzip -o cpa-validate-violation-tmp.*.logfiles.zip -unzip -o uautomizer-validate-correctness-tmp.*.logfiles.zip -unzip -o uautomizer-validate-violation-tmp.*.logfiles.zip -unzip -o witnesslint-validate2-tmp.*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint.xml b/sv-comp/my-bench-sv-comp/goblint.xml deleted file mode 100644 index c5773f3569..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint.xml +++ /dev/null @@ -1,38 +0,0 @@ - - - - - - **.graphml - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoOverflows-BitVectors.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoOverflows-Other.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-BusyBox-NoOverflows.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-uthash-NoOverflows.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - - - diff --git a/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml b/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml deleted file mode 100644 index c9b9932390..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-data-race.xml b/sv-comp/my-bench-sv-comp/table-generator-data-race.xml deleted file mode 100644 index 28410d1805..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-data-race.xml +++ /dev/null @@ -1,13 +0,0 @@ - - - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-lint.xml b/sv-comp/my-bench-sv-comp/table-generator-lint.xml deleted file mode 100644 index 6ca64dc84e..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-lint.xml +++ /dev/null @@ -1,16 +0,0 @@ - - - - - - - - - witness - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-witness.xml b/sv-comp/my-bench-sv-comp/table-generator-witness.xml deleted file mode 100644 index 876c08d392..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-witness.xml +++ /dev/null @@ -1,20 +0,0 @@ - - - - - - - - - witness - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml b/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml deleted file mode 100644 index efb0861775..0000000000 --- a/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml +++ /dev/null @@ -1,33 +0,0 @@ - - - - - **.graphml - - diff --git a/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml b/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml deleted file mode 100644 index fdf61b1bab..0000000000 --- a/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml +++ /dev/null @@ -1,32 +0,0 @@ - - - - - **.graphml - - diff --git a/sv-comp/my-bench-sv-comp/witnesslint-validate.xml b/sv-comp/my-bench-sv-comp/witnesslint-validate.xml deleted file mode 100644 index 96a41ef731..0000000000 --- a/sv-comp/my-bench-sv-comp/witnesslint-validate.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - diff --git a/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml b/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml deleted file mode 100644 index 475bc9846e..0000000000 --- a/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml +++ /dev/null @@ -1,31 +0,0 @@ - - - - - From 3eadb60431a18538263a4e3537ea40e0c1d57c7f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 12:27:53 +0200 Subject: [PATCH 210/233] Remove old ocamldoc index file --- src/main.camldoc | 140 ----------------------------------------------- 1 file changed, 140 deletions(-) delete mode 100644 src/main.camldoc diff --git a/src/main.camldoc b/src/main.camldoc deleted file mode 100644 index 0a0e52035f..0000000000 --- a/src/main.camldoc +++ /dev/null @@ -1,140 +0,0 @@ - -This is the API of the Goblint static analyzer framework, developed at the Technische Universität München ({b TUM}) -and the University of Tartu ({b UT}). - -The API is divided into four logical sections: -the framework, constraint solvers, domains, and analysis instances. - -{2 Framework} -{!modules: -Maingoblint -Analyses -Constraints -Control -MyCFG -Version -Config -} - -{3 Util} -{!modules: -Cache -Cilfacade -Defaults -GobConfig -Goblintutil -Hash -Htmldump -Htmlutil -Json -Messages -MyLiveness -OilUtil -Printer -Questions -Report -Tracing -Xmldump -} - -{3 CIL components} -{!modules: -Cil -Pretty -} - -{2 Solvers} -{!modules: -EffectWCon -EffectWConEq -Generic -Interactive -SLR -Selector -SharirPnueli -TopDown -} - -{2 Domains} - -{!modules: - -ValueDomain -Basetype - -Exp -IntDomain -CircularInterval -ArrayDomain -StructDomain -UnionDomain - -Lval -AddressDomain -MemoryDomain -MusteqDomain -RegionDomain -ShapeDomain -ListDomain - -BaseDomain -ConcDomain -ContainDomain -EscapeDomain -FlagModeDomain -LockDomain -StackDomain -FileDomain -LvalMapDomain - -} - -{3 General Lattice Functors} - -{!modules: -Lattice -Printable -MapDomain -PartitionDomain -SetDomain -Queries -Glob -} - -{2 Analyses} -{!modules: -MCP -Base - -CondVars -Contain -Deadlock -DeadlocksByRaces -Depbase -Depmutex -FileUse -Flag -FlagModes -ImpVar -Malloc_null -MayLocks -MTFlag -Mutex -Region -Shapes -StackTrace -SymbLocks -Termination -ThreadEscape -Thread -Uninit -Unit -VarDep -VarEq - -LibraryFunctions -} - -{9 Indexes} - -{!indexlist} From 4cbfd1a97dd378a5550002b09c07aa3e50668d2e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 12:55:20 +0200 Subject: [PATCH 211/233] Add bisect_ppx to extracted dune libraries --- src/common/dune | 3 ++- src/config/dune | 3 ++- src/domain/dune | 3 ++- src/incremental/dune | 3 ++- src/util/library/dune | 3 ++- src/util/std/dune | 3 ++- 6 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/common/dune b/src/common/dune index 7994798579..458ef02dcb 100644 --- a/src/common/dune +++ b/src/common/dune @@ -20,6 +20,7 @@ (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/config/dune b/src/config/dune index 1508e2553e..ce5cb11559 100644 --- a/src/config/dune +++ b/src/config/dune @@ -18,6 +18,7 @@ (preprocess (pps ppx_blob)) - (preprocessor_deps (file options.schema.json))) + (preprocessor_deps (file options.schema.json)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/domain/dune b/src/domain/dune index 169f4a1d5c..85e69a6246 100644 --- a/src/domain/dune +++ b/src/domain/dune @@ -14,6 +14,7 @@ (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/incremental/dune b/src/incremental/dune index 595dba22f7..15c1d2a7af 100644 --- a/src/incremental/dune +++ b/src/incremental/dune @@ -17,6 +17,7 @@ (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/util/library/dune b/src/util/library/dune index 075c01c35d..c7797db33f 100644 --- a/src/util/library/dune +++ b/src/util/library/dune @@ -13,6 +13,7 @@ (preprocess (pps ppx_deriving.std - ppx_deriving_hash))) + ppx_deriving_hash)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/util/std/dune b/src/util/std/dune index b074a29937..2b814c677a 100644 --- a/src/util/std/dune +++ b/src/util/std/dune @@ -15,4 +15,5 @@ (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) From 8650d7282d75d131c4d15cb071ab16ea408a87f2 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 15 Dec 2023 16:54:35 +0200 Subject: [PATCH 212/233] Fix mismerge of Lincons1.num_vars usage in ed06c346dd7341c52fa7144ceaf51b0675768aef --- src/analyses/apron/relationAnalysis.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index 5e128ffc30..e572755930 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -609,7 +609,7 @@ struct |> Enum.filter_map (fun (lincons1: Apron.Lincons1.t) -> (* filter one-vars and exact *) (* TODO: exact filtering doesn't really work with octagon because it returns two SUPEQ constraints instead *) - if (one_var || Apron.Linexpr0.get_size lincons1.lincons0.linexpr0 >= 2) && (exact || Apron.Lincons1.get_typ lincons1 <> EQ) then + if (one_var || GobApron.Lincons1.num_vars lincons1 >= 2) && (exact || Apron.Lincons1.get_typ lincons1 <> EQ) then RD.cil_exp_of_lincons1 lincons1 |> Option.map e_inv |> Option.filter (fun exp -> not (InvariantCil.exp_contains_tmp exp) && InvariantCil.exp_is_in_scope scope exp) From 87f7e02a69e9753155e3942e866881adab932aa6 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 19 Dec 2023 20:29:19 +0000 Subject: [PATCH 213/233] Bump actions/upload-pages-artifact from 2 to 3 Bumps [actions/upload-pages-artifact](https://github.com/actions/upload-pages-artifact) from 2 to 3. - [Release notes](https://github.com/actions/upload-pages-artifact/releases) - [Commits](https://github.com/actions/upload-pages-artifact/compare/v2...v3) --- updated-dependencies: - dependency-name: actions/upload-pages-artifact dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 1d73e037f4..f793fa4c0d 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -55,7 +55,7 @@ jobs: run: opam exec -- dune build @doc - name: Upload artifact - uses: actions/upload-pages-artifact@v2 + uses: actions/upload-pages-artifact@v3 with: path: _build/default/_doc/_html/ From 502923b921c412d31ce3ca30a4b18f78d09989dc Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 19 Dec 2023 20:29:19 +0000 Subject: [PATCH 214/233] Bump actions/deploy-pages from 3 to 4 Bumps [actions/deploy-pages](https://github.com/actions/deploy-pages) from 3 to 4. - [Release notes](https://github.com/actions/deploy-pages/releases) - [Commits](https://github.com/actions/deploy-pages/compare/v3...v4) --- updated-dependencies: - dependency-name: actions/deploy-pages dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 1d73e037f4..dedfe44ef8 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -68,4 +68,4 @@ jobs: steps: - name: Deploy to GitHub Pages id: deployment - uses: actions/deploy-pages@v3 + uses: actions/deploy-pages@v4 From 9f5de689ba9aa0fa38936a0cdfdd5014a2489851 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 20 Dec 2023 14:09:48 +0200 Subject: [PATCH 215/233] Revert "Bump actions/upload-pages-artifact from 2 to 3" This reverts commit 87f7e02a69e9753155e3942e866881adab932aa6. --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index d1f7fb09e0..dedfe44ef8 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -55,7 +55,7 @@ jobs: run: opam exec -- dune build @doc - name: Upload artifact - uses: actions/upload-pages-artifact@v3 + uses: actions/upload-pages-artifact@v2 with: path: _build/default/_doc/_html/ From df2b39a1c57c9cc4b7f4466bdbc842749db909b8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 20 Dec 2023 14:09:52 +0200 Subject: [PATCH 216/233] Revert "Bump actions/deploy-pages from 3 to 4" This reverts commit 502923b921c412d31ce3ca30a4b18f78d09989dc. --- .github/workflows/docs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index dedfe44ef8..1d73e037f4 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -68,4 +68,4 @@ jobs: steps: - name: Deploy to GitHub Pages id: deployment - uses: actions/deploy-pages@v4 + uses: actions/deploy-pages@v3 From 8bb2c5f3c521713be593200dbf81a0c2ff6e8a40 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 11:48:47 +0200 Subject: [PATCH 217/233] Add test for suppressing thread-unsafe lib fun calls in single-threaded mode #1260 --- .../00-sanity/52-thread-unsafe-libfuns-single-thread.c | 8 ++++++++ .../00-sanity/52-thread-unsafe-libfuns-single-thread.t | 5 +++++ 2 files changed, 13 insertions(+) create mode 100644 tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c create mode 100644 tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c new file mode 100644 index 0000000000..a83d9eeeb0 --- /dev/null +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c @@ -0,0 +1,8 @@ +// PARAM: --enable allglobs + +#include + +int main() { + rand(); + return 0; +} \ No newline at end of file diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t new file mode 100644 index 0000000000..0914c25439 --- /dev/null +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t @@ -0,0 +1,5 @@ + $ goblint --enable allglobs 52-thread-unsafe-libfuns-single-thread.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 3 + dead: 0 + total lines: 3 From b7e43c505cf3fa98f91f2a595a646a10be06d500 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 11:49:33 +0200 Subject: [PATCH 218/233] Do not record thread-unsafe lib fun calls in single-threaded mode #1260 --- src/analyses/raceAnalysis.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index f35e6756a1..5e03c6bfab 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -369,7 +369,7 @@ struct let special ctx (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = (* perform shallow and deep invalidate according to Library descriptors *) let desc = LibraryFunctions.find f in - if List.mem LibraryDesc.ThreadUnsafe desc.attrs then ( + if List.mem LibraryDesc.ThreadUnsafe desc.attrs && not (ctx.ask (Queries.MustBeSingleThreaded {since_start=true})) then ( let exp = Lval (Var f, NoOffset) in let conf = 110 in let kind = AccessKind.Call in From ee33a8050f7ede2e9f1c5a0fb21906a321b67c70 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 11:51:17 +0200 Subject: [PATCH 219/233] Fix old cram test according to new implementation --- tests/regression/29-svcomp/32-no-ov.t | 5 ----- 1 file changed, 5 deletions(-) diff --git a/tests/regression/29-svcomp/32-no-ov.t b/tests/regression/29-svcomp/32-no-ov.t index 85eb90c185..1dc22ed89e 100644 --- a/tests/regression/29-svcomp/32-no-ov.t +++ b/tests/regression/29-svcomp/32-no-ov.t @@ -9,8 +9,3 @@ dead: 0 total lines: 3 SV-COMP result: true - [Info][Race] Memory locations race summary: - safe: 1 - vulnerable: 0 - unsafe: 0 - total memory locations: 1 From c26c83e8fca0ad859e405a8fa0c65cf1028a7998 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:20:31 +0200 Subject: [PATCH 220/233] Make test for suppressing thread-unsafe lib fun calls check more cases --- .../52-thread-unsafe-libfuns-single-thread.c | 12 ++++++++++-- .../52-thread-unsafe-libfuns-single-thread.t | 6 +++--- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c index a83d9eeeb0..94c0f3efeb 100644 --- a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c @@ -1,8 +1,16 @@ -// PARAM: --enable allglobs - +// PARAM: --enable allglobs --set ana.activated[+] threadJoins #include +#include + +void *t_benign(void *arg) { + return NULL; +} int main() { + rand(); + pthread_t id; + pthread_create(&id, NULL, t_benign, NULL); + pthread_join(id, NULL); rand(); return 0; } \ No newline at end of file diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t index 0914c25439..64413bae36 100644 --- a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t @@ -1,5 +1,5 @@ - $ goblint --enable allglobs 52-thread-unsafe-libfuns-single-thread.c + $ goblint --enable allglobs --set ana.activated[+] threadJoins 52-thread-unsafe-libfuns-single-thread.c [Info][Deadcode] Logical lines of code (LLoC) summary: - live: 3 + live: 8 dead: 0 - total lines: 3 + total lines: 8 From ecd0bc5452dde4e7aa8c2200c809f9470836fe13 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:33:06 +0200 Subject: [PATCH 221/233] Do not record thread-unsafe lib fun calls after all threads have joined --- src/analyses/raceAnalysis.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 5e03c6bfab..6b7217147e 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -369,7 +369,7 @@ struct let special ctx (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = (* perform shallow and deep invalidate according to Library descriptors *) let desc = LibraryFunctions.find f in - if List.mem LibraryDesc.ThreadUnsafe desc.attrs && not (ctx.ask (Queries.MustBeSingleThreaded {since_start=true})) then ( + if List.mem LibraryDesc.ThreadUnsafe desc.attrs && ThreadFlag.is_currently_multi (Analyses.ask_of_ctx ctx) then ( let exp = Lval (Var f, NoOffset) in let conf = 110 in let kind = AccessKind.Call in From 8ac5fadb08ec258021c8a98b00faca549c69a95b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 14:41:48 +0200 Subject: [PATCH 222/233] Extract analysis results from Analyses module --- src/framework/analyses.ml | 186 ------------------------------- src/framework/analysisResult.ml | 191 ++++++++++++++++++++++++++++++++ src/framework/control.ml | 4 +- src/goblint_lib.ml | 1 + 4 files changed, 194 insertions(+), 188 deletions(-) create mode 100644 src/framework/analysisResult.ml diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 405df5b6a6..633eea1b39 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -162,183 +162,6 @@ struct end -module ResultNode: Printable.S with type t = MyCFG.node = -struct - include Printable.Std - - include Node - - let name () = "resultnode" - - let show a = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let x = UpdateCil.getLoc a in - let f = Node.find_fundec a in - CilType.Location.show x ^ "(" ^ f.svar.vname ^ ")" - - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) -end - -module type ResultConf = -sig - val result_name: string -end - -module Result (Range: Printable.S) (C: ResultConf) = -struct - include Hashtbl.Make (ResultNode) - type nonrec t = Range.t t (* specialize polymorphic type for Range values *) - - let pretty () mapping = - let f key st dok = - dok ++ dprintf "%a ->@? @[%a@]\n" ResultNode.pretty key Range.pretty st - in - let content () = fold f mapping nil in - let defline () = dprintf "OTHERS -> Not available\n" in - dprintf "@[Mapping {\n @[%t%t@]}@]" content defline - - include C - - let printXml f xs = - let print_one n v = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - BatPrintf.fprintf f "\n" (Node.show_id n) loc.file loc.line loc.byte loc.column; - BatPrintf.fprintf f "%a\n" Range.printXml v - in - iter print_one xs - - let printJson f xs = - let print_one n v = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - BatPrintf.fprintf f "{\n\"id\": \"%s\", \"file\": \"%s\", \"line\": \"%d\", \"byte\": \"%d\", \"column\": \"%d\", \"states\": %s\n},\n" (Node.show_id n) loc.file loc.line loc.byte loc.column (Yojson.Safe.to_string (Range.to_yojson v)) - in - iter print_one xs - - let printXmlWarning f () = - let one_text f Messages.Piece.{loc; text = m; _} = - match loc with - | Some loc -> - let l = Messages.Location.to_cil loc in - BatPrintf.fprintf f "\n%s" l.file l.line l.column (XmlUtil.escape m) - | None -> - () (* TODO: not outputting warning without location *) - in - let one_w f (m: Messages.Message.t) = match m.multipiece with - | Single piece -> one_text f piece - | Group {group_text = n; pieces = e; group_loc} -> - let group_loc_text = match group_loc with - | None -> "" - | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc) - in - BatPrintf.fprintf f "%a\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e - in - let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in - List.iter (one_w f) !Messages.Table.messages_list - - let output table gtable gtfxml (file: file) = - let out = Messages.get_out result_name !Messages.out in - match get_string "result" with - | "pretty" -> ignore (fprintf out "%a\n" pretty (Lazy.force table)) - | "fast_xml" -> - let module SH = BatHashtbl.Make (Basetype.RawStrings) in - let file2funs = SH.create 100 in - let funs2node = SH.create 100 in - iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); - iterGlobals file (function - | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname - | _ -> () - ); - let p_node f n = BatPrintf.fprintf f "%s" (Node.show_id n) in - let p_nodes f xs = - List.iter (BatPrintf.fprintf f "\n" p_node) xs - in - let p_funs f xs = - let one_fun n = - BatPrintf.fprintf f "\n%a\n" n p_nodes (SH.find_all funs2node n) - in - List.iter one_fun xs - in - let write_file f fn = - Messages.xml_file_name := fn; - BatPrintf.printf "Writing xml to temp. file: %s\n%!" fn; - BatPrintf.fprintf f ""; - BatPrintf.fprintf f "%s" GobSys.command_line; - BatPrintf.fprintf f ""; - let timing_ppf = BatFormat.formatter_of_out_channel f in - Timing.Default.print timing_ppf; - Format.pp_print_flush timing_ppf (); - BatPrintf.fprintf f ""; - BatPrintf.fprintf f "\n"; - BatEnum.iter (fun b -> BatPrintf.fprintf f "\n%a\n" (Filename.basename b) b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs); - BatPrintf.fprintf f "%a" printXml (Lazy.force table); - gtfxml f gtable; - printXmlWarning f (); - BatPrintf.fprintf f "\n"; - BatPrintf.fprintf f "%!" - in - if get_bool "g2html" then - BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file - else - let f = BatIO.output_channel out in - write_file f (get_string "outfile") - | "json" -> - let open BatPrintf in - let module SH = BatHashtbl.Make (Basetype.RawStrings) in - let file2funs = SH.create 100 in - let funs2node = SH.create 100 in - iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); - iterGlobals file (function - | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname - | _ -> () - ); - let p_enum p f xs = BatEnum.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in - let p_list p f xs = BatList.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in - (*let p_kv f (k,p,v) = fprintf f "\"%s\": %a" k p v in*) - (*let p_obj f xs = BatList.print ~first:"{\n " ~last:"\n}" ~sep:",\n " p_kv xs in*) - let p_node f n = BatPrintf.fprintf f "\"%s\"" (Node.show_id n) in - let p_fun f x = fprintf f "{\n \"name\": \"%s\",\n \"nodes\": %a\n}" x (p_list p_node) (SH.find_all funs2node x) in - (*let p_fun f x = p_obj f [ "name", BatString.print, x; "nodes", p_list p_node, SH.find_all funs2node x ] in*) - let p_file f x = fprintf f "{\n \"name\": \"%s\",\n \"path\": \"%s\",\n \"functions\": %a\n}" (Filename.basename x) x (p_list p_fun) (SH.find_all file2funs x) in - let write_file f fn = - printf "Writing json to temp. file: %s\n%!" fn; - fprintf f "{\n \"parameters\": \"%s\",\n " GobSys.command_line; - fprintf f "\"files\": %a,\n " (p_enum p_file) (SH.keys file2funs); - fprintf f "\"results\": [\n %a\n]\n" printJson (Lazy.force table); - (*gtfxml f gtable;*) - (*printXmlWarning f ();*) - fprintf f "}\n"; - in - if get_bool "g2html" then - BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file - else - let f = BatIO.output_channel out in - write_file f (get_string "outfile") - | "sarif" -> - let open BatPrintf in - printf "Writing Sarif to file: %s\n%!" (get_string "outfile"); - Yojson.Safe.to_channel ~std:true out (Sarif.to_yojson (List.rev !Messages.Table.messages_list)); - | "json-messages" -> - let json = `Assoc [ - ("files", Preprocessor.dependencies_to_yojson ()); - ("messages", Messages.Table.to_yojson ()); - ] - in - Yojson.Safe.to_channel ~std:true out json - | "none" -> () - | s -> failwith @@ "Unsupported value for option `result`: "^s -end - - (* Experiment to reduce the number of arguments on transfer functions and allow sub-analyses. The list sub contains the current local states of analyses in the same order as written in the dependencies list (in MCP). @@ -598,15 +421,6 @@ module type GenericGlobSolver = val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal end -module ResultType2 (S:Spec) = -struct - open S - include Printable.Prod3 (C) (D) (CilType.Fundec) - let show (es,x,f:t) = D.show x - let pretty () (_,x,_) = D.pretty () x - let printXml f (c,d,fd) = - BatPrintf.fprintf f "\n%a\n%a" C.printXml c D.printXml d -end module StdV = struct diff --git a/src/framework/analysisResult.ml b/src/framework/analysisResult.ml new file mode 100644 index 0000000000..09ece868c1 --- /dev/null +++ b/src/framework/analysisResult.ml @@ -0,0 +1,191 @@ +(** Analysis result output. *) + +open GoblintCil +open Pretty +open GobConfig + +module ResultNode: Printable.S with type t = MyCFG.node = +struct + include Printable.Std + + include Node + + let name () = "resultnode" + + let show a = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let x = UpdateCil.getLoc a in + let f = Node.find_fundec a in + CilType.Location.show x ^ "(" ^ f.svar.vname ^ ")" + + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) +end + +module type ResultConf = +sig + val result_name: string +end + +module Result (Range: Printable.S) (C: ResultConf) = +struct + include BatHashtbl.Make (ResultNode) + type nonrec t = Range.t t (* specialize polymorphic type for Range values *) + + let pretty () mapping = + let f key st dok = + dok ++ dprintf "%a ->@? @[%a@]\n" ResultNode.pretty key Range.pretty st + in + let content () = fold f mapping nil in + let defline () = dprintf "OTHERS -> Not available\n" in + dprintf "@[Mapping {\n @[%t%t@]}@]" content defline + + include C + + let printXml f xs = + let print_one n v = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + BatPrintf.fprintf f "\n" (Node.show_id n) loc.file loc.line loc.byte loc.column; + BatPrintf.fprintf f "%a\n" Range.printXml v + in + iter print_one xs + + let printJson f xs = + let print_one n v = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + BatPrintf.fprintf f "{\n\"id\": \"%s\", \"file\": \"%s\", \"line\": \"%d\", \"byte\": \"%d\", \"column\": \"%d\", \"states\": %s\n},\n" (Node.show_id n) loc.file loc.line loc.byte loc.column (Yojson.Safe.to_string (Range.to_yojson v)) + in + iter print_one xs + + let printXmlWarning f () = + let one_text f Messages.Piece.{loc; text = m; _} = + match loc with + | Some loc -> + let l = Messages.Location.to_cil loc in + BatPrintf.fprintf f "\n%s" l.file l.line l.column (XmlUtil.escape m) + | None -> + () (* TODO: not outputting warning without location *) + in + let one_w f (m: Messages.Message.t) = match m.multipiece with + | Single piece -> one_text f piece + | Group {group_text = n; pieces = e; group_loc} -> + let group_loc_text = match group_loc with + | None -> "" + | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc) + in + BatPrintf.fprintf f "%a\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e + in + let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in + List.iter (one_w f) !Messages.Table.messages_list + + let output table gtable gtfxml (file: file) = + let out = Messages.get_out result_name !Messages.out in + match get_string "result" with + | "pretty" -> ignore (fprintf out "%a\n" pretty (Lazy.force table)) + | "fast_xml" -> + let module SH = BatHashtbl.Make (Basetype.RawStrings) in + let file2funs = SH.create 100 in + let funs2node = SH.create 100 in + iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); + iterGlobals file (function + | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname + | _ -> () + ); + let p_node f n = BatPrintf.fprintf f "%s" (Node.show_id n) in + let p_nodes f xs = + List.iter (BatPrintf.fprintf f "\n" p_node) xs + in + let p_funs f xs = + let one_fun n = + BatPrintf.fprintf f "\n%a\n" n p_nodes (SH.find_all funs2node n) + in + List.iter one_fun xs + in + let write_file f fn = + Messages.xml_file_name := fn; + BatPrintf.printf "Writing xml to temp. file: %s\n%!" fn; + BatPrintf.fprintf f ""; + BatPrintf.fprintf f "%s" GobSys.command_line; + BatPrintf.fprintf f ""; + let timing_ppf = BatFormat.formatter_of_out_channel f in + Timing.Default.print timing_ppf; + Format.pp_print_flush timing_ppf (); + BatPrintf.fprintf f ""; + BatPrintf.fprintf f "\n"; + BatEnum.iter (fun b -> BatPrintf.fprintf f "\n%a\n" (Filename.basename b) b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs); + BatPrintf.fprintf f "%a" printXml (Lazy.force table); + gtfxml f gtable; + printXmlWarning f (); + BatPrintf.fprintf f "\n"; + BatPrintf.fprintf f "%!" + in + if get_bool "g2html" then + BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file + else + let f = BatIO.output_channel out in + write_file f (get_string "outfile") + | "json" -> + let open BatPrintf in + let module SH = BatHashtbl.Make (Basetype.RawStrings) in + let file2funs = SH.create 100 in + let funs2node = SH.create 100 in + iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); + iterGlobals file (function + | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname + | _ -> () + ); + let p_enum p f xs = BatEnum.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in + let p_list p f xs = BatList.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in + (*let p_kv f (k,p,v) = fprintf f "\"%s\": %a" k p v in*) + (*let p_obj f xs = BatList.print ~first:"{\n " ~last:"\n}" ~sep:",\n " p_kv xs in*) + let p_node f n = BatPrintf.fprintf f "\"%s\"" (Node.show_id n) in + let p_fun f x = fprintf f "{\n \"name\": \"%s\",\n \"nodes\": %a\n}" x (p_list p_node) (SH.find_all funs2node x) in + (*let p_fun f x = p_obj f [ "name", BatString.print, x; "nodes", p_list p_node, SH.find_all funs2node x ] in*) + let p_file f x = fprintf f "{\n \"name\": \"%s\",\n \"path\": \"%s\",\n \"functions\": %a\n}" (Filename.basename x) x (p_list p_fun) (SH.find_all file2funs x) in + let write_file f fn = + printf "Writing json to temp. file: %s\n%!" fn; + fprintf f "{\n \"parameters\": \"%s\",\n " GobSys.command_line; + fprintf f "\"files\": %a,\n " (p_enum p_file) (SH.keys file2funs); + fprintf f "\"results\": [\n %a\n]\n" printJson (Lazy.force table); + (*gtfxml f gtable;*) + (*printXmlWarning f ();*) + fprintf f "}\n"; + in + if get_bool "g2html" then + BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file + else + let f = BatIO.output_channel out in + write_file f (get_string "outfile") + | "sarif" -> + let open BatPrintf in + printf "Writing Sarif to file: %s\n%!" (get_string "outfile"); + Yojson.Safe.to_channel ~std:true out (Sarif.to_yojson (List.rev !Messages.Table.messages_list)); + | "json-messages" -> + let json = `Assoc [ + ("files", Preprocessor.dependencies_to_yojson ()); + ("messages", Messages.Table.to_yojson ()); + ] + in + Yojson.Safe.to_channel ~std:true out json + | "none" -> () + | s -> failwith @@ "Unsupported value for option `result`: "^s +end + +module ResultType2 (S: Analyses.Spec) = +struct + open S + include Printable.Prod3 (C) (D) (CilType.Fundec) + let show (es,x,f:t) = D.show x + let pretty () (_,x,_) = D.pretty () x + let printXml f (c,d,fd) = + BatPrintf.fprintf f "\n%a\n%a" C.printXml c D.printXml d +end diff --git a/src/framework/control.ml b/src/framework/control.ml index 00a6034e27..54fd1d7774 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -89,11 +89,11 @@ struct module CompareGlobSys = Constraints.CompareGlobSys (SpecSys) (* Triple of the function, context, and the local value. *) - module RT = Analyses.ResultType2 (Spec) + module RT = AnalysisResult.ResultType2 (Spec) (* Set of triples [RT] *) module LT = SetDomain.HeadlessSet (RT) (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = Analyses.Result (LT) (struct let result_name = "analysis" end) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) module Query = ResultQuery.Query (SpecSys) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index e402cc33fe..2cbe737079 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -45,6 +45,7 @@ module Events = Events The following modules help query the constraint system solution using semantic information. *) +module AnalysisResult = AnalysisResult module ResultQuery = ResultQuery module VarQuery = VarQuery From afdbcf5466015344db929ba982b49d608e2ae68e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:49:06 +0100 Subject: [PATCH 223/233] Remove `OldDomainFacade` --- src/cdomains/intDomain.ml | 93 -------------------------------------- src/cdomains/intDomain.mli | 2 - 2 files changed, 95 deletions(-) diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 376dab71c2..986634066c 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -282,99 +282,6 @@ end module type Z = Y with type int_t = BI.t -module OldDomainFacade (Old : IkindUnawareS with type int_t = int64) : S with type int_t = BI.t and type t = Old.t = -struct - include Old - type int_t = BI.t - let neg ?no_ov _ik = Old.neg - let add ?no_ov _ik = Old.add - let sub ?no_ov _ik = Old.sub - let mul ?no_ov _ik = Old.mul - let div ?no_ov _ik = Old.div - let rem _ik = Old.rem - - let lt _ik = Old.lt - let gt _ik = Old.gt - let le _ik = Old.le - let ge _ik = Old.ge - let eq _ik = Old.eq - let ne _ik = Old.ne - - let bitnot _ik = bitnot - let bitand _ik = bitand - let bitor _ik = bitor - let bitxor _ik = bitxor - - let shift_left _ik = shift_left - let shift_right _ik = shift_right - - let lognot _ik = lognot - let logand _ik = logand - let logor _ik = logor - - - let to_int a = Option.map BI.of_int64 (Old.to_int a) - - let equal_to (x: int_t) (a: t)= - try - Old.equal_to (BI.to_int64 x) a - with Z.Overflow | Failure _ -> `Top - - let to_excl_list a = Option.map (BatTuple.Tuple2.map1 (List.map BI.of_int64)) (Old.to_excl_list a) - let of_excl_list ik xs = - let xs' = List.map BI.to_int64 xs in - Old.of_excl_list ik xs' - - let to_incl_list a = Option.map (List.map BI.of_int64) (Old.to_incl_list a) - - let maximal a = Option.map BI.of_int64 (Old.maximal a) - let minimal a = Option.map BI.of_int64 (Old.minimal a) - - let of_int ik x = - (* If we cannot convert x to int64, we have to represent it with top in the underlying domain*) - try - Old.of_int (BI.to_int64 x) - with - Failure _ -> top_of ik - - let of_bool ik b = Old.of_bool b - let of_interval ?(suppress_ovwarn=false) ik (l, u) = - try - Old.of_interval ~suppress_ovwarn ik (BI.to_int64 l, BI.to_int64 u) - with - Failure _ -> top_of ik - let of_congruence ik (c, m) = - try - Old.of_congruence ik (BI.to_int64 c, BI.to_int64 m) - with - Failure _ -> top_of ik - - let starting ?(suppress_ovwarn=false) ik x = - try Old.starting ~suppress_ovwarn ik (BI.to_int64 x) with Failure _ -> top_of ik - let ending ?(suppress_ovwarn=false) ik x = - try Old.ending ~suppress_ovwarn ik (BI.to_int64 x) with Failure _ -> top_of ik - - let join _ik = Old.join - let meet _ik = Old.meet - let narrow _ik = Old.narrow - let widen _ik = Old.widen - - let is_top_of _ik = Old.is_top - - let invariant_ikind e ik t = Old.invariant e t - - let cast_to ?torg ?no_ov = Old.cast_to ?torg - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = a - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t - - let arbitrary _ik = Old.arbitrary () -end - module IntDomLifter (I : S) = struct diff --git a/src/cdomains/intDomain.mli b/src/cdomains/intDomain.mli index a853c8acca..4b14aeec72 100644 --- a/src/cdomains/intDomain.mli +++ b/src/cdomains/intDomain.mli @@ -308,8 +308,6 @@ end module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t -module OldDomainFacade (Old : IkindUnawareS with type int_t = int64) : S with type int_t = IntOps.BigIntOps.t and type t = Old.t -(** Facade for IntDomain implementations that do not implement the interface where arithmetic functions take an ikind parameter. *) module type Y = sig From 0602af056a32170f090cf54c9555b7366a4c2fee Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 14:56:31 +0200 Subject: [PATCH 224/233] Extract constraint systems from Analyses module --- src/framework/analyses.ml | 126 +----------------------- src/framework/constrSys.ml | 125 +++++++++++++++++++++++ src/framework/constraints.ml | 1 + src/framework/control.ml | 1 + src/goblint_lib.ml | 1 + src/solvers/effectWConEq.ml | 2 +- src/solvers/generic.ml | 2 +- src/solvers/postSolver.ml | 3 +- src/solvers/sLR.ml | 2 +- src/solvers/sLRphased.ml | 2 +- src/solvers/sLRterm.ml | 2 +- src/solvers/selector.ml | 2 +- src/solvers/td3.ml | 4 +- src/solvers/topDown.ml | 2 +- src/solvers/topDown_deprecated.ml | 2 +- src/solvers/topDown_space_cache_term.ml | 2 +- src/solvers/topDown_term.ml | 2 +- src/solvers/worklist.ml | 2 +- 18 files changed, 146 insertions(+), 137 deletions(-) create mode 100644 src/framework/constrSys.ml diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 633eea1b39..ca6cb9fd51 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -11,24 +11,6 @@ module M = Messages * other functions. *) type fundecs = fundec list * fundec list * fundec list -module type SysVar = -sig - type t - val is_write_only: t -> bool -end - -module type VarType = -sig - include Hashtbl.HashedType - include SysVar with type t := t - val pretty_trace: unit -> t -> doc - val compare : t -> t -> int - - val printXml : 'a BatInnerIO.output -> t -> unit - val var_id : t -> string - val node : t -> MyCFG.node - val relift : t -> t (* needed only for incremental+hashcons to re-hashcons contexts after loading *) -end module Var = struct @@ -69,7 +51,7 @@ end module type SpecSysVar = sig include Printable.S - include SysVar with type t := t + include ConstrSys.SysVar with type t := t end module GVarF (V: SpecSysVar) = @@ -318,110 +300,6 @@ type increment_data = { restarting: VarQuery.t list; } -(** Abstract incremental change to constraint system. - @param 'v constrain system variable type *) -type 'v sys_change_info = { - obsolete: 'v list; (** Variables to destabilize. *) - delete: 'v list; (** Variables to delete. *) - reluctant: 'v list; (** Variables to solve reluctantly. *) - restart: 'v list; (** Variables to restart. *) -} - -(** A side-effecting system. *) -module type MonSystem = -sig - type v (* variables *) - type d (* values *) - type 'a m (* basically a monad carrier *) - - (** Variables must be hashable, comparable, etc. *) - module Var : VarType with type t = v - - (** Values must form a lattice. *) - module Dom : Lattice.S with type t = d - - (** The system in functional form. *) - val system : v -> ((v -> d) -> (v -> d -> unit) -> d) m - - val sys_change: (v -> d) -> v sys_change_info - (** Compute incremental constraint system change from old solution. *) -end - -(** Any system of side-effecting equations over lattices. *) -module type EqConstrSys = MonSystem with type 'a m := 'a option - -(** A side-effecting system with globals. *) -module type GlobConstrSys = -sig - module LVar : VarType - module GVar : VarType - - module D : Lattice.S - module G : Lattice.S - val system : LVar.t -> ((LVar.t -> D.t) -> (LVar.t -> D.t -> unit) -> (GVar.t -> G.t) -> (GVar.t -> G.t -> unit) -> D.t) option - val iter_vars: (LVar.t -> D.t) -> (GVar.t -> G.t) -> VarQuery.t -> LVar.t VarQuery.f -> GVar.t VarQuery.f -> unit - val sys_change: (LVar.t -> D.t) -> (GVar.t -> G.t) -> [`L of LVar.t | `G of GVar.t] sys_change_info -end - -(** A solver is something that can translate a system into a solution (hash-table). - Incremental solver has data to be marshaled. *) -module type GenericEqIncrSolverBase = - functor (S:EqConstrSys) -> - functor (H:Hashtbl.S with type key=S.v) -> - sig - type marshal - - val copy_marshal: marshal -> marshal - val relift_marshal: marshal -> marshal - - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. - As a second component the solver returns data structures for incremental serialization. *) - val solve : (S.v*S.d) list -> S.v list -> marshal option -> S.d H.t * marshal - end - -(** (Incremental) solver argument, indicating which postsolving should be performed by the solver. *) -module type IncrSolverArg = -sig - val should_prune: bool - val should_verify: bool - val should_warn: bool - val should_save_run: bool -end - -(** An incremental solver takes the argument about postsolving. *) -module type GenericEqIncrSolver = - functor (Arg: IncrSolverArg) -> - GenericEqIncrSolverBase - -(** A solver is something that can translate a system into a solution (hash-table) *) -module type GenericEqSolver = - functor (S:EqConstrSys) -> - functor (H:Hashtbl.S with type key=S.v) -> - sig - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. *) - val solve : (S.v*S.d) list -> S.v list -> S.d H.t - end - -(** A solver is something that can translate a system into a solution (hash-table) *) -module type GenericGlobSolver = - functor (S:GlobConstrSys) -> - functor (LH:Hashtbl.S with type key=S.LVar.t) -> - functor (GH:Hashtbl.S with type key=S.GVar.t) -> - sig - type marshal - - val copy_marshal: marshal -> marshal - val relift_marshal: marshal -> marshal - - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. - As a second component the solver returns data structures for incremental serialization. *) - val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal - end - - module StdV = struct let is_write_only _ = false @@ -542,7 +420,7 @@ end module type SpecSys = sig module Spec: Spec - module EQSys: GlobConstrSys with module LVar = VarF (Spec.C) + module EQSys: ConstrSys.GlobConstrSys with module LVar = VarF (Spec.C) and module GVar = GVarF (Spec.V) and module D = Spec.D and module G = GVarG (Spec.G) (Spec.C) diff --git a/src/framework/constrSys.ml b/src/framework/constrSys.ml new file mode 100644 index 0000000000..936e03355c --- /dev/null +++ b/src/framework/constrSys.ml @@ -0,0 +1,125 @@ +(** {{!MonSystem} constraint system} signatures. *) + +open Batteries + +module type SysVar = +sig + type t + val is_write_only: t -> bool +end + +module type VarType = +sig + include Hashtbl.HashedType + include SysVar with type t := t + val pretty_trace: unit -> t -> GoblintCil.Pretty.doc + val compare : t -> t -> int + + val printXml : 'a BatInnerIO.output -> t -> unit + val var_id : t -> string + val node : t -> MyCFG.node + val relift : t -> t (* needed only for incremental+hashcons to re-hashcons contexts after loading *) +end + +(** Abstract incremental change to constraint system. + @param 'v constrain system variable type *) +type 'v sys_change_info = { + obsolete: 'v list; (** Variables to destabilize. *) + delete: 'v list; (** Variables to delete. *) + reluctant: 'v list; (** Variables to solve reluctantly. *) + restart: 'v list; (** Variables to restart. *) +} + +(** A side-effecting system. *) +module type MonSystem = +sig + type v (* variables *) + type d (* values *) + type 'a m (* basically a monad carrier *) + + (** Variables must be hashable, comparable, etc. *) + module Var : VarType with type t = v + + (** Values must form a lattice. *) + module Dom : Lattice.S with type t = d + + (** The system in functional form. *) + val system : v -> ((v -> d) -> (v -> d -> unit) -> d) m + + val sys_change: (v -> d) -> v sys_change_info + (** Compute incremental constraint system change from old solution. *) +end + +(** Any system of side-effecting equations over lattices. *) +module type EqConstrSys = MonSystem with type 'a m := 'a option + +(** A side-effecting system with globals. *) +module type GlobConstrSys = +sig + module LVar : VarType + module GVar : VarType + + module D : Lattice.S + module G : Lattice.S + val system : LVar.t -> ((LVar.t -> D.t) -> (LVar.t -> D.t -> unit) -> (GVar.t -> G.t) -> (GVar.t -> G.t -> unit) -> D.t) option + val iter_vars: (LVar.t -> D.t) -> (GVar.t -> G.t) -> VarQuery.t -> LVar.t VarQuery.f -> GVar.t VarQuery.f -> unit + val sys_change: (LVar.t -> D.t) -> (GVar.t -> G.t) -> [`L of LVar.t | `G of GVar.t] sys_change_info +end + +(** A solver is something that can translate a system into a solution (hash-table). + Incremental solver has data to be marshaled. *) +module type GenericEqIncrSolverBase = + functor (S:EqConstrSys) -> + functor (H:Hashtbl.S with type key=S.v) -> + sig + type marshal + + val copy_marshal: marshal -> marshal + val relift_marshal: marshal -> marshal + + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. + As a second component the solver returns data structures for incremental serialization. *) + val solve : (S.v*S.d) list -> S.v list -> marshal option -> S.d H.t * marshal + end + +(** (Incremental) solver argument, indicating which postsolving should be performed by the solver. *) +module type IncrSolverArg = +sig + val should_prune: bool + val should_verify: bool + val should_warn: bool + val should_save_run: bool +end + +(** An incremental solver takes the argument about postsolving. *) +module type GenericEqIncrSolver = + functor (Arg: IncrSolverArg) -> + GenericEqIncrSolverBase + +(** A solver is something that can translate a system into a solution (hash-table) *) +module type GenericEqSolver = + functor (S:EqConstrSys) -> + functor (H:Hashtbl.S with type key=S.v) -> + sig + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. *) + val solve : (S.v*S.d) list -> S.v list -> S.d H.t + end + +(** A solver is something that can translate a system into a solution (hash-table) *) +module type GenericGlobSolver = + functor (S:GlobConstrSys) -> + functor (LH:Hashtbl.S with type key=S.LVar.t) -> + functor (GH:Hashtbl.S with type key=S.GVar.t) -> + sig + type marshal + + val copy_marshal: marshal -> marshal + val relift_marshal: marshal -> marshal + + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. + As a second component the solver returns data structures for incremental serialization. *) + val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal + end \ No newline at end of file diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 8039a867d8..28e6f2f287 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -5,6 +5,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open ConstrSys open GobConfig module M = Messages diff --git a/src/framework/control.ml b/src/framework/control.ml index 54fd1d7774..26ef8bbda0 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -6,6 +6,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open ConstrSys open GobConfig open Constraints diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 2cbe737079..a340cb085f 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -21,6 +21,7 @@ module CfgTools = CfgTools A dynamic composition of analyses is combined with CFGs to produce a constraint system. *) module Analyses = Analyses +module ConstrSys = ConstrSys module Constraints = Constraints module AnalysisState = AnalysisState module AnalysisStateUtil = AnalysisStateUtil diff --git a/src/solvers/effectWConEq.ml b/src/solvers/effectWConEq.ml index c6dcf8f0e9..2455dc10f2 100644 --- a/src/solvers/effectWConEq.ml +++ b/src/solvers/effectWConEq.ml @@ -1,7 +1,7 @@ (** ([effectWConEq]). *) open Batteries -open Analyses +open ConstrSys open Constraints module Make = diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 2569341dd1..025074c149 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -2,7 +2,7 @@ open Batteries open GobConfig -open Analyses +open ConstrSys module LoadRunSolver: GenericEqSolver = functor (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> diff --git a/src/solvers/postSolver.ml b/src/solvers/postSolver.ml index e01560c752..ebfa17063a 100644 --- a/src/solvers/postSolver.ml +++ b/src/solvers/postSolver.ml @@ -1,9 +1,10 @@ (** Extra constraint system evaluation pass for warning generation, verification, pruning, etc. *) open Batteries -open Analyses +open ConstrSys open GobConfig module Pretty = GoblintCil.Pretty +module M = Messages (** Postsolver with hooks. *) module type S = diff --git a/src/solvers/sLR.ml b/src/solvers/sLR.ml index 4904731b61..d6bc2a56a5 100644 --- a/src/solvers/sLR.ml +++ b/src/solvers/sLR.ml @@ -3,7 +3,7 @@ @see Apinis, K. Frameworks for analyzing multi-threaded C. *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages diff --git a/src/solvers/sLRphased.ml b/src/solvers/sLRphased.ml index c120a7bc6c..5f48669b14 100644 --- a/src/solvers/sLRphased.ml +++ b/src/solvers/sLRphased.ml @@ -1,7 +1,7 @@ (** Two-phased terminating SLR3 solver ([slr3tp]). *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages open SLR diff --git a/src/solvers/sLRterm.ml b/src/solvers/sLRterm.ml index eb11447d11..b90e195ec4 100644 --- a/src/solvers/sLRterm.ml +++ b/src/solvers/sLRterm.ml @@ -2,7 +2,7 @@ Simpler version of {!SLRphased} without phases. *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages open SLR diff --git a/src/solvers/selector.ml b/src/solvers/selector.ml index 664cbe0513..854b8e1036 100644 --- a/src/solvers/selector.ml +++ b/src/solvers/selector.ml @@ -1,7 +1,7 @@ (** Solver, which delegates at runtime to the configured solver. *) open Batteries -open Analyses +open ConstrSys open GobConfig (* Registered solvers. *) diff --git a/src/solvers/td3.ml b/src/solvers/td3.ml index 07edc632c7..b2696787e6 100644 --- a/src/solvers/td3.ml +++ b/src/solvers/td3.ml @@ -15,9 +15,11 @@ *) open Batteries -open Analyses +open ConstrSys open Messages +module M = Messages + module type Hooks = sig module S: EqConstrSys diff --git a/src/solvers/topDown.ml b/src/solvers/topDown.ml index c6b20d28db..fe6aaf53da 100644 --- a/src/solvers/topDown.ml +++ b/src/solvers/topDown.ml @@ -2,7 +2,7 @@ Simpler version of {!Td3} without terminating, space-efficiency and incremental. *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages diff --git a/src/solvers/topDown_deprecated.ml b/src/solvers/topDown_deprecated.ml index 1f51244458..3e1329aa19 100644 --- a/src/solvers/topDown_deprecated.ml +++ b/src/solvers/topDown_deprecated.ml @@ -1,7 +1,7 @@ (** Deprecated top-down solver ([topdown_deprecated]). *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages diff --git a/src/solvers/topDown_space_cache_term.ml b/src/solvers/topDown_space_cache_term.ml index a78d90559d..1bf8127fb9 100644 --- a/src/solvers/topDown_space_cache_term.ml +++ b/src/solvers/topDown_space_cache_term.ml @@ -2,7 +2,7 @@ Simpler version of {!Td3} without incremental. *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages diff --git a/src/solvers/topDown_term.ml b/src/solvers/topDown_term.ml index ec07995586..f62aa74a5c 100644 --- a/src/solvers/topDown_term.ml +++ b/src/solvers/topDown_term.ml @@ -2,7 +2,7 @@ Simpler version of {!Td3} without space-efficiency and incremental. *) open Batteries -open Analyses +open ConstrSys open Constraints open Messages diff --git a/src/solvers/worklist.ml b/src/solvers/worklist.ml index b525764c74..2954928a23 100644 --- a/src/solvers/worklist.ml +++ b/src/solvers/worklist.ml @@ -1,7 +1,7 @@ (** Worklist solver ([WL]). *) open Batteries -open Analyses +open ConstrSys open Constraints module Make = From f97869c3aa7e655bdb8fe5bebf445b5959cbe63e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 15:09:59 +0200 Subject: [PATCH 225/233] Extract constraint systems from Constraints module --- src/framework/constrSys.ml | 176 +++++++++++++++++++++- src/framework/constraints.ml | 189 ------------------------ src/solvers/effectWConEq.ml | 3 +- src/solvers/generic.ml | 2 +- src/solvers/postSolver.ml | 19 +++ src/solvers/sLR.ml | 29 ++-- src/solvers/sLRphased.ml | 3 +- src/solvers/sLRterm.ml | 3 +- src/solvers/td3.ml | 2 +- src/solvers/topDown.ml | 3 +- src/solvers/topDown_deprecated.ml | 3 +- src/solvers/topDown_space_cache_term.ml | 3 +- src/solvers/topDown_term.ml | 3 +- src/solvers/worklist.ml | 3 +- 14 files changed, 218 insertions(+), 223 deletions(-) diff --git a/src/framework/constrSys.ml b/src/framework/constrSys.ml index 936e03355c..1698d5f214 100644 --- a/src/framework/constrSys.ml +++ b/src/framework/constrSys.ml @@ -122,4 +122,178 @@ module type GenericGlobSolver = reached from starting values [xs]. As a second component the solver returns data structures for incremental serialization. *) val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal - end \ No newline at end of file + end + + +(** Combined variables so that we can also use the more common [EqConstrSys] + that uses only one kind of a variable. *) +module Var2 (LV:VarType) (GV:VarType) + : VarType + with type t = [ `L of LV.t | `G of GV.t ] += +struct + type t = [ `L of LV.t | `G of GV.t ] [@@deriving eq, ord, hash] + let relift = function + | `L x -> `L (LV.relift x) + | `G x -> `G (GV.relift x) + + let pretty_trace () = function + | `L a -> GoblintCil.Pretty.dprintf "L:%a" LV.pretty_trace a + | `G a -> GoblintCil.Pretty.dprintf "G:%a" GV.pretty_trace a + + let printXml f = function + | `L a -> LV.printXml f a + | `G a -> GV.printXml f a + + let var_id = function + | `L a -> LV.var_id a + | `G a -> GV.var_id a + + let node = function + | `L a -> LV.node a + | `G a -> GV.node a + + let is_write_only = function + | `L a -> LV.is_write_only a + | `G a -> GV.is_write_only a +end + + +(** Translate a [GlobConstrSys] into a [EqConstrSys] *) +module EqConstrSysFromGlobConstrSys (S:GlobConstrSys) + : EqConstrSys with type v = Var2(S.LVar)(S.GVar).t + and type d = Lattice.Lift2(S.G)(S.D).t + and module Var = Var2(S.LVar)(S.GVar) + and module Dom = Lattice.Lift2(S.G)(S.D) += +struct + module Var = Var2(S.LVar)(S.GVar) + module Dom = + struct + include Lattice.Lift2 (S.G) (S.D) + let printXml f = function + | `Lifted1 a -> S.G.printXml f a + | `Lifted2 a -> S.D.printXml f a + | (`Bot | `Top) as x -> printXml f x + end + type v = Var.t + type d = Dom.t + + let getG = function + | `Lifted1 x -> x + | `Bot -> S.G.bot () + | `Top -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has top value" + | `Lifted2 _ -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has local value" + + let getL = function + | `Lifted2 x -> x + | `Bot -> S.D.bot () + | `Top -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has top value" + | `Lifted1 _ -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has global value" + + let l, g = (fun x -> `L x), (fun x -> `G x) + let lD, gD = (fun x -> `Lifted2 x), (fun x -> `Lifted1 x) + + let conv f get set = + f (getL % get % l) (fun x v -> set (l x) (lD v)) + (getG % get % g) (fun x v -> set (g x) (gD v)) + |> lD + + let system = function + | `G _ -> None + | `L x -> Option.map conv (S.system x) + + let sys_change get = + S.sys_change (getL % get % l) (getG % get % g) +end + +(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution with given [Hashtbl.S] for the [EqConstrSys]. *) +module GlobConstrSolFromEqConstrSolBase (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) (VH: Hashtbl.S with type key = Var2 (S.LVar) (S.GVar).t) = +struct + let split_solution hm = + let l' = LH.create 113 in + let g' = GH.create 113 in + let split_vars x d = match x with + | `L x -> + begin match d with + | `Lifted2 d -> LH.replace l' x d + (* | `Bot -> () *) + (* Since Verify2 is broken and only checks existing keys, add it with local bottom value. + This works around some cases, where Verify2 would not detect a problem due to completely missing variable. *) + | `Bot -> LH.replace l' x (S.D.bot ()) + | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has top value" + | `Lifted1 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has global value" + end + | `G x -> + begin match d with + | `Lifted1 d -> GH.replace g' x d + | `Bot -> () + | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has top value" + | `Lifted2 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has local value" + end + in + VH.iter split_vars hm; + (l', g') +end + +(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution. *) +module GlobConstrSolFromEqConstrSol (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) = +struct + module S2 = EqConstrSysFromGlobConstrSys (S) + module VH = Hashtbl.Make (S2.Var) + + include GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) +end + +(** Transforms a [GenericEqIncrSolver] into a [GenericGlobSolver]. *) +module GlobSolverFromEqSolver (Sol:GenericEqIncrSolverBase) + = functor (S:GlobConstrSys) -> + functor (LH:Hashtbl.S with type key=S.LVar.t) -> + functor (GH:Hashtbl.S with type key=S.GVar.t) -> + struct + module EqSys = EqConstrSysFromGlobConstrSys (S) + + module VH : Hashtbl.S with type key=EqSys.v = Hashtbl.Make(EqSys.Var) + module Sol' = Sol (EqSys) (VH) + + module Splitter = GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) (* reuse EqSys and VH *) + + type marshal = Sol'.marshal + + let copy_marshal = Sol'.copy_marshal + let relift_marshal = Sol'.relift_marshal + + let solve ls gs l old_data = + let vs = List.map (fun (x,v) -> `L x, `Lifted2 v) ls + @ List.map (fun (x,v) -> `G x, `Lifted1 v) gs in + let sv = List.map (fun x -> `L x) l in + let hm, solver_data = Sol'.solve vs sv old_data in + Splitter.split_solution hm, solver_data + end + + +(** [EqConstrSys] where [current_var] indicates the variable whose right-hand side is currently being evaluated. *) +module CurrentVarEqConstrSys (S: EqConstrSys) = +struct + let current_var = ref None + + module S = + struct + include S + + let system x = + match S.system x with + | None -> None + | Some f -> + let f' get set = + let old_current_var = !current_var in + current_var := Some x; + Fun.protect ~finally:(fun () -> + current_var := old_current_var + ) (fun () -> + f get set + ) + in + Some f' + end +end diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 28e6f2f287..f5c024c24f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -502,38 +502,6 @@ sig val increment: increment_data option end -(** Combined variables so that we can also use the more common [EqConstrSys] - that uses only one kind of a variable. *) -module Var2 (LV:VarType) (GV:VarType) - : VarType - with type t = [ `L of LV.t | `G of GV.t ] -= -struct - type t = [ `L of LV.t | `G of GV.t ] [@@deriving eq, ord, hash] - let relift = function - | `L x -> `L (LV.relift x) - | `G x -> `G (GV.relift x) - - let pretty_trace () = function - | `L a -> Pretty.dprintf "L:%a" LV.pretty_trace a - | `G a -> Pretty.dprintf "G:%a" GV.pretty_trace a - - let printXml f = function - | `L a -> LV.printXml f a - | `G a -> GV.printXml f a - - let var_id = function - | `L a -> LV.var_id a - | `G a -> GV.var_id a - - let node = function - | `L a -> LV.node a - | `G a -> GV.node a - - let is_write_only = function - | `L a -> LV.is_write_only a - | `G a -> GV.is_write_only a -end (** The main point of this file---generating a [GlobConstrSys] from a [Spec]. *) module FromSpec (S:Spec) (Cfg:CfgBackward) (I: Increment) @@ -1054,137 +1022,6 @@ struct {obsolete; delete; reluctant; restart} end -(** Convert a non-incremental solver into an "incremental" solver. - It will solve from scratch, perform standard postsolving and have no marshal data. *) -module EqIncrSolverFromEqSolver (Sol: GenericEqSolver): GenericEqIncrSolver = - functor (Arg: IncrSolverArg) (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> - struct - module Sol = Sol (S) (VH) - module Post = PostSolver.MakeList (PostSolver.ListArgFromStdArg (S) (VH) (Arg)) - - type marshal = unit - let copy_marshal () = () - let relift_marshal () = () - - let solve xs vs _ = - let vh = Sol.solve xs vs in - Post.post xs vs vh; - (vh, ()) - end - - -(** Translate a [GlobConstrSys] into a [EqConstrSys] *) -module EqConstrSysFromGlobConstrSys (S:GlobConstrSys) - : EqConstrSys with type v = Var2(S.LVar)(S.GVar).t - and type d = Lattice.Lift2(S.G)(S.D).t - and module Var = Var2(S.LVar)(S.GVar) - and module Dom = Lattice.Lift2(S.G)(S.D) -= -struct - module Var = Var2(S.LVar)(S.GVar) - module Dom = - struct - include Lattice.Lift2 (S.G) (S.D) - let printXml f = function - | `Lifted1 a -> S.G.printXml f a - | `Lifted2 a -> S.D.printXml f a - | (`Bot | `Top) as x -> printXml f x - end - type v = Var.t - type d = Dom.t - - let getG = function - | `Lifted1 x -> x - | `Bot -> S.G.bot () - | `Top -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has top value" - | `Lifted2 _ -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has local value" - - let getL = function - | `Lifted2 x -> x - | `Bot -> S.D.bot () - | `Top -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has top value" - | `Lifted1 _ -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has global value" - - let l, g = (fun x -> `L x), (fun x -> `G x) - let lD, gD = (fun x -> `Lifted2 x), (fun x -> `Lifted1 x) - - let conv f get set = - f (getL % get % l) (fun x v -> set (l x) (lD v)) - (getG % get % g) (fun x v -> set (g x) (gD v)) - |> lD - - let system = function - | `G _ -> None - | `L x -> Option.map conv (S.system x) - - let sys_change get = - S.sys_change (getL % get % l) (getG % get % g) -end - -(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution with given [Hashtbl.S] for the [EqConstrSys]. *) -module GlobConstrSolFromEqConstrSolBase (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) (VH: Hashtbl.S with type key = Var2 (S.LVar) (S.GVar).t) = -struct - let split_solution hm = - let l' = LH.create 113 in - let g' = GH.create 113 in - let split_vars x d = match x with - | `L x -> - begin match d with - | `Lifted2 d -> LH.replace l' x d - (* | `Bot -> () *) - (* Since Verify2 is broken and only checks existing keys, add it with local bottom value. - This works around some cases, where Verify2 would not detect a problem due to completely missing variable. *) - | `Bot -> LH.replace l' x (S.D.bot ()) - | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has top value" - | `Lifted1 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has global value" - end - | `G x -> - begin match d with - | `Lifted1 d -> GH.replace g' x d - | `Bot -> () - | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has top value" - | `Lifted2 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has local value" - end - in - VH.iter split_vars hm; - (l', g') -end - -(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution. *) -module GlobConstrSolFromEqConstrSol (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) = -struct - module S2 = EqConstrSysFromGlobConstrSys (S) - module VH = Hashtbl.Make (S2.Var) - - include GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) -end - -(** Transforms a [GenericEqIncrSolver] into a [GenericGlobSolver]. *) -module GlobSolverFromEqSolver (Sol:GenericEqIncrSolverBase) - = functor (S:GlobConstrSys) -> - functor (LH:Hashtbl.S with type key=S.LVar.t) -> - functor (GH:Hashtbl.S with type key=S.GVar.t) -> - struct - module EqSys = EqConstrSysFromGlobConstrSys (S) - - module VH : Hashtbl.S with type key=EqSys.v = Hashtbl.Make(EqSys.Var) - module Sol' = Sol (EqSys) (VH) - - module Splitter = GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) (* reuse EqSys and VH *) - - type marshal = Sol'.marshal - - let copy_marshal = Sol'.copy_marshal - let relift_marshal = Sol'.relift_marshal - - let solve ls gs l old_data = - let vs = List.map (fun (x,v) -> `L x, `Lifted2 v) ls - @ List.map (fun (x,v) -> `G x, `Lifted1 v) gs in - let sv = List.map (fun x -> `L x) l in - let hm, solver_data = Sol'.solve vs sv old_data in - Splitter.split_solution hm, solver_data - end - (** Add path sensitivity to a analysis *) module PathSensitive2 (Spec:Spec) @@ -2057,29 +1894,3 @@ struct ignore (Pretty.printf "Nodes comparison summary: %t\n" (fun () -> msg)); print_newline (); end - -(** [EqConstrSys] where [current_var] indicates the variable whose right-hand side is currently being evaluated. *) -module CurrentVarEqConstrSys (S: EqConstrSys) = -struct - let current_var = ref None - - module S = - struct - include S - - let system x = - match S.system x with - | None -> None - | Some f -> - let f' get set = - let old_current_var = !current_var in - current_var := Some x; - Fun.protect ~finally:(fun () -> - current_var := old_current_var - ) (fun () -> - f get set - ) - in - Some f' - end -end diff --git a/src/solvers/effectWConEq.ml b/src/solvers/effectWConEq.ml index 2455dc10f2..3cca6361b4 100644 --- a/src/solvers/effectWConEq.ml +++ b/src/solvers/effectWConEq.ml @@ -2,7 +2,6 @@ open Batteries open ConstrSys -open Constraints module Make = functor (S:EqConstrSys) -> @@ -88,4 +87,4 @@ module Make = end let _ = - Selector.add_solver ("effectWConEq", (module EqIncrSolverFromEqSolver (Make))); + Selector.add_solver ("effectWConEq", (module PostSolver.EqIncrSolverFromEqSolver (Make))); diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 025074c149..636aed8831 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -30,7 +30,7 @@ module LoadRunSolver: GenericEqSolver = end module LoadRunIncrSolver: GenericEqIncrSolver = - Constraints.EqIncrSolverFromEqSolver (LoadRunSolver) + PostSolver.EqIncrSolverFromEqSolver (LoadRunSolver) module SolverStats (S:EqConstrSys) (HM:Hashtbl.S with type key = S.v) = struct diff --git a/src/solvers/postSolver.ml b/src/solvers/postSolver.ml index ebfa17063a..7f4f9c2b1f 100644 --- a/src/solvers/postSolver.ml +++ b/src/solvers/postSolver.ml @@ -316,3 +316,22 @@ struct |> List.map snd |> List.map (fun (module F: F) -> (module F (S) (VH): M)) end + +(* Here to avoid module cycle between ConstrSys and PostSolver. *) +(** Convert a non-incremental solver into an "incremental" solver. + It will solve from scratch, perform standard postsolving and have no marshal data. *) +module EqIncrSolverFromEqSolver (Sol: GenericEqSolver): GenericEqIncrSolver = + functor (Arg: IncrSolverArg) (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> + struct + module Sol = Sol (S) (VH) + module Post = MakeList (ListArgFromStdArg (S) (VH) (Arg)) + + type marshal = unit + let copy_marshal () = () + let relift_marshal () = () + + let solve xs vs _ = + let vh = Sol.solve xs vs in + Post.post xs vs vh; + (vh, ()) + end diff --git a/src/solvers/sLR.ml b/src/solvers/sLR.ml index d6bc2a56a5..d05d87c4f3 100644 --- a/src/solvers/sLR.ml +++ b/src/solvers/sLR.ml @@ -4,7 +4,6 @@ open Batteries open ConstrSys -open Constraints open Messages let narrow f = if GobConfig.get_bool "exp.no-narrow" then (fun a b -> a) else f @@ -522,29 +521,29 @@ let _ = let module W1 = JustWiden (struct let ver = 1 end) in let module W2 = JustWiden (struct let ver = 2 end) in let module W3 = JustWiden (struct let ver = 3 end) in - Selector.add_solver ("widen1", (module EqIncrSolverFromEqSolver (W1))); - Selector.add_solver ("widen2", (module EqIncrSolverFromEqSolver (W2))); - Selector.add_solver ("widen3", (module EqIncrSolverFromEqSolver (W3))); + Selector.add_solver ("widen1", (module PostSolver.EqIncrSolverFromEqSolver (W1))); + Selector.add_solver ("widen2", (module PostSolver.EqIncrSolverFromEqSolver (W2))); + Selector.add_solver ("widen3", (module PostSolver.EqIncrSolverFromEqSolver (W3))); let module S2 = TwoPhased (struct let ver = 1 end) in - Selector.add_solver ("two", (module EqIncrSolverFromEqSolver (S2))); + Selector.add_solver ("two", (module PostSolver.EqIncrSolverFromEqSolver (S2))); let module S1 = Make (struct let ver = 1 end) in - Selector.add_solver ("new", (module EqIncrSolverFromEqSolver (S1))); - Selector.add_solver ("slr+", (module EqIncrSolverFromEqSolver (S1))) + Selector.add_solver ("new", (module PostSolver.EqIncrSolverFromEqSolver (S1))); + Selector.add_solver ("slr+", (module PostSolver.EqIncrSolverFromEqSolver (S1))) let _ = let module S1 = Make (struct let ver = 1 end) in let module S2 = Make (struct let ver = 2 end) in let module S3 = SLR3 in let module S4 = Make (struct let ver = 4 end) in - Selector.add_solver ("slr1", (module EqIncrSolverFromEqSolver (S1))); (* W&N at every program point *) - Selector.add_solver ("slr2", (module EqIncrSolverFromEqSolver (S2))); (* W&N dynamic at certain points, growing number of W-points *) - Selector.add_solver ("slr3", (module EqIncrSolverFromEqSolver (S3))); (* same as S2 but number of W-points may also shrink *) - Selector.add_solver ("slr4", (module EqIncrSolverFromEqSolver (S4))); (* restarting: set influenced variables to bot and start up-iteration instead of narrowing *) + Selector.add_solver ("slr1", (module PostSolver.EqIncrSolverFromEqSolver (S1))); (* W&N at every program point *) + Selector.add_solver ("slr2", (module PostSolver.EqIncrSolverFromEqSolver (S2))); (* W&N dynamic at certain points, growing number of W-points *) + Selector.add_solver ("slr3", (module PostSolver.EqIncrSolverFromEqSolver (S3))); (* same as S2 but number of W-points may also shrink *) + Selector.add_solver ("slr4", (module PostSolver.EqIncrSolverFromEqSolver (S4))); (* restarting: set influenced variables to bot and start up-iteration instead of narrowing *) let module S1p = PrintInfluence (Make (struct let ver = 1 end)) in let module S2p = PrintInfluence (Make (struct let ver = 2 end)) in let module S3p = PrintInfluence (Make (struct let ver = 3 end)) in let module S4p = PrintInfluence (Make (struct let ver = 4 end)) in - Selector.add_solver ("slr1p", (module EqIncrSolverFromEqSolver (S1p))); (* same as S1-4 above but with side-effects *) - Selector.add_solver ("slr2p", (module EqIncrSolverFromEqSolver (S2p))); - Selector.add_solver ("slr3p", (module EqIncrSolverFromEqSolver (S3p))); - Selector.add_solver ("slr4p", (module EqIncrSolverFromEqSolver (S4p))); + Selector.add_solver ("slr1p", (module PostSolver.EqIncrSolverFromEqSolver (S1p))); (* same as S1-4 above but with side-effects *) + Selector.add_solver ("slr2p", (module PostSolver.EqIncrSolverFromEqSolver (S2p))); + Selector.add_solver ("slr3p", (module PostSolver.EqIncrSolverFromEqSolver (S3p))); + Selector.add_solver ("slr4p", (module PostSolver.EqIncrSolverFromEqSolver (S4p))); diff --git a/src/solvers/sLRphased.ml b/src/solvers/sLRphased.ml index 5f48669b14..17571f0138 100644 --- a/src/solvers/sLRphased.ml +++ b/src/solvers/sLRphased.ml @@ -2,7 +2,6 @@ open Batteries open ConstrSys -open Constraints open Messages open SLR @@ -205,4 +204,4 @@ module Make = end let _ = - Selector.add_solver ("slr3tp", (module EqIncrSolverFromEqSolver (Make))); (* two-phased slr3t *) + Selector.add_solver ("slr3tp", (module PostSolver.EqIncrSolverFromEqSolver (Make))); (* two-phased slr3t *) diff --git a/src/solvers/sLRterm.ml b/src/solvers/sLRterm.ml index b90e195ec4..8ec34c7dc2 100644 --- a/src/solvers/sLRterm.ml +++ b/src/solvers/sLRterm.ml @@ -3,7 +3,6 @@ open Batteries open ConstrSys -open Constraints open Messages open SLR @@ -224,4 +223,4 @@ module SLR3term = end let _ = - Selector.add_solver ("slr3t", (module EqIncrSolverFromEqSolver (SLR3term))); (* same as S2 but number of W-points may also shrink + terminating? *) + Selector.add_solver ("slr3t", (module PostSolver.EqIncrSolverFromEqSolver (SLR3term))); (* same as S2 but number of W-points may also shrink + terminating? *) diff --git a/src/solvers/td3.ml b/src/solvers/td3.ml index b2696787e6..54b7520cd6 100644 --- a/src/solvers/td3.ml +++ b/src/solvers/td3.ml @@ -194,7 +194,7 @@ module Base = type phase = Widen | Narrow [@@deriving show] (* used in inner solve *) - module CurrentVarS = Constraints.CurrentVarEqConstrSys (S) + module CurrentVarS = ConstrSys.CurrentVarEqConstrSys (S) module S = CurrentVarS.S let solve st vs marshal = diff --git a/src/solvers/topDown.ml b/src/solvers/topDown.ml index fe6aaf53da..f7da560057 100644 --- a/src/solvers/topDown.ml +++ b/src/solvers/topDown.ml @@ -3,7 +3,6 @@ open Batteries open ConstrSys -open Constraints open Messages module WP = @@ -155,4 +154,4 @@ module WP = end let _ = - Selector.add_solver ("topdown", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/topDown_deprecated.ml b/src/solvers/topDown_deprecated.ml index 3e1329aa19..4e9799cf78 100644 --- a/src/solvers/topDown_deprecated.ml +++ b/src/solvers/topDown_deprecated.ml @@ -2,7 +2,6 @@ open Batteries open ConstrSys -open Constraints open Messages exception SolverCannotDoGlobals @@ -164,4 +163,4 @@ module TD3 = end let _ = - Selector.add_solver ("topdown_deprecated", (module EqIncrSolverFromEqSolver (TD3))); + Selector.add_solver ("topdown_deprecated", (module PostSolver.EqIncrSolverFromEqSolver (TD3))); diff --git a/src/solvers/topDown_space_cache_term.ml b/src/solvers/topDown_space_cache_term.ml index 1bf8127fb9..f6c256517c 100644 --- a/src/solvers/topDown_space_cache_term.ml +++ b/src/solvers/topDown_space_cache_term.ml @@ -3,7 +3,6 @@ open Batteries open ConstrSys -open Constraints open Messages module WP = @@ -197,4 +196,4 @@ module WP = end let _ = - Selector.add_solver ("topdown_space_cache_term", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown_space_cache_term", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/topDown_term.ml b/src/solvers/topDown_term.ml index f62aa74a5c..d15493b5a1 100644 --- a/src/solvers/topDown_term.ml +++ b/src/solvers/topDown_term.ml @@ -3,7 +3,6 @@ open Batteries open ConstrSys -open Constraints open Messages module WP = @@ -134,4 +133,4 @@ module WP = end let _ = - Selector.add_solver ("topdown_term", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown_term", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/worklist.ml b/src/solvers/worklist.ml index 2954928a23..b1a5d7e834 100644 --- a/src/solvers/worklist.ml +++ b/src/solvers/worklist.ml @@ -2,7 +2,6 @@ open Batteries open ConstrSys -open Constraints module Make = functor (S:EqConstrSys) -> @@ -63,4 +62,4 @@ module Make = let _ = - Selector.add_solver ("WL", (module EqIncrSolverFromEqSolver (Make))); + Selector.add_solver ("WL", (module PostSolver.EqIncrSolverFromEqSolver (Make))); From 07009f020e7874a688f8517e8417ff7b29836e25 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 15:21:21 +0200 Subject: [PATCH 226/233] Extract constraint system to goblint_constraint dune library --- src/{framework => constraint}/constrSys.ml | 0 src/constraint/constraint.mld | 16 ++++++++++++++++ src/constraint/dune | 21 +++++++++++++++++++++ src/{framework => constraint}/varQuery.ml | 0 src/{framework => constraint}/varQuery.mli | 0 src/dune | 2 +- src/index.mld | 3 +++ 7 files changed, 41 insertions(+), 1 deletion(-) rename src/{framework => constraint}/constrSys.ml (100%) create mode 100644 src/constraint/constraint.mld create mode 100644 src/constraint/dune rename src/{framework => constraint}/varQuery.ml (100%) rename src/{framework => constraint}/varQuery.mli (100%) diff --git a/src/framework/constrSys.ml b/src/constraint/constrSys.ml similarity index 100% rename from src/framework/constrSys.ml rename to src/constraint/constrSys.ml diff --git a/src/constraint/constraint.mld b/src/constraint/constraint.mld new file mode 100644 index 0000000000..695e7bfa0d --- /dev/null +++ b/src/constraint/constraint.mld @@ -0,0 +1,16 @@ +{0 Library goblint.constraint} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Framework} + +{2 Specification} +{!modules: +ConstrSys +} + +{2 Results} +{!modules: +VarQuery +} diff --git a/src/constraint/dune b/src/constraint/dune new file mode 100644 index 0000000000..2d11b9010f --- /dev/null +++ b/src/constraint/dune @@ -0,0 +1,21 @@ +(include_subdirs no) + +(library + (name goblint_constraint) + (public_name goblint.constraint) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_domain + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/framework/varQuery.ml b/src/constraint/varQuery.ml similarity index 100% rename from src/framework/varQuery.ml rename to src/constraint/varQuery.ml diff --git a/src/framework/varQuery.mli b/src/constraint/varQuery.mli similarity index 100% rename from src/framework/varQuery.mli rename to src/constraint/varQuery.mli diff --git a/src/dune b/src/dune index eac6640451..59845b8e03 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_library goblint_incremental goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_library goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/index.mld b/src/index.mld index 76b9d230dd..3ed2b8079f 100644 --- a/src/index.mld +++ b/src/index.mld @@ -16,6 +16,9 @@ This {{!page-common}unwrapped library} contains various common modules extracted {2 Library goblint.domain} This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. +{2 Library goblint.constraint} +This {{!page-constraint}unwrapped library} contains various constraint system modules extracted from {!Goblint_lib}. + {2 Library goblint.library} This {{!page-library}unwrapped library} contains various library specification modules extracted from {!Goblint_lib}. From 834df31e5821a5a38c956abe7f029c4e0a4b122c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 15:51:06 +0200 Subject: [PATCH 227/233] Extract solvers to goblint_solver dune library --- scripts/goblint-lib-modules.py | 2 ++ src/analyses/base.ml | 2 +- src/dune | 2 +- src/framework/control.ml | 6 +++--- src/goblint_lib.ml | 35 ---------------------------------- src/index.mld | 3 +++ src/maingoblint.ml | 4 ++-- src/solvers/dune | 22 +++++++++++++++++++++ src/solvers/goblint_solver.ml | 31 ++++++++++++++++++++++++++++++ 9 files changed, 65 insertions(+), 42 deletions(-) create mode 100644 src/solvers/dune create mode 100644 src/solvers/goblint_solver.ml diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index ec0e78e440..95ac9b268e 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -8,6 +8,7 @@ goblint_lib_paths = [ src_root_path / "goblint_lib.ml", + src_root_path / "solvers" / "goblint_solver.ml", src_root_path / "util" / "std" / "goblint_std.ml", ] goblint_lib_modules = set() @@ -33,6 +34,7 @@ # libraries "Goblint_std", + "Goblint_solver", "Goblint_timing", "Goblint_backtrace", "Goblint_tracing", diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 912d1f3bff..2b8ca4d429 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2871,7 +2871,7 @@ struct | "once" -> f (D.bot ()) | "fixpoint" -> - let module DFP = LocalFixpoint.Make (D) in + let module DFP = Goblint_solver.LocalFixpoint.Make (D) in DFP.lfp f | _ -> assert false diff --git a/src/dune b/src/dune index 59845b8e03..2ea9155b9b 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_library goblint_incremental goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_solver goblint_library goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/framework/control.ml b/src/framework/control.ml index 26ef8bbda0..391c766feb 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -85,7 +85,7 @@ struct let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in save_run <> "" end - module Slvr = (GlobSolverFromEqSolver (Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) + module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) (* The comparator *) module CompareGlobSys = Constraints.CompareGlobSys (SpecSys) @@ -476,7 +476,7 @@ struct let save_run_str = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in let lh, gh = if load_run <> "" then ( - let module S2' = (GlobSolverFromEqSolver (Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in + let module S2' = (GlobSolverFromEqSolver (Goblint_solver.Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) r2 ) else if compare_runs <> [] then ( @@ -582,7 +582,7 @@ struct let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) CompareGlobSys.compare (get_string "solver", get_string "comparesolver") (lh,gh) (r2) in - compare_with (Selector.choose_solver (get_string "comparesolver")) + compare_with (Goblint_solver.Selector.choose_solver (get_string "comparesolver")) ); (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index a340cb085f..1bc70f3f52 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -288,41 +288,6 @@ module Serialize = Serialize module CilMaps = CilMaps -(** {1 Solvers} - - Generic solvers are used to solve {{!Analyses.MonSystem} (side-effecting) constraint systems}. *) - -(** {2 Top-down} - - The top-down solver family. *) - -module Td3 = Td3 -module TopDown = TopDown -module TopDown_term = TopDown_term -module TopDown_space_cache_term = TopDown_space_cache_term -module TopDown_deprecated = TopDown_deprecated - -(** {2 SLR} - - The SLR solver family. *) - -module SLRphased = SLRphased -module SLRterm = SLRterm -module SLR = SLR - -(** {2 Other} *) - -module EffectWConEq = EffectWConEq -module Worklist = Worklist -module Generic = Generic -module Selector = Selector - -module PostSolver = PostSolver -module LocalFixpoint = LocalFixpoint -module SolverStats = SolverStats -module SolverBox = SolverBox - - (** {1 I/O} Various input/output interfaces and formats. *) diff --git a/src/index.mld b/src/index.mld index 3ed2b8079f..0763284c15 100644 --- a/src/index.mld +++ b/src/index.mld @@ -19,6 +19,9 @@ This {{!page-domain}unwrapped library} contains various domain modules extracted {2 Library goblint.constraint} This {{!page-constraint}unwrapped library} contains various constraint system modules extracted from {!Goblint_lib}. +{2 Library goblint.solver} +{!modules:Goblint_solver} + {2 Library goblint.library} This {{!page-library}unwrapped library} contains various library specification modules extracted from {!Goblint_lib}. diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 2c7d353594..f1d2793d2e 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -513,7 +513,7 @@ let preprocess_parse_merge () = let do_stats () = if get_bool "dbg.timing.enabled" then ( print_newline (); - SolverStats.print (); + Goblint_solver.SolverStats.print (); print_newline (); print_string "Timings:\n"; Timing.Default.print (Stdlib.Format.formatter_of_out_channel @@ Messages.get_out "timing" Legacy.stderr); @@ -521,7 +521,7 @@ let do_stats () = ) let reset_stats () = - SolverStats.reset (); + Goblint_solver.SolverStats.reset (); Timing.Default.reset (); Timing.Program.reset () diff --git a/src/solvers/dune b/src/solvers/dune new file mode 100644 index 0000000000..907d082089 --- /dev/null +++ b/src/solvers/dune @@ -0,0 +1,22 @@ +(include_subdirs no) + +(library + (name goblint_solver) + (public_name goblint.solver) + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_domain + goblint_constraint + goblint_incremental + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/solvers/goblint_solver.ml b/src/solvers/goblint_solver.ml new file mode 100644 index 0000000000..0a264d7dea --- /dev/null +++ b/src/solvers/goblint_solver.ml @@ -0,0 +1,31 @@ +(** Generic solvers for {{!ConstrSys.MonSystem} (side-effecting) constraint systems}. *) + +(** {1 Top-down} + + The top-down solver family. *) + +module Td3 = Td3 +module TopDown = TopDown +module TopDown_term = TopDown_term +module TopDown_space_cache_term = TopDown_space_cache_term +module TopDown_deprecated = TopDown_deprecated + +(** {1 SLR} + + The SLR solver family. *) + +module SLRphased = SLRphased +module SLRterm = SLRterm +module SLR = SLR + +(** {1 Other} *) + +module EffectWConEq = EffectWConEq +module Worklist = Worklist +module Generic = Generic +module Selector = Selector + +module PostSolver = PostSolver +module LocalFixpoint = LocalFixpoint +module SolverStats = SolverStats +module SolverBox = SolverBox From e9c0cc3b757e1f5904c4c1f2de70d2baba02c8e8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 15:54:47 +0200 Subject: [PATCH 228/233] Rename src/solvers -> src/solver --- scripts/goblint-lib-modules.py | 2 +- src/{solvers => solver}/dune | 0 src/{solvers => solver}/effectWConEq.ml | 0 src/{solvers => solver}/generic.ml | 0 src/{solvers => solver}/goblint_solver.ml | 0 src/{solvers => solver}/localFixpoint.ml | 0 src/{solvers => solver}/postSolver.ml | 0 src/{solvers => solver}/sLR.ml | 0 src/{solvers => solver}/sLRphased.ml | 0 src/{solvers => solver}/sLRterm.ml | 0 src/{solvers => solver}/selector.ml | 0 src/{solvers => solver}/solverBox.ml | 0 src/{solvers => solver}/solverStats.ml | 0 src/{solvers => solver}/td3.ml | 0 src/{solvers => solver}/topDown.ml | 0 src/{solvers => solver}/topDown_deprecated.ml | 0 src/{solvers => solver}/topDown_space_cache_term.ml | 0 src/{solvers => solver}/topDown_term.ml | 0 src/{solvers => solver}/worklist.ml | 0 19 files changed, 1 insertion(+), 1 deletion(-) rename src/{solvers => solver}/dune (100%) rename src/{solvers => solver}/effectWConEq.ml (100%) rename src/{solvers => solver}/generic.ml (100%) rename src/{solvers => solver}/goblint_solver.ml (100%) rename src/{solvers => solver}/localFixpoint.ml (100%) rename src/{solvers => solver}/postSolver.ml (100%) rename src/{solvers => solver}/sLR.ml (100%) rename src/{solvers => solver}/sLRphased.ml (100%) rename src/{solvers => solver}/sLRterm.ml (100%) rename src/{solvers => solver}/selector.ml (100%) rename src/{solvers => solver}/solverBox.ml (100%) rename src/{solvers => solver}/solverStats.ml (100%) rename src/{solvers => solver}/td3.ml (100%) rename src/{solvers => solver}/topDown.ml (100%) rename src/{solvers => solver}/topDown_deprecated.ml (100%) rename src/{solvers => solver}/topDown_space_cache_term.ml (100%) rename src/{solvers => solver}/topDown_term.ml (100%) rename src/{solvers => solver}/worklist.ml (100%) diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 95ac9b268e..8ae3b4b3eb 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -8,7 +8,7 @@ goblint_lib_paths = [ src_root_path / "goblint_lib.ml", - src_root_path / "solvers" / "goblint_solver.ml", + src_root_path / "solver" / "goblint_solver.ml", src_root_path / "util" / "std" / "goblint_std.ml", ] goblint_lib_modules = set() diff --git a/src/solvers/dune b/src/solver/dune similarity index 100% rename from src/solvers/dune rename to src/solver/dune diff --git a/src/solvers/effectWConEq.ml b/src/solver/effectWConEq.ml similarity index 100% rename from src/solvers/effectWConEq.ml rename to src/solver/effectWConEq.ml diff --git a/src/solvers/generic.ml b/src/solver/generic.ml similarity index 100% rename from src/solvers/generic.ml rename to src/solver/generic.ml diff --git a/src/solvers/goblint_solver.ml b/src/solver/goblint_solver.ml similarity index 100% rename from src/solvers/goblint_solver.ml rename to src/solver/goblint_solver.ml diff --git a/src/solvers/localFixpoint.ml b/src/solver/localFixpoint.ml similarity index 100% rename from src/solvers/localFixpoint.ml rename to src/solver/localFixpoint.ml diff --git a/src/solvers/postSolver.ml b/src/solver/postSolver.ml similarity index 100% rename from src/solvers/postSolver.ml rename to src/solver/postSolver.ml diff --git a/src/solvers/sLR.ml b/src/solver/sLR.ml similarity index 100% rename from src/solvers/sLR.ml rename to src/solver/sLR.ml diff --git a/src/solvers/sLRphased.ml b/src/solver/sLRphased.ml similarity index 100% rename from src/solvers/sLRphased.ml rename to src/solver/sLRphased.ml diff --git a/src/solvers/sLRterm.ml b/src/solver/sLRterm.ml similarity index 100% rename from src/solvers/sLRterm.ml rename to src/solver/sLRterm.ml diff --git a/src/solvers/selector.ml b/src/solver/selector.ml similarity index 100% rename from src/solvers/selector.ml rename to src/solver/selector.ml diff --git a/src/solvers/solverBox.ml b/src/solver/solverBox.ml similarity index 100% rename from src/solvers/solverBox.ml rename to src/solver/solverBox.ml diff --git a/src/solvers/solverStats.ml b/src/solver/solverStats.ml similarity index 100% rename from src/solvers/solverStats.ml rename to src/solver/solverStats.ml diff --git a/src/solvers/td3.ml b/src/solver/td3.ml similarity index 100% rename from src/solvers/td3.ml rename to src/solver/td3.ml diff --git a/src/solvers/topDown.ml b/src/solver/topDown.ml similarity index 100% rename from src/solvers/topDown.ml rename to src/solver/topDown.ml diff --git a/src/solvers/topDown_deprecated.ml b/src/solver/topDown_deprecated.ml similarity index 100% rename from src/solvers/topDown_deprecated.ml rename to src/solver/topDown_deprecated.ml diff --git a/src/solvers/topDown_space_cache_term.ml b/src/solver/topDown_space_cache_term.ml similarity index 100% rename from src/solvers/topDown_space_cache_term.ml rename to src/solver/topDown_space_cache_term.ml diff --git a/src/solvers/topDown_term.ml b/src/solver/topDown_term.ml similarity index 100% rename from src/solvers/topDown_term.ml rename to src/solver/topDown_term.ml diff --git a/src/solvers/worklist.ml b/src/solver/worklist.ml similarity index 100% rename from src/solvers/worklist.ml rename to src/solver/worklist.ml From 27295d709fd74facf3ca0789c2a769594ec41919 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 16:02:03 +0200 Subject: [PATCH 229/233] Fix SolverTest compilation --- unittest/dune | 2 +- unittest/solver/solverTest.ml | 6 ++++-- unittest/util/intOpsTest.ml | 1 - 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/unittest/dune b/unittest/dune index a08a4b2323..cb8dd668be 100644 --- a/unittest/dune +++ b/unittest/dune @@ -2,7 +2,7 @@ (test (name mainTest) - (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.sites.dune goblint.build-info.dune) + (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.constraint goblint.solver goblint.sites.dune goblint.build-info.dune) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall)) diff --git a/unittest/solver/solverTest.ml b/unittest/solver/solverTest.ml index 47ec5443ca..4e96266262 100644 --- a/unittest/solver/solverTest.ml +++ b/unittest/solver/solverTest.ml @@ -2,6 +2,8 @@ open Goblint_lib open OUnit2 open GoblintCil open Pretty +open ConstrSys +open Goblint_solver (* variables are strings *) module StringVar = @@ -43,7 +45,7 @@ module ConstrSys = struct | _ -> None let iter_vars _ _ _ _ _ = () - let sys_change _ _ = {Analyses.obsolete = []; delete = []; reluctant = []; restart = []} + let sys_change _ _ = {obsolete = []; delete = []; reluctant = []; restart = []} end module LH = BatHashtbl.Make (ConstrSys.LVar) @@ -55,7 +57,7 @@ struct let should_warn = false let should_save_run = false end -module Solver = Constraints.GlobSolverFromEqSolver (Constraints.EqIncrSolverFromEqSolver (EffectWConEq.Make) (PostSolverArg)) (ConstrSys) (LH) (GH) +module Solver = GlobSolverFromEqSolver (PostSolver.EqIncrSolverFromEqSolver (EffectWConEq.Make) (PostSolverArg)) (ConstrSys) (LH) (GH) let test1 _ = let id x = x in diff --git a/unittest/util/intOpsTest.ml b/unittest/util/intOpsTest.ml index 307d9e84b0..b0cb4dc984 100644 --- a/unittest/util/intOpsTest.ml +++ b/unittest/util/intOpsTest.ml @@ -1,6 +1,5 @@ open OUnit2 open Goblint_std -open Goblint_lib (* If the first operand of a div is negative, Zarith rounds the result away from zero. We thus always transform this into a division with a non-negative first operand. *) From 41499319b4e4463e8a0b044d2d98873ab7480b3e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 16:11:42 +0200 Subject: [PATCH 230/233] Add goblint_config dependency to goblint_solver --- src/solver/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/src/solver/dune b/src/solver/dune index 907d082089..bd6d7a4d0a 100644 --- a/src/solver/dune +++ b/src/solver/dune @@ -7,6 +7,7 @@ batteries.unthreaded goblint_std goblint_common + goblint_config goblint_domain goblint_constraint goblint_incremental From 580e5dce0e7d5c9e3269fd2df0581370aaa3fc14 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 16:24:52 +0200 Subject: [PATCH 231/233] Update Gobview with goblint.constraint and goblint.solver dependencies --- gobview | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gobview b/gobview index 3de13d7412..c8fcb09e9a 160000 --- a/gobview +++ b/gobview @@ -1 +1 @@ -Subproject commit 3de13d74124ab7bc30d8be299f02570d8f498b84 +Subproject commit c8fcb09e9a3e27de22d4803606d5784f667a542a From c4292c3d84284f6d26825f23c77fbfeabd423677 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 17:09:27 +0200 Subject: [PATCH 232/233] Move some modules from goblint_lib to goblint_common --- src/{ => common}/cdomains/floatOps/floatOps.ml | 0 src/{ => common}/cdomains/floatOps/floatOps.mli | 0 src/{ => common}/cdomains/floatOps/stubs.c | 0 src/common/common.mld | 7 +++++++ src/common/dune | 2 ++ src/{ => common}/util/analysisStateUtil.ml | 0 src/{ => common}/util/contextUtil.ml | 0 src/{ => common}/util/intOps.ml | 0 src/dune | 1 - 9 files changed, 9 insertions(+), 1 deletion(-) rename src/{ => common}/cdomains/floatOps/floatOps.ml (100%) rename src/{ => common}/cdomains/floatOps/floatOps.mli (100%) rename src/{ => common}/cdomains/floatOps/stubs.c (100%) rename src/{ => common}/util/analysisStateUtil.ml (100%) rename src/{ => common}/util/contextUtil.ml (100%) rename src/{ => common}/util/intOps.ml (100%) diff --git a/src/cdomains/floatOps/floatOps.ml b/src/common/cdomains/floatOps/floatOps.ml similarity index 100% rename from src/cdomains/floatOps/floatOps.ml rename to src/common/cdomains/floatOps/floatOps.ml diff --git a/src/cdomains/floatOps/floatOps.mli b/src/common/cdomains/floatOps/floatOps.mli similarity index 100% rename from src/cdomains/floatOps/floatOps.mli rename to src/common/cdomains/floatOps/floatOps.mli diff --git a/src/cdomains/floatOps/stubs.c b/src/common/cdomains/floatOps/stubs.c similarity index 100% rename from src/cdomains/floatOps/stubs.c rename to src/common/cdomains/floatOps/stubs.c diff --git a/src/common/common.mld b/src/common/common.mld index 2ad88c3758..2176a95b8a 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -16,6 +16,7 @@ CfgTools {2 Specification} {!modules: AnalysisState +AnalysisStateUtil ControlSpecC } @@ -42,6 +43,7 @@ Messages {2 General} {!modules: +IntOps LazyEval ResettableLazy MessageUtil @@ -55,6 +57,11 @@ Cilfacade RichVarinfo } +{2 Analysis-specific} +{!modules: +ContextUtil +} + {1 Library extensions} diff --git a/src/common/dune b/src/common/dune index 458ef02dcb..8576970900 100644 --- a/src/common/dune +++ b/src/common/dune @@ -16,6 +16,8 @@ goblint_timing qcheck-core.runner) (flags :standard -open Goblint_std) + (foreign_stubs (language c) (names stubs)) + (ocamlopt_flags :standard -no-float-const-prop) (preprocess (pps ppx_deriving.std diff --git a/src/util/analysisStateUtil.ml b/src/common/util/analysisStateUtil.ml similarity index 100% rename from src/util/analysisStateUtil.ml rename to src/common/util/analysisStateUtil.ml diff --git a/src/util/contextUtil.ml b/src/common/util/contextUtil.ml similarity index 100% rename from src/util/contextUtil.ml rename to src/common/util/contextUtil.ml diff --git a/src/util/intOps.ml b/src/common/util/intOps.ml similarity index 100% rename from src/util/intOps.ml rename to src/common/util/intOps.ml diff --git a/src/dune b/src/dune index 2ea9155b9b..d65acfc856 100644 --- a/src/dune +++ b/src/dune @@ -61,7 +61,6 @@ ) ) (flags :standard -open Goblint_std) - (foreign_stubs (language c) (names stubs)) (ocamlopt_flags :standard -no-float-const-prop) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson ppx_blob)) From 7ee115aa429a90e0c5a61f44ddb2c85503a12e93 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 17:50:56 +0200 Subject: [PATCH 233/233] Extract value domain to goblint_cdomain_value dune library --- .../analyses/wrapperFunctionAnalysis0.ml | 0 src/cdomain/value/cdomain_value.mld | 71 +++++++++++++++++++ .../value}/cdomains/addressDomain.ml | 0 .../value}/cdomains/addressDomain.mli | 0 .../value}/cdomains/addressDomain_intf.ml | 0 .../value}/cdomains/arrayDomain.ml | 0 .../value}/cdomains/arrayDomain.mli | 0 .../value}/cdomains/concDomain.ml | 0 .../value}/cdomains/floatDomain.ml | 0 .../value}/cdomains/floatDomain.mli | 0 src/{ => cdomain/value}/cdomains/intDomain.ml | 0 .../value}/cdomains/intDomain.mli | 0 .../value}/cdomains/jmpBufDomain.ml | 0 src/{ => cdomain/value}/cdomains/lval.ml | 0 .../value}/cdomains/mutexAttrDomain.ml | 0 src/{ => cdomain/value}/cdomains/mval.ml | 0 src/{ => cdomain/value}/cdomains/mval.mli | 0 src/{ => cdomain/value}/cdomains/mval_intf.ml | 0 .../value}/cdomains/nullByteSet.ml | 0 src/{ => cdomain/value}/cdomains/offset.ml | 0 src/{ => cdomain/value}/cdomains/offset.mli | 0 .../value}/cdomains/offset_intf.ml | 0 .../value}/cdomains/preValueDomain.ml | 0 .../value}/cdomains/stringDomain.ml | 0 .../value}/cdomains/stringDomain.mli | 0 .../value}/cdomains/structDomain.ml | 0 .../value}/cdomains/structDomain.mli | 0 .../value}/cdomains/threadIdDomain.ml | 0 .../value}/cdomains/unionDomain.ml | 0 .../value}/cdomains/valueDomain.ml | 0 src/{ => cdomain/value}/domains/invariant.ml | 0 .../value}/domains/invariantCil.ml | 0 .../value}/domains/valueDomainQueries.ml | 0 src/cdomain/value/dune | 24 +++++++ src/{ => cdomain/value}/util/precisionUtil.ml | 0 .../value}/util/wideningThresholds.ml | 0 .../value}/util/wideningThresholds.mli | 0 src/dune | 2 +- src/index.mld | 3 + unittest/dune | 2 +- 40 files changed, 100 insertions(+), 2 deletions(-) rename src/{ => cdomain/value}/analyses/wrapperFunctionAnalysis0.ml (100%) create mode 100644 src/cdomain/value/cdomain_value.mld rename src/{ => cdomain/value}/cdomains/addressDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/addressDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/addressDomain_intf.ml (100%) rename src/{ => cdomain/value}/cdomains/arrayDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/arrayDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/concDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/floatDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/floatDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/intDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/intDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/jmpBufDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/lval.ml (100%) rename src/{ => cdomain/value}/cdomains/mutexAttrDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/mval.ml (100%) rename src/{ => cdomain/value}/cdomains/mval.mli (100%) rename src/{ => cdomain/value}/cdomains/mval_intf.ml (100%) rename src/{ => cdomain/value}/cdomains/nullByteSet.ml (100%) rename src/{ => cdomain/value}/cdomains/offset.ml (100%) rename src/{ => cdomain/value}/cdomains/offset.mli (100%) rename src/{ => cdomain/value}/cdomains/offset_intf.ml (100%) rename src/{ => cdomain/value}/cdomains/preValueDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/stringDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/stringDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/structDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/structDomain.mli (100%) rename src/{ => cdomain/value}/cdomains/threadIdDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/unionDomain.ml (100%) rename src/{ => cdomain/value}/cdomains/valueDomain.ml (100%) rename src/{ => cdomain/value}/domains/invariant.ml (100%) rename src/{ => cdomain/value}/domains/invariantCil.ml (100%) rename src/{ => cdomain/value}/domains/valueDomainQueries.ml (100%) create mode 100644 src/cdomain/value/dune rename src/{ => cdomain/value}/util/precisionUtil.ml (100%) rename src/{ => cdomain/value}/util/wideningThresholds.ml (100%) rename src/{ => cdomain/value}/util/wideningThresholds.mli (100%) diff --git a/src/analyses/wrapperFunctionAnalysis0.ml b/src/cdomain/value/analyses/wrapperFunctionAnalysis0.ml similarity index 100% rename from src/analyses/wrapperFunctionAnalysis0.ml rename to src/cdomain/value/analyses/wrapperFunctionAnalysis0.ml diff --git a/src/cdomain/value/cdomain_value.mld b/src/cdomain/value/cdomain_value.mld new file mode 100644 index 0000000000..668bbfa0ca --- /dev/null +++ b/src/cdomain/value/cdomain_value.mld @@ -0,0 +1,71 @@ +{0 Library goblint.cdomain.value} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Domains} + +{2 Analysis-specific} + +{3 Value} + +{4 Non-relational} + +{5 Numeric} +{!modules: +IntDomain +FloatDomain +} + +{5 Addresses} +{!modules: +Mval +Offset +StringDomain +AddressDomain +} + +{5 Complex} +{!modules: +StructDomain +UnionDomain +ArrayDomain +NullByteSet +JmpBufDomain +} + +{5 Combined} +{!modules: +ValueDomain +ValueDomainQueries +} + +{3 Concurrency} +{!modules: +MutexAttrDomain +ThreadIdDomain +ConcDomain +} + +{3 Other} +{!modules: +Lval +} + + +{1 I/O} + +{2 Witnesses} +{!modules: +Invariant +InvariantCil +} + + +{1 Utilities} + +{2 Analysis-specific} +{!modules: +PrecisionUtil +WideningThresholds +} diff --git a/src/cdomains/addressDomain.ml b/src/cdomain/value/cdomains/addressDomain.ml similarity index 100% rename from src/cdomains/addressDomain.ml rename to src/cdomain/value/cdomains/addressDomain.ml diff --git a/src/cdomains/addressDomain.mli b/src/cdomain/value/cdomains/addressDomain.mli similarity index 100% rename from src/cdomains/addressDomain.mli rename to src/cdomain/value/cdomains/addressDomain.mli diff --git a/src/cdomains/addressDomain_intf.ml b/src/cdomain/value/cdomains/addressDomain_intf.ml similarity index 100% rename from src/cdomains/addressDomain_intf.ml rename to src/cdomain/value/cdomains/addressDomain_intf.ml diff --git a/src/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml similarity index 100% rename from src/cdomains/arrayDomain.ml rename to src/cdomain/value/cdomains/arrayDomain.ml diff --git a/src/cdomains/arrayDomain.mli b/src/cdomain/value/cdomains/arrayDomain.mli similarity index 100% rename from src/cdomains/arrayDomain.mli rename to src/cdomain/value/cdomains/arrayDomain.mli diff --git a/src/cdomains/concDomain.ml b/src/cdomain/value/cdomains/concDomain.ml similarity index 100% rename from src/cdomains/concDomain.ml rename to src/cdomain/value/cdomains/concDomain.ml diff --git a/src/cdomains/floatDomain.ml b/src/cdomain/value/cdomains/floatDomain.ml similarity index 100% rename from src/cdomains/floatDomain.ml rename to src/cdomain/value/cdomains/floatDomain.ml diff --git a/src/cdomains/floatDomain.mli b/src/cdomain/value/cdomains/floatDomain.mli similarity index 100% rename from src/cdomains/floatDomain.mli rename to src/cdomain/value/cdomains/floatDomain.mli diff --git a/src/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml similarity index 100% rename from src/cdomains/intDomain.ml rename to src/cdomain/value/cdomains/intDomain.ml diff --git a/src/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli similarity index 100% rename from src/cdomains/intDomain.mli rename to src/cdomain/value/cdomains/intDomain.mli diff --git a/src/cdomains/jmpBufDomain.ml b/src/cdomain/value/cdomains/jmpBufDomain.ml similarity index 100% rename from src/cdomains/jmpBufDomain.ml rename to src/cdomain/value/cdomains/jmpBufDomain.ml diff --git a/src/cdomains/lval.ml b/src/cdomain/value/cdomains/lval.ml similarity index 100% rename from src/cdomains/lval.ml rename to src/cdomain/value/cdomains/lval.ml diff --git a/src/cdomains/mutexAttrDomain.ml b/src/cdomain/value/cdomains/mutexAttrDomain.ml similarity index 100% rename from src/cdomains/mutexAttrDomain.ml rename to src/cdomain/value/cdomains/mutexAttrDomain.ml diff --git a/src/cdomains/mval.ml b/src/cdomain/value/cdomains/mval.ml similarity index 100% rename from src/cdomains/mval.ml rename to src/cdomain/value/cdomains/mval.ml diff --git a/src/cdomains/mval.mli b/src/cdomain/value/cdomains/mval.mli similarity index 100% rename from src/cdomains/mval.mli rename to src/cdomain/value/cdomains/mval.mli diff --git a/src/cdomains/mval_intf.ml b/src/cdomain/value/cdomains/mval_intf.ml similarity index 100% rename from src/cdomains/mval_intf.ml rename to src/cdomain/value/cdomains/mval_intf.ml diff --git a/src/cdomains/nullByteSet.ml b/src/cdomain/value/cdomains/nullByteSet.ml similarity index 100% rename from src/cdomains/nullByteSet.ml rename to src/cdomain/value/cdomains/nullByteSet.ml diff --git a/src/cdomains/offset.ml b/src/cdomain/value/cdomains/offset.ml similarity index 100% rename from src/cdomains/offset.ml rename to src/cdomain/value/cdomains/offset.ml diff --git a/src/cdomains/offset.mli b/src/cdomain/value/cdomains/offset.mli similarity index 100% rename from src/cdomains/offset.mli rename to src/cdomain/value/cdomains/offset.mli diff --git a/src/cdomains/offset_intf.ml b/src/cdomain/value/cdomains/offset_intf.ml similarity index 100% rename from src/cdomains/offset_intf.ml rename to src/cdomain/value/cdomains/offset_intf.ml diff --git a/src/cdomains/preValueDomain.ml b/src/cdomain/value/cdomains/preValueDomain.ml similarity index 100% rename from src/cdomains/preValueDomain.ml rename to src/cdomain/value/cdomains/preValueDomain.ml diff --git a/src/cdomains/stringDomain.ml b/src/cdomain/value/cdomains/stringDomain.ml similarity index 100% rename from src/cdomains/stringDomain.ml rename to src/cdomain/value/cdomains/stringDomain.ml diff --git a/src/cdomains/stringDomain.mli b/src/cdomain/value/cdomains/stringDomain.mli similarity index 100% rename from src/cdomains/stringDomain.mli rename to src/cdomain/value/cdomains/stringDomain.mli diff --git a/src/cdomains/structDomain.ml b/src/cdomain/value/cdomains/structDomain.ml similarity index 100% rename from src/cdomains/structDomain.ml rename to src/cdomain/value/cdomains/structDomain.ml diff --git a/src/cdomains/structDomain.mli b/src/cdomain/value/cdomains/structDomain.mli similarity index 100% rename from src/cdomains/structDomain.mli rename to src/cdomain/value/cdomains/structDomain.mli diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomain/value/cdomains/threadIdDomain.ml similarity index 100% rename from src/cdomains/threadIdDomain.ml rename to src/cdomain/value/cdomains/threadIdDomain.ml diff --git a/src/cdomains/unionDomain.ml b/src/cdomain/value/cdomains/unionDomain.ml similarity index 100% rename from src/cdomains/unionDomain.ml rename to src/cdomain/value/cdomains/unionDomain.ml diff --git a/src/cdomains/valueDomain.ml b/src/cdomain/value/cdomains/valueDomain.ml similarity index 100% rename from src/cdomains/valueDomain.ml rename to src/cdomain/value/cdomains/valueDomain.ml diff --git a/src/domains/invariant.ml b/src/cdomain/value/domains/invariant.ml similarity index 100% rename from src/domains/invariant.ml rename to src/cdomain/value/domains/invariant.ml diff --git a/src/domains/invariantCil.ml b/src/cdomain/value/domains/invariantCil.ml similarity index 100% rename from src/domains/invariantCil.ml rename to src/cdomain/value/domains/invariantCil.ml diff --git a/src/domains/valueDomainQueries.ml b/src/cdomain/value/domains/valueDomainQueries.ml similarity index 100% rename from src/domains/valueDomainQueries.ml rename to src/cdomain/value/domains/valueDomainQueries.ml diff --git a/src/cdomain/value/dune b/src/cdomain/value/dune new file mode 100644 index 0000000000..c89d5be04d --- /dev/null +++ b/src/cdomain/value/dune @@ -0,0 +1,24 @@ +(include_subdirs unqualified) + +(library + (name goblint_cdomain_value) + (public_name goblint.cdomain.value) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_config + goblint_library + goblint_domain + goblint_incremental + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/util/precisionUtil.ml b/src/cdomain/value/util/precisionUtil.ml similarity index 100% rename from src/util/precisionUtil.ml rename to src/cdomain/value/util/precisionUtil.ml diff --git a/src/util/wideningThresholds.ml b/src/cdomain/value/util/wideningThresholds.ml similarity index 100% rename from src/util/wideningThresholds.ml rename to src/cdomain/value/util/wideningThresholds.ml diff --git a/src/util/wideningThresholds.mli b/src/cdomain/value/util/wideningThresholds.mli similarity index 100% rename from src/util/wideningThresholds.mli rename to src/cdomain/value/util/wideningThresholds.mli diff --git a/src/dune b/src/dune index d65acfc856..d7c6d28026 100644 --- a/src/dune +++ b/src/dune @@ -7,7 +7,7 @@ (name goblint_lib) (public_name goblint.lib) (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_solver goblint_library goblint_incremental goblint_tracing + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_solver goblint_library goblint_cdomain_value goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. diff --git a/src/index.mld b/src/index.mld index 0763284c15..0f6b1c3e69 100644 --- a/src/index.mld +++ b/src/index.mld @@ -16,6 +16,9 @@ This {{!page-common}unwrapped library} contains various common modules extracted {2 Library goblint.domain} This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. +{2 Library goblint.cdomain.value} +This {{!page-cdomain_value}unwrapped library} contains various value domain modules extracted from {!Goblint_lib}. + {2 Library goblint.constraint} This {{!page-constraint}unwrapped library} contains various constraint system modules extracted from {!Goblint_lib}. diff --git a/unittest/dune b/unittest/dune index cb8dd668be..036c8d8013 100644 --- a/unittest/dune +++ b/unittest/dune @@ -2,7 +2,7 @@ (test (name mainTest) - (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.constraint goblint.solver goblint.sites.dune goblint.build-info.dune) + (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.constraint goblint.solver goblint.cdomain.value goblint.sites.dune goblint.build-info.dune) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall))