From d754d76fd0912b78e495cab0eb2fa73405c00952 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 13 Apr 2022 14:19:21 +0000 Subject: [PATCH 001/517] Add direct Klever concurrency specials --- src/analyses/libraryFunctions.ml | 5 ++++- src/analyses/mutexEventsAnalysis.ml | 6 ++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 0c00391dcb..ce89391691 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -24,7 +24,8 @@ let classify' fn exps = `Unknown fn in match fn with - | "pthread_create" -> + | "pthread_create" + | "pthread_create_N" -> (* Klever *) begin match exps with | [id;_;fn;x] -> `ThreadCreate (id, fn, x) | _ -> strange_arguments () @@ -72,6 +73,7 @@ let classify' fn exps = | "pthread_rwlock_wrlock" | "GetResource" | "_raw_spin_lock" | "_raw_spin_lock_flags" | "_raw_spin_lock_irqsave" | "_raw_spin_lock_irq" | "_raw_spin_lock_bh" | "spin_lock_irqsave" | "spin_lock" + | "ldv_mutex_model_lock" | "ldv_spin_model_lock" (* Klever *) -> `Lock (get_bool "sem.lock.fail", true, true) | "pthread_mutex_lock" | "__pthread_mutex_lock" -> `Lock (get_bool "sem.lock.fail", true, false) @@ -84,6 +86,7 @@ let classify' fn exps = | "mutex_unlock" | "ReleaseResource" | "_write_unlock" | "_read_unlock" | "_raw_spin_unlock_irqrestore" | "pthread_mutex_unlock" | "__pthread_mutex_unlock" | "spin_unlock_irqrestore" | "up_read" | "up_write" | "up" + | "ldv_mutex_model_unlock" | "ldv_spin_model_unlock" (* Klever *) -> `Unlock | x -> `Unknown x diff --git a/src/analyses/mutexEventsAnalysis.ml b/src/analyses/mutexEventsAnalysis.ml index 4a3ef078ce..050b8de600 100644 --- a/src/analyses/mutexEventsAnalysis.ml +++ b/src/analyses/mutexEventsAnalysis.ml @@ -77,7 +77,8 @@ struct let unlock remove_fn = match f.vname, arglist with | _, [arg] - | ("spin_unlock_irqrestore" | "_raw_spin_unlock_irqrestore"), [arg; _] -> + | ("spin_unlock_irqrestore" | "_raw_spin_unlock_irqrestore"), [arg; _] + | "ldv_mutex_model_unlock", [arg; _] -> (* Klever *) List.iter (fun e -> ctx.split () [Events.Unlock (remove_fn e)] ) (eval_exp_addr (Analyses.ask_of_ctx ctx) arg); @@ -92,7 +93,8 @@ struct | `Lock (failing, rw, nonzero_return_when_aquired), _ -> begin match f.vname, arglist with | _, [arg] - | "spin_lock_irqsave", [arg; _] -> + | "spin_lock_irqsave", [arg; _] + | "ldv_mutex_model_lock", [arg; _] -> (* Klever *) (*print_endline @@ "Mutex `Lock "^f.vname;*) lock ctx rw failing nonzero_return_when_aquired (Analyses.ask_of_ctx ctx) lv arg | _ -> failwith "lock has multiple arguments" From 8f3160943db3dc36a622b0914242a3fa496a2978 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 13 Apr 2022 14:20:08 +0000 Subject: [PATCH 002/517] Add special rtnl_lock from Linux --- src/analyses/mutexEventsAnalysis.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/analyses/mutexEventsAnalysis.ml b/src/analyses/mutexEventsAnalysis.ml index 050b8de600..a7448af4f4 100644 --- a/src/analyses/mutexEventsAnalysis.ml +++ b/src/analyses/mutexEventsAnalysis.ml @@ -11,6 +11,7 @@ open GobConfig let big_kernel_lock = LockDomain.Addr.from_var (Goblintutil.create_var (makeGlobalVar "[big kernel lock]" intType)) let console_sem = LockDomain.Addr.from_var (Goblintutil.create_var (makeGlobalVar "[console semaphore]" intType)) +let rtnl_lock = LockDomain.Addr.from_var (Goblintutil.create_var (makeGlobalVar "[rtnl_lock]" intType)) let verifier_atomic = LockDomain.Addr.from_var (Goblintutil.create_var (makeGlobalVar "[__VERIFIER_atomic]" intType)) module Spec: MCPSpec = @@ -118,10 +119,14 @@ struct (*print_endline @@ "Mutex `Unlock "^f.vname;*) unlock remove_rw | _, "spinlock_check" -> () - | _, "acquire_console_sem" when get_bool "kernel" -> + | _, "acquire_console_sem"-> (* TODO: removed for Klever: when get_bool "kernel" *) ctx.emit (Events.Lock (console_sem, true)) - | _, "release_console_sem" when get_bool "kernel" -> + | _, "release_console_sem" -> (* TODO: removed for Klever: when get_bool "kernel" *) ctx.emit (Events.Unlock console_sem) + | _, "rtnl_lock"-> + ctx.emit (Events.Lock (rtnl_lock, true)) + | _, ("rtnl_unlock" | "__rtnl_unlock") -> + ctx.emit (Events.Unlock rtnl_lock) | _, "__builtin_prefetch" | _, "misc_deregister" -> () | _, "__VERIFIER_atomic_begin" when get_bool "ana.sv-comp.functions" -> From 1fbf9105c125d1bf4903d43ea477cd88cbb0df6b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 13 Apr 2022 14:20:19 +0000 Subject: [PATCH 003/517] Add symb_locks to ldv-races conf --- conf/ldv-races.json | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/conf/ldv-races.json b/conf/ldv-races.json index 2414413de4..2b30576e1b 100644 --- a/conf/ldv-races.json +++ b/conf/ldv-races.json @@ -27,7 +27,9 @@ "access", "escape", "expRelation", - "mhp" + "mhp", + "var_eq", + "symb_locks" ], "malloc": { "wrappers": [ From 2a53cbbd38c921cdde0c55aaabd4bdc2351821d3 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 23 May 2023 12:59:24 +0200 Subject: [PATCH 004/517] 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 12444933d1f7107dc73c4a2f30107e75c85c97ee Mon Sep 17 00:00:00 2001 From: Vesal Vojdani Date: Fri, 26 May 2023 10:58:09 +0300 Subject: [PATCH 005/517] Add initial attempt to rely on ptranal for EvalFunvar queries --- src/analyses/ptranalEvalFunvar.ml | 59 +++++++++++++++++++ src/framework/constraints.ml | 1 + .../regression/33-constants/05-fun_ptranal.c | 14 +++++ 3 files changed, 74 insertions(+) create mode 100644 src/analyses/ptranalEvalFunvar.ml create mode 100644 tests/regression/33-constants/05-fun_ptranal.c diff --git a/src/analyses/ptranalEvalFunvar.ml b/src/analyses/ptranalEvalFunvar.ml new file mode 100644 index 0000000000..3b3d04ed6d --- /dev/null +++ b/src/analyses/ptranalEvalFunvar.ml @@ -0,0 +1,59 @@ +(** Wrapper analysis to answer EvalFunvar query using Cil's pointer analysis. *) + +open GoblintCil +open Analyses + +module Spec = +struct + include Analyses.DefaultSpec + + let name () = "ptranal" + + module D = Lattice.Unit + module C = Lattice.Unit + + (* transfer functions *) + let assign ctx (lval:lval) (rval:exp) : D.t = + ctx.local + + let branch ctx (exp:exp) (tv:bool) : D.t = + ctx.local + + let body ctx (f:fundec) : D.t = + ctx.local + + let return ctx (exp:exp option) (f:fundec) : D.t = + ctx.local + + let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [ctx.local, ctx.local] + + let combine_env ctx lval fexp f args fc au f_ask = + au + + let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + ctx.local + + let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + ctx.local + + let query ctx (type a) (q: a Queries.t): a Queries.result = + match q with + | Queries.EvalFunvar (Lval (Mem e, _)) -> + let funs = Ptranal.resolve_exp e in + List.fold_left (fun xs f -> Queries.LS.add (f, `NoOffset) xs) (Queries.LS.empty ()) funs + | _ -> Queries.Result.top q + + let startstate v = D.bot () + let threadenter ctx lval f args = [D.top ()] + let threadspawn ctx lval f args fctx = ctx.local + let exitstate v = D.top () + + let init _: unit = + Ptranal.analyze_file !Cilfacade.current_file; + Ptranal.compute_results false + +end + +let _ = + MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index f608698521..d8fcdcd09a 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -754,6 +754,7 @@ struct [v] | _ -> (* Depends on base for query. *) + M.debug ~category:Program "Dynamic function call through %a" d_exp e; let ls = ctx.ask (Queries.EvalFunvar e) in Queries.LS.fold (fun ((x,_)) xs -> x::xs) ls [] in diff --git a/tests/regression/33-constants/05-fun_ptranal.c b/tests/regression/33-constants/05-fun_ptranal.c new file mode 100644 index 0000000000..5ebaf24e22 --- /dev/null +++ b/tests/regression/33-constants/05-fun_ptranal.c @@ -0,0 +1,14 @@ +//PARAM: --set ana.activated '["constants", "ptranal"]' +// intentional explicit ana.activated to do tutorial in isolation +int f(int a, int b){ + int d = 3; + int z = a + d; + return z; +} + +int main(){ + int d = 0; + int (*fp)(int,int) = &f; + d = fp(2, 3); + return 0; +} From 7798c0448c9204d17c131eef4f9c9691f45ec025 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Tue, 30 May 2023 19:50:04 +0200 Subject: [PATCH 006/517] 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 007/517] 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 008/517] 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 009/517] 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 010/517] 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 011/517] 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 012/517] 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 013/517] 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 014/517] 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 015/517] 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 016/517] 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 017/517] 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 018/517] 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 019/517] 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 020/517] 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 021/517] 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 022/517] 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 023/517] 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 024/517] 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 025/517] 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 026/517] 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 027/517] 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 028/517] 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 029/517] 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 030/517] 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 031/517] 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 032/517] 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 033/517] 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 034/517] 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 035/517] 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 036/517] 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 037/517] 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 038/517] 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 039/517] 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 040/517] 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 041/517] 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 042/517] 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 043/517] 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 044/517] 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 045/517] 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 046/517] 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 80b3b72df749337a3b68435f45b3ff90a2a74dac Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 4 Oct 2023 11:49:49 +0300 Subject: [PATCH 047/517] Add ldv_kzalloc to svcomp malloc wrappers --- conf/svcomp.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/conf/svcomp.json b/conf/svcomp.json index 913d43784b..d6c07387a8 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -52,7 +52,8 @@ "ldv_xmalloc", "ldv_xzalloc", - "ldv_calloc" + "ldv_calloc", + "ldv_kzalloc" ] }, "base": { From 35f6d0000f61e2565e9e9ab86bf2279fd8ebce7a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 4 Oct 2023 11:54:54 +0300 Subject: [PATCH 048/517] Disable free races in svcomp They should be considered MemSafety issues instead. --- conf/svcomp.json | 3 +++ 1 file changed, 3 insertions(+) diff --git a/conf/svcomp.json b/conf/svcomp.json index d6c07387a8..16c4ef338e 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -61,6 +61,9 @@ "domain": "partitioned" } }, + "race": { + "free": false + }, "autotune": { "enabled": true, "activated": [ From b6dfb14231e30c869e9c3a139b6ce7b609960a38 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 4 Oct 2023 11:55:39 +0300 Subject: [PATCH 049/517] Make threadid path sensitive in svcomp This is required for some ldv-races/ no-data-race tasks. --- conf/svcomp.json | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/conf/svcomp.json b/conf/svcomp.json index 16c4ef338e..f51c7a52ee 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -32,6 +32,14 @@ "thread", "threadJoins" ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "threadid" + ], "context": { "widen": false }, From 11164fd7c7d709206c2e6483edd79492450af3c5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 4 Oct 2023 12:15:54 +0300 Subject: [PATCH 050/517] Use exp.architecture for SV-COMP preprocessing Avoids a large number or CIL warnings about mismatching types. --- src/maingoblint.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 155faa0e76..ef548fb83a 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -252,6 +252,15 @@ let preprocess_files () = (* Preprocessor flags *) let cppflags = ref (get_string_list "pre.cppflags") in + if get_bool "ana.sv-comp.enabled" then ( + let architecture_flag = match get_string "exp.architecture" with + | "32bit" -> "-m32" + | "64bit" -> "-m64" + | _ -> assert false + in + cppflags := architecture_flag :: !cppflags + ); + (* the base include directory *) (* TODO: any better way? dune executable promotion doesn't add _build sites *) let source_lib_dirs = From 94307d03c47d63621ade9b833c0be35bb23bee89 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 5 Oct 2023 17:27:55 +0300 Subject: [PATCH 051/517] Add option ana.race.call --- conf/svcomp.json | 3 ++- src/domains/access.ml | 2 ++ src/util/options.schema.json | 6 ++++++ 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/conf/svcomp.json b/conf/svcomp.json index f51c7a52ee..df624e4b83 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -70,7 +70,8 @@ } }, "race": { - "free": false + "free": false, + "call": false }, "autotune": { "enabled": true, diff --git a/src/domains/access.ml b/src/domains/access.ml index 8907ccbc32..f243b85bda 100644 --- a/src/domains/access.ml +++ b/src/domains/access.ml @@ -444,6 +444,8 @@ let may_race A.{kind; acc; _} A.{kind=kind2; acc=acc2; _} = false (* two read/read accesses do not race *) else if not (get_bool "ana.race.free") && (kind = Free || kind2 = Free) then false + else if not (get_bool "ana.race.call") && (kind = Call || kind2 = Call) then + false else if not (MCPAccess.A.may_race acc acc2) then false (* analysis-specific information excludes race *) else diff --git a/src/util/options.schema.json b/src/util/options.schema.json index 1b9c7d3fd5..33de069b38 100644 --- a/src/util/options.schema.json +++ b/src/util/options.schema.json @@ -1002,6 +1002,12 @@ "type": "boolean", "default": true }, + "call": { + "title": "ana.race.call", + "description": "Report races for thread-unsafe function calls.", + "type": "boolean", + "default": true + }, "direct-arithmetic": { "title": "ana.race.direct-arithmetic", "description": "Collect and distribute direct (i.e. not in a field) accesses to arithmetic types.", From 1d94b5a5f596f194b87cf64a4c58605c35287cf7 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 6 Oct 2023 17:21:17 +0300 Subject: [PATCH 052/517] Add 73-strings/05-string-unit-domain test --- .../regression/73-strings/05-string-unit-domain.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 tests/regression/73-strings/05-string-unit-domain.c diff --git a/tests/regression/73-strings/05-string-unit-domain.c b/tests/regression/73-strings/05-string-unit-domain.c new file mode 100644 index 0000000000..521e2f3ec5 --- /dev/null +++ b/tests/regression/73-strings/05-string-unit-domain.c @@ -0,0 +1,15 @@ +// PARAM: --enable ana.base.limit-string-addresses +#include +#include + +void foo(char *s) { + int l = strlen(s); + __goblint_check(l == 3 || l == 6); // UNKNOWN +} + +int main() { + foo("foo"); + foo("bar"); + foo("foobar"); + return 0; +} From 12a22b64c461fb7d80ff5be8de196f5f33536eb3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 6 Oct 2023 17:39:41 +0300 Subject: [PATCH 053/517] Extract StringDomain from AddressDomain --- src/cdomains/addressDomain.ml | 85 ++++++++------------------------- src/cdomains/stringDomain.ml | 89 +++++++++++++++++++++++++++++++++++ 2 files changed, 108 insertions(+), 66 deletions(-) create mode 100644 src/cdomains/stringDomain.ml diff --git a/src/cdomains/addressDomain.ml b/src/cdomains/addressDomain.ml index 5981caf9ea..55b1aceefc 100644 --- a/src/cdomains/addressDomain.ml +++ b/src/cdomains/addressDomain.ml @@ -5,6 +5,7 @@ open IntOps module M = Messages module Mval_outer = Mval +module SD = StringDomain module AddressBase (Mval: Printable.S) = @@ -14,23 +15,14 @@ struct | Addr of Mval.t | NullPtr | UnknownPtr - | StrPtr of string option + | StrPtr of SD.t [@@deriving eq, ord, hash] (* TODO: StrPtr equal problematic if the same literal appears more than once *) let name () = Format.sprintf "address (%s)" (Mval.name ()) - let hash x = match x with - | StrPtr _ -> - if GobConfig.get_bool "ana.base.limit-string-addresses" then - 13859 - else - hash x - | _ -> hash x - let show = function | Addr m -> Mval.show m - | StrPtr (Some x) -> "\"" ^ x ^ "\"" - | StrPtr None -> "(unknown string)" + | StrPtr s -> StringDomain.show s | UnknownPtr -> "?" | NullPtr -> "NULL" @@ -42,31 +34,18 @@ struct ) (* strings *) - let of_string x = StrPtr (Some x) + let of_string x = StrPtr (SD.of_string x) let to_string = function - | StrPtr (Some x) -> Some x + | StrPtr s -> SD.to_string s | _ -> None - (* only keep part before first null byte *) let to_c_string = function - | StrPtr (Some x) -> - begin match String.split_on_char '\x00' x with - | s::_ -> Some s - | [] -> None - end + | StrPtr s -> SD.to_c_string s | _ -> None - let to_n_c_string n x = - match to_c_string x with - | Some x -> - if n > String.length x then - Some x - else if n < 0 then - None - else - Some (String.sub x 0 n) + let to_n_c_string n = function + | StrPtr s -> SD.to_n_c_string n s | _ -> None - let to_string_length x = - match to_c_string x with - | Some x -> Some (String.length x) + let to_string_length = function + | StrPtr s -> SD.to_string_length s | _ -> None let arbitrary () = QCheck.always UnknownPtr (* S TODO: non-unknown *) @@ -101,8 +80,7 @@ struct (* TODO: seems to be unused *) let to_exp = function | Addr m -> AddrOf (Mval.to_cil m) - | StrPtr (Some x) -> mkString x - | StrPtr None -> raise (Lattice.Unsupported "Cannot express unknown string pointer as expression.") + | StrPtr s -> SD.to_exp s | NullPtr -> integer 0 | UnknownPtr -> raise Lattice.TopValue (* TODO: unused *) @@ -123,9 +101,7 @@ struct let semantic_equal x y = match x, y with | Addr x, Addr y -> Mval.semantic_equal x y - | StrPtr None, StrPtr _ - | StrPtr _, StrPtr None -> Some true - | StrPtr (Some a), StrPtr (Some b) -> if a = b then None else Some false + | StrPtr s1, StrPtr s2 -> SD.semantic_equal s1 s2 | NullPtr, NullPtr -> Some true | UnknownPtr, UnknownPtr | UnknownPtr, Addr _ @@ -135,8 +111,7 @@ struct | _, _ -> Some false let leq x y = match x, y with - | StrPtr _, StrPtr None -> true - | StrPtr a, StrPtr b -> a = b + | StrPtr s1, StrPtr s2 -> SD.leq s1 s2 | Addr x, Addr y -> Mval.leq x y | _ -> x = y @@ -144,26 +119,6 @@ struct | Addr x -> Addr (Mval.top_indices x) | x -> x - let join_string_ptr x y = match x, y with - | None, _ - | _, None -> None - | Some a, Some b when a = b -> Some a - | Some a, Some b (* when a <> b *) -> - if GobConfig.get_bool "ana.base.limit-string-addresses" then - None - else - raise Lattice.Uncomparable - - let meet_string_ptr x y = match x, y with - | None, a - | a, None -> a - | Some a, Some b when a = b -> Some a - | Some a, Some b (* when a <> b *) -> - if GobConfig.get_bool "ana.base.limit-string-addresses" then - raise Lattice.BotValue - else - raise Lattice.Uncomparable - let merge mop sop x y = match x, y with | UnknownPtr, UnknownPtr -> UnknownPtr @@ -172,10 +127,10 @@ struct | Addr x, Addr y -> Addr (mop x y) | _ -> raise Lattice.Uncomparable - let join = merge Mval.join join_string_ptr - let widen = merge Mval.widen join_string_ptr - let meet = merge Mval.meet meet_string_ptr - let narrow = merge Mval.narrow meet_string_ptr + let join = merge Mval.join SD.join + let widen = merge Mval.widen SD.join + let meet = merge Mval.meet SD.meet + let narrow = merge Mval.narrow SD.meet include Lattice.NoBotTop @@ -194,8 +149,7 @@ struct let of_elt (x: elt): t = match x with | Addr (v, o) -> Addr v - | StrPtr _ when GobConfig.get_bool "ana.base.limit-string-addresses" -> StrPtr None (* all strings together if limited *) - | StrPtr x -> StrPtr x (* everything else is kept separate, including strings if not limited *) + | StrPtr s -> StrPtr (SD.repr s) | NullPtr -> NullPtr | UnknownPtr -> UnknownPtr end @@ -211,8 +165,7 @@ struct let of_elt (x: elt): t = match x with | Addr (v, o) -> Addr (v, Offset.Unit.of_offs o) (* addrs grouped by var and part of offset *) - | StrPtr _ when GobConfig.get_bool "ana.base.limit-string-addresses" -> StrPtr None (* all strings together if limited *) - | StrPtr x -> StrPtr x (* everything else is kept separate, including strings if not limited *) + | StrPtr s -> StrPtr (SD.repr s) | NullPtr -> NullPtr | UnknownPtr -> UnknownPtr end diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml new file mode 100644 index 0000000000..c888663c7c --- /dev/null +++ b/src/cdomains/stringDomain.ml @@ -0,0 +1,89 @@ +type t = string option [@@deriving eq, ord, hash] + +let hash x = + if GobConfig.get_bool "ana.base.limit-string-addresses" then + 13859 + else + hash x + +let show = function + | Some x -> "\"" ^ x ^ "\"" + | None -> "(unknown string)" + +include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) + +let of_string x = Some x +let to_string x = x + +(* only keep part before first null byte *) +let to_c_string = function + | Some x -> + begin match String.split_on_char '\x00' x with + | s::_ -> Some s + | [] -> None + end + | None -> None + +let to_n_c_string n x = + match to_c_string x with + | Some x -> + if n > String.length x then + Some x + else if n < 0 then + None + else + Some (String.sub x 0 n) + | None -> None + +let to_string_length x = + match to_c_string x with + | Some x -> Some (String.length x) + | None -> None + +let to_exp = function + | Some x -> GoblintCil.mkString x + | None -> raise (Lattice.Unsupported "Cannot express unknown string pointer as expression.") + +let semantic_equal x y = + match x, y with + | None, _ + | _, None -> Some true + | Some a, Some b -> if a = b then None else Some false + +let leq x y = + match x, y with + | _, None -> true + | a, b -> a = b + +let join x y = + match x, y with + | None, _ + | _, None -> None + | Some a, Some b when a = b -> Some a + | Some a, Some b (* when a <> b *) -> + if GobConfig.get_bool "ana.base.limit-string-addresses" then + None + else + raise Lattice.Uncomparable + +let meet x y = + match x, y with + | None, a + | a, None -> a + | Some a, Some b when a = b -> Some a + | Some a, Some b (* when a <> b *) -> + if GobConfig.get_bool "ana.base.limit-string-addresses" then + raise Lattice.BotValue + else + raise Lattice.Uncomparable + +let repr x = + if GobConfig.get_bool "ana.base.limit-string-addresses" then + None (* all strings together if limited *) + else + x (* everything else is kept separate, including strings if not limited *) From 26b9cad1951bc574848fe6de993c2d69a21fa324 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 6 Oct 2023 17:48:28 +0300 Subject: [PATCH 054/517] Change ana.base.limit-string-addresses to ana.base.strings.domain --- conf/examples/very-precise.json | 4 ++- src/cdomains/addressDomain_intf.ml | 2 +- src/cdomains/stringDomain.ml | 30 +++++++++++-------- src/util/options.schema.json | 18 +++++++---- .../02-base/88-string-ptrs-limited.c | 2 +- .../02-base/89-string-ptrs-not-limited.c | 2 +- .../73-strings/01-string_literals.c | 8 ++--- .../73-strings/02-string_literals_with_null.c | 2 +- .../regression/73-strings/03-string_basics.c | 2 +- .../73-strings/05-string-unit-domain.c | 2 +- 10 files changed, 43 insertions(+), 29 deletions(-) diff --git a/conf/examples/very-precise.json b/conf/examples/very-precise.json index 84cbf53585..2197335eaf 100644 --- a/conf/examples/very-precise.json +++ b/conf/examples/very-precise.json @@ -61,7 +61,9 @@ "structs" : { "domain" : "combined-sk" }, - "limit-string-addresses": false + "strings": { + "domain": "disjoint" + } } }, "exp": { diff --git a/src/cdomains/addressDomain_intf.ml b/src/cdomains/addressDomain_intf.ml index 0ef3d6dd8d..f86dee29c4 100644 --- a/src/cdomains/addressDomain_intf.ml +++ b/src/cdomains/addressDomain_intf.ml @@ -71,7 +71,7 @@ sig - Each {!Addr}, modulo precise index expressions in the offset, is a sublattice with ordering induced by {!Mval}. - {!NullPtr} is a singleton sublattice. - {!UnknownPtr} is a singleton sublattice. - - If [ana.base.limit-string-addresses] is enabled, then all {!StrPtr} are together in one sublattice with flat ordering. If [ana.base.limit-string-addresses] is disabled, then each {!StrPtr} is a singleton sublattice. *) + - If [ana.base.strings.domain] is disjoint, then each {!StrPtr} is a singleton sublattice. Otherwise, all {!StrPtr} are together in one sublattice with flat ordering. *) module AddressLattice (Mval: Mval.Lattice): sig include module type of AddressPrintable (Mval) diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml index c888663c7c..6c398cf9fd 100644 --- a/src/cdomains/stringDomain.ml +++ b/src/cdomains/stringDomain.ml @@ -1,10 +1,10 @@ type t = string option [@@deriving eq, ord, hash] let hash x = - if GobConfig.get_bool "ana.base.limit-string-addresses" then - 13859 - else + if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then hash x + else + 13859 let show = function | Some x -> "\"" ^ x ^ "\"" @@ -17,7 +17,11 @@ include Printable.SimpleShow ( end ) -let of_string x = Some x +let of_string x = + if GobConfig.get_string "ana.base.strings.domain" = "unit" then + None + else + Some x let to_string x = x (* only keep part before first null byte *) @@ -66,10 +70,10 @@ let join x y = | _, None -> None | Some a, Some b when a = b -> Some a | Some a, Some b (* when a <> b *) -> - if GobConfig.get_bool "ana.base.limit-string-addresses" then - None - else + if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then raise Lattice.Uncomparable + else + None let meet x y = match x, y with @@ -77,13 +81,13 @@ let meet x y = | a, None -> a | Some a, Some b when a = b -> Some a | Some a, Some b (* when a <> b *) -> - if GobConfig.get_bool "ana.base.limit-string-addresses" then - raise Lattice.BotValue - else + if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then raise Lattice.Uncomparable + else + raise Lattice.BotValue let repr x = - if GobConfig.get_bool "ana.base.limit-string-addresses" then - None (* all strings together if limited *) - else + if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then x (* everything else is kept separate, including strings if not limited *) + else + None (* all strings together if limited *) diff --git a/src/util/options.schema.json b/src/util/options.schema.json index 1b9c7d3fd5..330506958a 100644 --- a/src/util/options.schema.json +++ b/src/util/options.schema.json @@ -619,11 +619,19 @@ }, "additionalProperties": false }, - "limit-string-addresses": { - "title": "ana.base.limit-string-addresses", - "description": "Limit abstract address sets to keep at most one distinct string pointer.", - "type": "boolean", - "default": true + "strings": { + "title": "ana.base.strings", + "type": "object", + "properties": { + "domain": { + "title": "ana.base.strings.domain", + "description": "Domain for string literals.", + "type": "string", + "enum": ["unit", "flat", "disjoint"], + "default": "flat" + } + }, + "additionalProperties": false }, "partition-arrays": { "title": "ana.base.partition-arrays", diff --git a/tests/regression/02-base/88-string-ptrs-limited.c b/tests/regression/02-base/88-string-ptrs-limited.c index ab8b2fefe8..c4f39dc711 100644 --- a/tests/regression/02-base/88-string-ptrs-limited.c +++ b/tests/regression/02-base/88-string-ptrs-limited.c @@ -1,4 +1,4 @@ -//PARAM: --enable ana.base.limit-string-addresses +//PARAM: --set ana.base.strings.domain flat #include #include diff --git a/tests/regression/02-base/89-string-ptrs-not-limited.c b/tests/regression/02-base/89-string-ptrs-not-limited.c index 96100d230d..ab30e21fd8 100644 --- a/tests/regression/02-base/89-string-ptrs-not-limited.c +++ b/tests/regression/02-base/89-string-ptrs-not-limited.c @@ -1,4 +1,4 @@ -//PARAM: --disable ana.base.limit-string-addresses +//PARAM: --set ana.base.strings.domain disjoint #include #include diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 36e4ed121c..42086e07b6 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval #include #include @@ -21,7 +21,7 @@ int main() { char* s1 = "abcde"; char* s2 = "abcdfg"; char* s3 = hello_world(); - + int i = strlen(s1); __goblint_check(i == 5); @@ -96,10 +96,10 @@ int main() { #define STRNCAT strncat(s1, "hi", 1) #endif STRNCAT; // WARN - + #ifdef __APPLE__ // do nothing => no warning - #else + #else char s4[] = "hello"; strcpy(s4, s2); // NOWARN strncpy(s4, s3, 2); // NOWARN 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..cc41e9e287 100644 --- a/tests/regression/73-strings/02-string_literals_with_null.c +++ b/tests/regression/73-strings/02-string_literals_with_null.c @@ -1,4 +1,4 @@ -// PARAM: --disable ana.base.limit-string-addresses --enable ana.int.interval +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval #include #include diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index db196c64b4..a9d02d5e8b 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: --set ana.base.strings.domain disjoint --enable ana.int.interval #include #include diff --git a/tests/regression/73-strings/05-string-unit-domain.c b/tests/regression/73-strings/05-string-unit-domain.c index 521e2f3ec5..70e6bed5bf 100644 --- a/tests/regression/73-strings/05-string-unit-domain.c +++ b/tests/regression/73-strings/05-string-unit-domain.c @@ -1,4 +1,4 @@ -// PARAM: --enable ana.base.limit-string-addresses +// PARAM: --set ana.base.strings.domain unit #include #include From 3cb651f0ac8258523d82356bca5ce1d2bf5498df Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 6 Oct 2023 17:57:11 +0300 Subject: [PATCH 055/517] Add StringDomain interface --- src/cdomains/addressDomain_intf.ml | 4 +--- src/cdomains/stringDomain.ml | 4 ++++ src/cdomains/stringDomain.mli | 37 ++++++++++++++++++++++++++++++ src/goblint_lib.ml | 1 + 4 files changed, 43 insertions(+), 3 deletions(-) create mode 100644 src/cdomains/stringDomain.mli diff --git a/src/cdomains/addressDomain_intf.ml b/src/cdomains/addressDomain_intf.ml index f86dee29c4..f65b2977c4 100644 --- a/src/cdomains/addressDomain_intf.ml +++ b/src/cdomains/addressDomain_intf.ml @@ -7,7 +7,7 @@ sig | Addr of Mval.t (** Pointer to mvalue. *) | NullPtr (** NULL pointer. *) | UnknownPtr (** Unknown pointer. Could point to globals, heap and escaped variables. *) - | StrPtr of string option (** String literal pointer. [StrPtr None] abstracts any string pointer *) + | StrPtr of StringDomain.t (** String literal pointer. [StrPtr None] abstracts any string pointer *) include Printable.S with type t := t (** @closed *) val of_string: string -> t @@ -16,8 +16,6 @@ sig val to_string: t -> string option (** Convert {!StrPtr} to string if possible. *) - (** C strings are different from OCaml strings as they are not processed after the first [NUL] byte, even though the OCaml string (and a C string literal) may be longer. *) - val to_c_string: t -> string option (** Convert {!StrPtr} to C string if possible. *) diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml index 6c398cf9fd..925a7fec62 100644 --- a/src/cdomains/stringDomain.ml +++ b/src/cdomains/stringDomain.ml @@ -1,3 +1,7 @@ +include Printable.StdLeaf + +let name () = "string" + type t = string option [@@deriving eq, ord, hash] let hash x = diff --git a/src/cdomains/stringDomain.mli b/src/cdomains/stringDomain.mli new file mode 100644 index 0000000000..3541dac6e7 --- /dev/null +++ b/src/cdomains/stringDomain.mli @@ -0,0 +1,37 @@ +(** String literals domain. *) + +include Printable.S + +val of_string: string -> t +(** Convert from string. *) + +val to_string: t -> string option +(** Convert to string if possible. *) + +(** C strings are different from OCaml strings as they are not processed after the first [NUL] byte, even though the OCaml string (and a C string literal) may be longer. *) + +val to_c_string: t -> string option +(** Convert to C string if possible. *) + +val to_n_c_string: int -> t -> string option +(** Convert to C string of given maximum length if possible. *) + +val to_string_length: t -> int option +(** Find length of C string if possible. *) + +val to_exp: t -> GoblintCil.exp +(** Convert to CIL expression. *) + +val semantic_equal: t -> t -> bool option +(** Check semantic equality of two strings. + + @return [Some true] if definitely equal, [Some false] if definitely not equal, [None] if unknown. *) + +(** Some {!Lattice.S} operations. *) + +val leq: t -> t -> bool +val join: t -> t -> t +val meet: t -> t -> t + +val repr : t -> t +(** Representative for address lattice. *) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 6e700485dd..3f0123c372 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -211,6 +211,7 @@ module FloatDomain = FloatDomain module Mval = Mval module Offset = Offset +module StringDomain = StringDomain module AddressDomain = AddressDomain (** {5 Complex} *) From 5ac2f23a2029290940b65b85554f69242b42d830 Mon Sep 17 00:00:00 2001 From: Nathan Schmidt Date: Mon, 9 Oct 2023 17:18:08 +0200 Subject: [PATCH 056/517] 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 057/517] 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 058/517] 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 059/517] 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 060/517] 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 061/517] 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 062/517] 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 063/517] 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 064/517] 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 065/517] 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 35f9323854d7e358a63b374c0bad3ced5cc1d4ed Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 12:10:56 +0200 Subject: [PATCH 066/517] Use threadflag path-sensitivity instead of threadid in svcomp conf This is enough for ldv-races/race-2_1-container_of, etc, but cheaper. --- conf/svcomp.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conf/svcomp.json b/conf/svcomp.json index df624e4b83..d17e1a5f1e 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -38,7 +38,7 @@ "uninit", "expsplit", "activeSetjmp", - "threadid" + "threadflag" ], "context": { "widen": false From f4b37100d7a9edd544518b434aa39950ef1edb88 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 12:22:46 +0200 Subject: [PATCH 067/517] Copy svcomp conf to svcomp24 --- conf/svcomp24.json | 116 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 conf/svcomp24.json diff --git a/conf/svcomp24.json b/conf/svcomp24.json new file mode 100644 index 0000000000..178035eb8a --- /dev/null +++ b/conf/svcomp24.json @@ -0,0 +1,116 @@ +{ + "ana": { + "sv-comp": { + "enabled": true, + "functions": true + }, + "int": { + "def_exc": true, + "enums": false, + "interval": true + }, + "float": { + "interval": true + }, + "activated": [ + "base", + "threadid", + "threadflag", + "threadreturn", + "mallocWrapper", + "mutexEvents", + "mutex", + "access", + "race", + "escape", + "expRelation", + "mhp", + "assert", + "var_eq", + "symb_locks", + "region", + "thread", + "threadJoins" + ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "threadflag" + ], + "context": { + "widen": false + }, + "malloc": { + "wrappers": [ + "kmalloc", + "__kmalloc", + "usb_alloc_urb", + "__builtin_alloca", + "kzalloc", + + "ldv_malloc", + + "kzalloc_node", + "ldv_zalloc", + "kmalloc_array", + "kcalloc", + + "ldv_xmalloc", + "ldv_xzalloc", + "ldv_calloc", + "ldv_kzalloc" + ] + }, + "base": { + "arrays": { + "domain": "partitioned" + } + }, + "race": { + "free": false, + "call": false + }, + "autotune": { + "enabled": true, + "activated": [ + "singleThreaded", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "congruence", + "octagon", + "wideningThresholds", + "loopUnrollHeuristic", + "memsafetySpecification" + ] + } + }, + "exp": { + "region-offsets": true + }, + "solver": "td3", + "sem": { + "unknown_function": { + "spawn": false + }, + "int": { + "signed_overflow": "assume_none" + }, + "null-pointer": { + "dereference": "assume_none" + } + }, + "witness": { + "graphml": { + "enabled": true, + "id": "enumerate", + "unknown": false + } + }, + "pre": { + "enabled": false + } +} From 529a415a03f50dcd69ca4869b5dddf4194535638 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 12:56:11 +0200 Subject: [PATCH 068/517] Add YAML witness generation to svcomp confs --- conf/svcomp.json | 23 +++++++++++++++++++++++ conf/svcomp24.json | 23 +++++++++++++++++++++++ 2 files changed, 46 insertions(+) diff --git a/conf/svcomp.json b/conf/svcomp.json index 178035eb8a..77f519a568 100644 --- a/conf/svcomp.json +++ b/conf/svcomp.json @@ -108,6 +108,29 @@ "enabled": true, "id": "enumerate", "unknown": false + }, + "yaml": { + "enabled": true, + "entry-types": [ + "loop_invariant" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": false, + "other": false, + "accessed": false, + "exact": true, + "exclude-vars": [ + "tmp\\(___[0-9]+\\)?", + "cond", + "RETURN", + "__\\(cil_\\)?tmp_?[0-9]*\\(_[0-9]+\\)?", + ".*____CPAchecker_TMP_[0-9]+", + "__VERIFIER_assert__cond", + "__ksymtab_.*", + "\\(ldv_state_variable\\|ldv_timer_state\\|ldv_timer_list\\|ldv_irq_\\(line_\\|data_\\)?[0-9]+\\|ldv_retval\\)_[0-9]+" + ] } }, "pre": { diff --git a/conf/svcomp24.json b/conf/svcomp24.json index 178035eb8a..77f519a568 100644 --- a/conf/svcomp24.json +++ b/conf/svcomp24.json @@ -108,6 +108,29 @@ "enabled": true, "id": "enumerate", "unknown": false + }, + "yaml": { + "enabled": true, + "entry-types": [ + "loop_invariant" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": false, + "other": false, + "accessed": false, + "exact": true, + "exclude-vars": [ + "tmp\\(___[0-9]+\\)?", + "cond", + "RETURN", + "__\\(cil_\\)?tmp_?[0-9]*\\(_[0-9]+\\)?", + ".*____CPAchecker_TMP_[0-9]+", + "__VERIFIER_assert__cond", + "__ksymtab_.*", + "\\(ldv_state_variable\\|ldv_timer_state\\|ldv_timer_list\\|ldv_irq_\\(line_\\|data_\\)?[0-9]+\\|ldv_retval\\)_[0-9]+" + ] } }, "pre": { From ab9eacc13ba44deea33edd146615914cdf2d544e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 12:56:33 +0200 Subject: [PATCH 069/517] Copy svcomp24 conf to svcomp24-validate --- conf/svcomp24-validate.json | 139 ++++++++++++++++++++++++++++++++++++ 1 file changed, 139 insertions(+) create mode 100644 conf/svcomp24-validate.json diff --git a/conf/svcomp24-validate.json b/conf/svcomp24-validate.json new file mode 100644 index 0000000000..77f519a568 --- /dev/null +++ b/conf/svcomp24-validate.json @@ -0,0 +1,139 @@ +{ + "ana": { + "sv-comp": { + "enabled": true, + "functions": true + }, + "int": { + "def_exc": true, + "enums": false, + "interval": true + }, + "float": { + "interval": true + }, + "activated": [ + "base", + "threadid", + "threadflag", + "threadreturn", + "mallocWrapper", + "mutexEvents", + "mutex", + "access", + "race", + "escape", + "expRelation", + "mhp", + "assert", + "var_eq", + "symb_locks", + "region", + "thread", + "threadJoins" + ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "threadflag" + ], + "context": { + "widen": false + }, + "malloc": { + "wrappers": [ + "kmalloc", + "__kmalloc", + "usb_alloc_urb", + "__builtin_alloca", + "kzalloc", + + "ldv_malloc", + + "kzalloc_node", + "ldv_zalloc", + "kmalloc_array", + "kcalloc", + + "ldv_xmalloc", + "ldv_xzalloc", + "ldv_calloc", + "ldv_kzalloc" + ] + }, + "base": { + "arrays": { + "domain": "partitioned" + } + }, + "race": { + "free": false, + "call": false + }, + "autotune": { + "enabled": true, + "activated": [ + "singleThreaded", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "congruence", + "octagon", + "wideningThresholds", + "loopUnrollHeuristic", + "memsafetySpecification" + ] + } + }, + "exp": { + "region-offsets": true + }, + "solver": "td3", + "sem": { + "unknown_function": { + "spawn": false + }, + "int": { + "signed_overflow": "assume_none" + }, + "null-pointer": { + "dereference": "assume_none" + } + }, + "witness": { + "graphml": { + "enabled": true, + "id": "enumerate", + "unknown": false + }, + "yaml": { + "enabled": true, + "entry-types": [ + "loop_invariant" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": false, + "other": false, + "accessed": false, + "exact": true, + "exclude-vars": [ + "tmp\\(___[0-9]+\\)?", + "cond", + "RETURN", + "__\\(cil_\\)?tmp_?[0-9]*\\(_[0-9]+\\)?", + ".*____CPAchecker_TMP_[0-9]+", + "__VERIFIER_assert__cond", + "__ksymtab_.*", + "\\(ldv_state_variable\\|ldv_timer_state\\|ldv_timer_list\\|ldv_irq_\\(line_\\|data_\\)?[0-9]+\\|ldv_retval\\)_[0-9]+" + ] + } + }, + "pre": { + "enabled": false + } +} From 95ee32e6ea1bcb0a7075e9cea1f439d45f0d4965 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 13:08:21 +0200 Subject: [PATCH 070/517] Add YAML witness validation to svcomp24-validate conf --- conf/svcomp24-validate.json | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/conf/svcomp24-validate.json b/conf/svcomp24-validate.json index 77f519a568..3727c3e9f8 100644 --- a/conf/svcomp24-validate.json +++ b/conf/svcomp24-validate.json @@ -12,6 +12,10 @@ "float": { "interval": true }, + "apron": { + "domain": "polyhedra", + "strengthening": true + }, "activated": [ "base", "threadid", @@ -30,7 +34,9 @@ "symb_locks", "region", "thread", - "threadJoins" + "threadJoins", + "unassume", + "apron" ], "path_sens": [ "mutex", @@ -86,6 +92,9 @@ "loopUnrollHeuristic", "memsafetySpecification" ] + }, + "widen": { + "tokens": true } }, "exp": { @@ -105,32 +114,19 @@ }, "witness": { "graphml": { - "enabled": true, - "id": "enumerate", - "unknown": false + "enabled": false }, "yaml": { - "enabled": true, + "enabled": false, "entry-types": [ + "location_invariant", "loop_invariant" ] }, "invariant": { "loop-head": true, - "after-lock": false, - "other": false, - "accessed": false, - "exact": true, - "exclude-vars": [ - "tmp\\(___[0-9]+\\)?", - "cond", - "RETURN", - "__\\(cil_\\)?tmp_?[0-9]*\\(_[0-9]+\\)?", - ".*____CPAchecker_TMP_[0-9]+", - "__VERIFIER_assert__cond", - "__ksymtab_.*", - "\\(ldv_state_variable\\|ldv_timer_state\\|ldv_timer_list\\|ldv_irq_\\(line_\\|data_\\)?[0-9]+\\|ldv_retval\\)_[0-9]+" - ] + "after-lock": true, + "other": true } }, "pre": { From ce917e639d88c0777cd929de635c030fe060cf2b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 13:13:52 +0200 Subject: [PATCH 071/517] Update sv-comp/archive.sh for 2024 --- sv-comp/archive.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/sv-comp/archive.sh b/sv-comp/archive.sh index 9bab49f70d..87dcd75eb9 100755 --- a/sv-comp/archive.sh +++ b/sv-comp/archive.sh @@ -4,7 +4,7 @@ make clean -git tag -m "SV-COMP 2023" svcomp23 +git tag -m "SV-COMP 2024" svcomp24 dune build --profile=release src/goblint.exe rm -f goblint @@ -32,7 +32,8 @@ zip goblint/sv-comp/goblint.zip \ goblint/lib/libboxD.so \ goblint/lib/libpolkaMPQ.so \ goblint/lib/LICENSE.APRON \ - goblint/conf/svcomp23.json \ + goblint/conf/svcomp24.json \ + goblint/conf/svcomp24-validate.json \ goblint/lib/libc/stub/include/assert.h \ goblint/lib/goblint/runtime/include/goblint.h \ goblint/lib/libc/stub/src/stdlib.c \ From 6bad00c305c18578af314b3f1b83ee76aa23f8a6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Nov 2023 13:22:09 +0200 Subject: [PATCH 072/517] Fix Apron license for unpinned package for SV-COMP --- sv-comp/archive.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sv-comp/archive.sh b/sv-comp/archive.sh index 87dcd75eb9..5d8605dc70 100755 --- a/sv-comp/archive.sh +++ b/sv-comp/archive.sh @@ -18,7 +18,7 @@ cp _opam/share/apron/lib/libapron.so lib/ cp _opam/share/apron/lib/liboctD.so lib/ cp _opam/share/apron/lib/libboxD.so lib/ cp _opam/share/apron/lib/libpolkaMPQ.so lib/ -cp _opam/.opam-switch/sources/apron/COPYING lib/LICENSE.APRON +wget -O lib/LICENSE.APRON https://raw.githubusercontent.com/antoinemine/apron/master/COPYING # done outside to ensure archive contains goblint/ directory cd .. From 0f1389808ff3a848a9d6e6484df3f381860c7ddc Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 1 Nov 2023 17:14:03 +0200 Subject: [PATCH 073/517] 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 993a0455cbdde81e5eaa41d3a1890f09ac9258b6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 2 Nov 2023 12:25:38 +0200 Subject: [PATCH 074/517] Extract both branches dead test from concrat/Remotery --- tests/regression/00-sanity/41-both_branches-2.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 tests/regression/00-sanity/41-both_branches-2.c diff --git a/tests/regression/00-sanity/41-both_branches-2.c b/tests/regression/00-sanity/41-both_branches-2.c new file mode 100644 index 0000000000..4bfd339b13 --- /dev/null +++ b/tests/regression/00-sanity/41-both_branches-2.c @@ -0,0 +1,17 @@ +// PARAM: --disable sem.unknown_function.invalidate.globals +#include +struct S { + int *f[1]; +}; + +int main() { + struct S* s; + s = magic(); + + int *p = s->f[0]; + if (p) + __goblint_check(1); // reachable + else + __goblint_check(1); // reachable + return 0; +} From 4ea07567add44655631166371103c1512a32b678 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 2 Nov 2023 12:37:03 +0200 Subject: [PATCH 075/517] Fix both branches dead from bot address in array Fix from https://github.com/goblint/analyzer/issues/1188#issuecomment-1735060169. --- 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..003a65a49e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -201,7 +201,7 @@ struct let typAttr = typeAttrs ai in let can_recover_from_top = ArrayDomain.can_recover_from_top (ArrayDomain.get_domain ~varAttr ~typAttr) in let len = array_length_idx (IndexDomain.top ()) length in - Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else (bot_value ai))) + Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else Bot)) | TNamed ({ttype=t; _}, _) -> top_value ~varAttr t | _ -> Top From 421abcd41fa5084c3f07854b88a26a1382d253e1 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Tue, 7 Nov 2023 21:44:51 +0100 Subject: [PATCH 076/517] Warn whenever there's allocated heap memory that's unreachable from globals at program exit --- src/analyses/memLeak.ml | 32 ++++++++++++++++++++++++++++---- 1 file changed, 28 insertions(+), 4 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index dbaa2d69fc..f7f555a70a 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -19,6 +19,22 @@ struct let context _ _ = () (* HELPER FUNCTIONS *) + let get_global_vars () = + (* Filtering by GVar seems to account for declarations, as well as definitions of global vars *) + List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + + let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = + global_vars + |> List.map (fun v -> Lval (Var v, NoOffset)) + |> List.filter_map (fun exp -> + match ctx.ask (Queries.MayPointTo exp) with + | a when not (Queries.AD.is_top a) && Queries.AD.cardinal a = 1 -> + begin match List.hd @@ Queries.AD.elements a with + | Queries.AD.Addr.Addr (v, _) when (ctx.ask (Queries.IsHeapVar v)) && not (ctx.ask (Queries.IsMultiple v)) -> Some v + | _ -> None + end + | _ -> None) + let warn_for_multi_threaded ctx = if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) then ( set_mem_safety_flag InvalidMemTrack; @@ -27,17 +43,25 @@ struct ) let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = - let state = ctx.local in - if not @@ D.is_empty state then + let allocated_mem = ctx.local in + if not (D.is_empty allocated_mem) then + let reachable_mem = D.of_list (get_reachable_mem_from_globals (get_global_vars ()) ctx) in + (* Check and warn if there's unreachable allocated memory at program exit *) + let allocated_and_unreachable_mem = D.diff allocated_mem reachable_mem in + if not (D.is_empty allocated_and_unreachable_mem) then ( + set_mem_safety_flag InvalidMemTrack; + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "There is unreachable allocated heap memory at program exit. A memory leak might occur for the alloc vars %a\n" (Pretty.d_list ", " CilType.Varinfo.pretty) (D.elements allocated_and_unreachable_mem) + ); + (* Check and warn if some of the allocated memory is not deallocated at program exit *) match assert_exp_imprecise, exp with | true, Some exp -> set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty state + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty allocated_mem | _ -> set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables: %a" D.pretty state + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables: %a" D.pretty allocated_mem (* TRANSFER FUNCTIONS *) let return ctx (exp:exp option) (f:fundec) : D.t = From 9f7224ed8d6ffeaeda226b62a71d40b1dbd247f5 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Tue, 7 Nov 2023 21:45:21 +0100 Subject: [PATCH 077/517] Add test cases for unreachable heap memory from globals --- .../regression/76-memleak/08-unreachable-mem.c | 12 ++++++++++++ .../76-memleak/09-unreachable-with-local-var.c | 17 +++++++++++++++++ 2 files changed, 29 insertions(+) create mode 100644 tests/regression/76-memleak/08-unreachable-mem.c create mode 100644 tests/regression/76-memleak/09-unreachable-with-local-var.c diff --git a/tests/regression/76-memleak/08-unreachable-mem.c b/tests/regression/76-memleak/08-unreachable-mem.c new file mode 100644 index 0000000000..08e7b4e741 --- /dev/null +++ b/tests/regression/76-memleak/08-unreachable-mem.c @@ -0,0 +1,12 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +int *g; + +int main(int argc, char const *argv[]) { + g = malloc(sizeof(int)); + // Reference to g's heap contents is lost here + g = NULL; + + return 0; //WARN +} diff --git a/tests/regression/76-memleak/09-unreachable-with-local-var.c b/tests/regression/76-memleak/09-unreachable-with-local-var.c new file mode 100644 index 0000000000..1614b19132 --- /dev/null +++ b/tests/regression/76-memleak/09-unreachable-with-local-var.c @@ -0,0 +1,17 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +int *g; + +int main(int argc, char const *argv[]) { + g = malloc(sizeof(int)); + // Reference to g's heap contents is lost here + g = NULL; + // We get a false positive for p's memory being unreachable + // It's still leaked, but due to free() being commented out + // TODO: Should we only improve the error reporting for unreachable memory in this case? + int *p = malloc(sizeof(int)); + //free(p); + + return 0; //WARN +} From c056b32954f095f4ee4ab3a2fcab536eec35bdf2 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 8 Nov 2023 20:51:19 +0100 Subject: [PATCH 078/517] Remove //TODO comment from `76/09` --- tests/regression/76-memleak/09-unreachable-with-local-var.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/tests/regression/76-memleak/09-unreachable-with-local-var.c b/tests/regression/76-memleak/09-unreachable-with-local-var.c index 1614b19132..bc71bb560e 100644 --- a/tests/regression/76-memleak/09-unreachable-with-local-var.c +++ b/tests/regression/76-memleak/09-unreachable-with-local-var.c @@ -7,11 +7,9 @@ int main(int argc, char const *argv[]) { g = malloc(sizeof(int)); // Reference to g's heap contents is lost here g = NULL; - // We get a false positive for p's memory being unreachable - // It's still leaked, but due to free() being commented out - // TODO: Should we only improve the error reporting for unreachable memory in this case? + + // According to `valid-memtrack`, the memory of p is unreachable and we don't have a false positive int *p = malloc(sizeof(int)); - //free(p); return 0; //WARN } From 175b003aa3fae00a07052e6ae58d3cf6a8173cac Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 8 Nov 2023 21:52:45 +0200 Subject: [PATCH 079/517] Don't set `InvalidMemTrack` flag a second time Co-authored-by: Michael Schwarz --- src/analyses/memLeak.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index f7f555a70a..865ecaffc4 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -55,7 +55,6 @@ struct (* Check and warn if some of the allocated memory is not deallocated at program exit *) match assert_exp_imprecise, exp with | true, Some exp -> - set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty allocated_mem | _ -> From 05e4892feac736b520c81c151ed5b2558187e1a0 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 8 Nov 2023 21:53:56 +0200 Subject: [PATCH 080/517] Don't set `InvalidMemTrack` flag a second time Co-authored-by: Michael Schwarz --- src/analyses/memLeak.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 865ecaffc4..fc015f458b 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -58,7 +58,6 @@ struct set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty allocated_mem | _ -> - set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables: %a" D.pretty allocated_mem From f343d74efa850011f6ebebf1ce819f9bc1acefb9 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 8 Nov 2023 22:52:27 +0100 Subject: [PATCH 081/517] Add 3 regr. tests for trying out global struct variables --- .../76-memleak/10-global-struct-no-ptr.c | 16 ++++++++++++ .../76-memleak/11-global-struct-ptr.c | 19 ++++++++++++++ .../76-memleak/12-global-nested-struct-ptr.c | 25 +++++++++++++++++++ 3 files changed, 60 insertions(+) create mode 100644 tests/regression/76-memleak/10-global-struct-no-ptr.c create mode 100644 tests/regression/76-memleak/11-global-struct-ptr.c create mode 100644 tests/regression/76-memleak/12-global-nested-struct-ptr.c diff --git a/tests/regression/76-memleak/10-global-struct-no-ptr.c b/tests/regression/76-memleak/10-global-struct-no-ptr.c new file mode 100644 index 0000000000..490b2bb443 --- /dev/null +++ b/tests/regression/76-memleak/10-global-struct-no-ptr.c @@ -0,0 +1,16 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +typedef struct st { + int *a; + int b; +} st; + +st st_nonptr; + +int main(int argc, char const *argv[]) { + st_nonptr.a = malloc(sizeof(int)); + st_nonptr.a = NULL; + + return 0; //WARN +} diff --git a/tests/regression/76-memleak/11-global-struct-ptr.c b/tests/regression/76-memleak/11-global-struct-ptr.c new file mode 100644 index 0000000000..4ebe1c16b8 --- /dev/null +++ b/tests/regression/76-memleak/11-global-struct-ptr.c @@ -0,0 +1,19 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +typedef struct st { + int *a; + int b; +} st; + +st *st_ptr; + +int main(int argc, char const *argv[]) { + st_ptr = malloc(sizeof(st)); + st_ptr->a = malloc(sizeof(int)); + st_ptr->a = NULL; + free(st_ptr); + + // Only st_ptr->a is causing trouble here + return 0; //WARN +} diff --git a/tests/regression/76-memleak/12-global-nested-struct-ptr.c b/tests/regression/76-memleak/12-global-nested-struct-ptr.c new file mode 100644 index 0000000000..e0f5175064 --- /dev/null +++ b/tests/regression/76-memleak/12-global-nested-struct-ptr.c @@ -0,0 +1,25 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +typedef struct st { + int *a; + int b; +} st; + +typedef struct st2 { + st *st_ptr; +} st2; + +st2 *st_var; + +int main(int argc, char const *argv[]) { + st_var = malloc(sizeof(st2)); + st_var->st_ptr = malloc(sizeof(st)); + st_var->st_ptr->a = malloc(sizeof(int)); + st_var->st_ptr->a = NULL; + free(st_var->st_ptr); + free(st_var); + + // Only st_var->st_ptr->a is causing trouble here + return 0; //WARN +} From 7fc834308201ea8e7d2cd0d8c79bfe0c81833cae Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 9 Nov 2023 13:56:10 +0200 Subject: [PATCH 082/517] Fix relation read_globals_to_locals reading untracked variables --- 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 13f549fc44..0fa26781dd 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -70,7 +70,7 @@ struct let visitor = object inherit nopCilVisitor method! vlval = function - | (Var v, NoOffset) when v.vglob || ThreadEscape.has_escaped ask v -> + | (Var v, NoOffset) when (v.vglob || ThreadEscape.has_escaped ask v) && RD.Tracked.varinfo_tracked v -> let v_in = if VH.mem v_ins v then VH.find v_ins v From fbc66e32b897891d5a00dbe47ee719df7de75772 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 9 Nov 2023 15:18:59 +0200 Subject: [PATCH 083/517] Remove default Apron polyhedra in svcomp24-validate conf --- conf/svcomp24-validate.json | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/conf/svcomp24-validate.json b/conf/svcomp24-validate.json index 6479bd01b5..ce11af12f6 100644 --- a/conf/svcomp24-validate.json +++ b/conf/svcomp24-validate.json @@ -12,10 +12,6 @@ "float": { "interval": true }, - "apron": { - "domain": "polyhedra", - "strengthening": true - }, "activated": [ "base", "threadid", @@ -35,8 +31,7 @@ "region", "thread", "threadJoins", - "unassume", - "apron" + "unassume" ], "path_sens": [ "mutex", From e64558da31a28216909b948556d9848ca279f0cf Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 14 Nov 2023 14:46:20 +0100 Subject: [PATCH 084/517] Cache option ana.base.strings.domain, reset the cache in server. --- src/cdomains/stringDomain.ml | 27 ++++++++++++++++++++++----- src/cdomains/stringDomain.mli | 3 +++ src/util/server.ml | 1 + 3 files changed, 26 insertions(+), 5 deletions(-) diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml index 925a7fec62..bc4f6d3955 100644 --- a/src/cdomains/stringDomain.ml +++ b/src/cdomains/stringDomain.ml @@ -2,10 +2,27 @@ include Printable.StdLeaf let name () = "string" +type string_domain = Unit | Disjoint | Flat +let string_domain = ref None +let string_domain_config = "ana.base.strings.domain" +let parse config = match config with + | "unit" -> Unit + | "disjoint" -> Disjoint + | "flat" -> Flat + | _ -> raise @@ GobConfig.ConfigError ("Invalid option for " ^ string_domain_config) + +let get_string_domain () = + if !string_domain = None then + string_domain := Some (parse (GobConfig.get_string string_domain_config)); + Option.get !string_domain + +let reset_lazy () = + string_domain := None + type t = string option [@@deriving eq, ord, hash] let hash x = - if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then + if get_string_domain () = Disjoint then hash x else 13859 @@ -22,7 +39,7 @@ include Printable.SimpleShow ( ) let of_string x = - if GobConfig.get_string "ana.base.strings.domain" = "unit" then + if get_string_domain () = Unit then None else Some x @@ -74,7 +91,7 @@ let join x y = | _, None -> None | Some a, Some b when a = b -> Some a | Some a, Some b (* when a <> b *) -> - if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then + if get_string_domain () = Disjoint then raise Lattice.Uncomparable else None @@ -85,13 +102,13 @@ let meet x y = | a, None -> a | Some a, Some b when a = b -> Some a | Some a, Some b (* when a <> b *) -> - if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then + if get_string_domain () = Disjoint then raise Lattice.Uncomparable else raise Lattice.BotValue let repr x = - if GobConfig.get_string "ana.base.strings.domain" = "disjoint" then + if get_string_domain () = Disjoint then x (* everything else is kept separate, including strings if not limited *) else None (* all strings together if limited *) diff --git a/src/cdomains/stringDomain.mli b/src/cdomains/stringDomain.mli index 3541dac6e7..66423caa0b 100644 --- a/src/cdomains/stringDomain.mli +++ b/src/cdomains/stringDomain.mli @@ -2,6 +2,9 @@ include Printable.S +val reset_lazy: unit -> unit +(** Reset the cached configuration of the string domain. *) + val of_string: string -> t (** Convert from string. *) diff --git a/src/util/server.ml b/src/util/server.ml index 22f5a03350..829ee92ee8 100644 --- a/src/util/server.ml +++ b/src/util/server.ml @@ -280,6 +280,7 @@ let analyze ?(reset=false) (s: t) = InvariantCil.reset_lazy (); WideningThresholds.reset_lazy (); IntDomain.reset_lazy (); + StringDomain.reset_lazy (); PrecisionUtil.reset_lazy (); ApronDomain.reset_lazy (); AutoTune.reset_lazy (); From a2306181263a9c04f35fdb2fbc7874af2e3b1578 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 14 Nov 2023 14:47:50 +0100 Subject: [PATCH 085/517] Add newlines between functions. --- src/cdomains/stringDomain.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml index bc4f6d3955..978482a503 100644 --- a/src/cdomains/stringDomain.ml +++ b/src/cdomains/stringDomain.ml @@ -3,8 +3,11 @@ include Printable.StdLeaf let name () = "string" type string_domain = Unit | Disjoint | Flat + let string_domain = ref None + let string_domain_config = "ana.base.strings.domain" + let parse config = match config with | "unit" -> Unit | "disjoint" -> Disjoint From 6decbddb2503a7633c73b3151df40e158417ede8 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 15 Nov 2023 23:20:11 +0100 Subject: [PATCH 086/517] Improve the detection of reachable memory through global struct vars --- src/analyses/memLeak.ml | 89 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 88 insertions(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index fc015f458b..4d7e864c06 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -23,6 +23,14 @@ struct (* Filtering by GVar seems to account for declarations, as well as definitions of global vars *) List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + let get_global_struct_ptr_vars () = + List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + |> List.filter (fun v -> match v.vtype with TPtr (TComp _, _) | TPtr ((TNamed ({ttype = TComp _; _}, _)), _) -> true | _ -> false) + + let get_global_struct_non_ptr_vars () = + List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + |> List.filter (fun v -> match v.vtype with TComp (_, _) | (TNamed ({ttype = TComp _; _}, _)) -> true | _ -> false) + let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = global_vars |> List.map (fun v -> Lval (Var v, NoOffset)) @@ -35,6 +43,81 @@ struct end | _ -> None) + let rec get_reachable_mem_from_str_ptr_globals (global_struct_ptr_vars:varinfo list) ctx = + let eval_value_of_heap_var heap_var = + match ctx.ask (Queries.EvalValue (Lval (Var heap_var, NoOffset))) with + | a when not (Queries.VD.is_top a) -> + begin match a with + | Struct s -> + List.fold_left (fun acc f -> + if isPointerType f.ftype then + begin match ValueDomain.Structs.get s f with + | Queries.VD.Address a -> + let reachable_from_addr_set = + List.fold_left (fun acc addr -> + match addr with + | Queries.AD.Addr.Addr (v, _) -> List.append acc (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) + | _ -> acc + ) [] (Queries.AD.elements a) + in List.append acc reachable_from_addr_set + | _ -> acc + end + else acc + ) [] (ValueDomain.Structs.keys s) + | _ -> [] + end + | _ -> [] + in + let get_pts_of_non_heap_ptr_var var = + match ctx.ask (Queries.MayPointTo (Lval (Var var, NoOffset))) with + | a when not (Queries.AD.is_top a) && Queries.AD.cardinal a = 1 -> + begin match List.hd @@ Queries.AD.elements a with + | Queries.AD.Addr.Addr (v, _) when (ctx.ask (Queries.IsHeapVar v)) && not (ctx.ask (Queries.IsMultiple v)) -> v :: (eval_value_of_heap_var v) + | Queries.AD.Addr.Addr (v, _) when not (ctx.ask (Queries.IsAllocVar v)) && isPointerType v.vtype -> get_reachable_mem_from_str_ptr_globals [v] ctx + | _ -> [] + end + | _ -> [] + in + global_struct_ptr_vars + |> List.fold_left (fun acc var -> + if ctx.ask (Queries.IsHeapVar var) then eval_value_of_heap_var var + else if not (ctx.ask (Queries.IsAllocVar var)) && isPointerType var.vtype then get_pts_of_non_heap_ptr_var var + else acc + ) [] + + let get_reachable_mem_from_str_non_ptr_globals (global_struct_non_ptr_vars:varinfo list) ctx = + global_struct_non_ptr_vars + (* Filter out global struct vars that don't have pointer fields *) + |> List.filter_map (fun v -> + match ctx.ask (Queries.EvalValue (Lval (Var v, NoOffset))) with + | a when not (Queries.VD.is_top a) -> + begin match a with + | Queries.VD.Struct s -> + let struct_fields = ValueDomain.Structs.keys s in + let ptr_struct_fields = List.filter (fun f -> isPointerType f.ftype) struct_fields in + if List.length ptr_struct_fields = 0 then None else Some (s, ptr_struct_fields) + | _ -> None + end + | _ -> None + ) + |> List.fold_left (fun acc_struct (s, fields) -> + let reachable_from_fields = + List.fold_left (fun acc_field field -> + match ValueDomain.Structs.get s field with + | Queries.VD.Address a -> + let reachable_from_addr_set = + List.fold_left (fun acc_addr addr -> + match addr with + | Queries.AD.Addr.Addr (v, _) -> List.append acc_addr (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) + | _ -> acc_addr + ) [] (Queries.AD.elements a) + in List.append acc_field reachable_from_addr_set + | _ -> acc_field + ) [] fields + in + List.append acc_struct reachable_from_fields + ) [] + let warn_for_multi_threaded ctx = if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) then ( set_mem_safety_flag InvalidMemTrack; @@ -45,7 +128,11 @@ struct let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = let allocated_mem = ctx.local in if not (D.is_empty allocated_mem) then - let reachable_mem = D.of_list (get_reachable_mem_from_globals (get_global_vars ()) ctx) in + let reachable_mem_from_non_struct_globals = D.of_list (get_reachable_mem_from_globals (get_global_vars ()) ctx) in + let reachable_mem_from_struct_ptr_globals = D.of_list (get_reachable_mem_from_str_ptr_globals (get_global_struct_ptr_vars ()) ctx) in + let reachable_mem_from_struct_non_ptr_globals = D.of_list (get_reachable_mem_from_str_non_ptr_globals (get_global_struct_non_ptr_vars ()) ctx) in + let reachable_mem_from_struct_globals = D.join reachable_mem_from_struct_ptr_globals reachable_mem_from_struct_non_ptr_globals in + let reachable_mem = D.join reachable_mem_from_non_struct_globals reachable_mem_from_struct_globals in (* Check and warn if there's unreachable allocated memory at program exit *) let allocated_and_unreachable_mem = D.diff allocated_mem reachable_mem in if not (D.is_empty allocated_and_unreachable_mem) then ( From c3804260bf8bc43ea90e76ea9f2cf0f7ebb7186f Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 15 Nov 2023 23:20:53 +0100 Subject: [PATCH 087/517] Add regr. tests for reachable memory through global struct vars --- .../13-global-nested-struct-ptr-reachable.c | 29 +++++++++++++++++++ ...4-global-nested-struct-non-ptr-reachable.c | 25 ++++++++++++++++ 2 files changed, 54 insertions(+) create mode 100644 tests/regression/76-memleak/13-global-nested-struct-ptr-reachable.c create mode 100644 tests/regression/76-memleak/14-global-nested-struct-non-ptr-reachable.c diff --git a/tests/regression/76-memleak/13-global-nested-struct-ptr-reachable.c b/tests/regression/76-memleak/13-global-nested-struct-ptr-reachable.c new file mode 100644 index 0000000000..1726625a59 --- /dev/null +++ b/tests/regression/76-memleak/13-global-nested-struct-ptr-reachable.c @@ -0,0 +1,29 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +typedef struct st { + int *a; + int b; +} st; + +typedef struct st2 { + st *st_ptr; +} st2; + +st2 *st_var; + +int main(int argc, char const *argv[]) { + st_var = malloc(sizeof(st2)); + st_var->st_ptr = malloc(sizeof(st)); + int *local_ptr = malloc(sizeof(int)); + st_var->st_ptr->a = local_ptr; + local_ptr = NULL; + + free(st_var->st_ptr); + free(st_var); + + // local_ptr's memory is reachable through st_var->st_ptr->a + // It's leaked, because we don't call free() on it + // Hence, there should be a single warning for a memory leak, but not for unreachable memory + return 0; //WARN +} diff --git a/tests/regression/76-memleak/14-global-nested-struct-non-ptr-reachable.c b/tests/regression/76-memleak/14-global-nested-struct-non-ptr-reachable.c new file mode 100644 index 0000000000..1153bd81e0 --- /dev/null +++ b/tests/regression/76-memleak/14-global-nested-struct-non-ptr-reachable.c @@ -0,0 +1,25 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include + +typedef struct st { + int *a; + int b; +} st; + +typedef struct st2 { + st *st_ptr; +} st2; + +st2 st_var; + +int main(int argc, char const *argv[]) { + st_var.st_ptr = malloc(sizeof(st)); + int *local_ptr = malloc(sizeof(int)); + st_var.st_ptr->a = local_ptr; + local_ptr = NULL; + free(st_var.st_ptr); + + // local_ptr's memory is reachable through st_var.st_ptr->a, but it's not freed + // Hence, there should be only a single warning for a memory leak, but not for unreachable memory + return 0; //WARN +} From 845910410bbda2f9964ccd727d63a6e7b811ac7f Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Wed, 15 Nov 2023 23:33:58 +0100 Subject: [PATCH 088/517] Fix semgrep warning for using `List.length` for an emptiness check --- src/analyses/memLeak.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index a5d357d9c8..51a5a2ff75 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -96,7 +96,7 @@ struct | Queries.VD.Struct s -> let struct_fields = ValueDomain.Structs.keys s in let ptr_struct_fields = List.filter (fun f -> isPointerType f.ftype) struct_fields in - if List.length ptr_struct_fields = 0 then None else Some (s, ptr_struct_fields) + if ptr_struct_fields = [] then None else Some (s, ptr_struct_fields) | _ -> None end | _ -> None From f209afdae5be755eeded7bb0080473fe15571b7d Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Thu, 16 Nov 2023 07:52:56 +0100 Subject: [PATCH 089/517] First attempt to improve precision for multi-threaded valid-memcleanup --- src/analyses/memLeak.ml | 72 +++++++++++++++++++++++++++++++++-------- 1 file changed, 59 insertions(+), 13 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 9c09c05cf6..c64bb95697 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -6,30 +6,50 @@ open MessageCategory open AnalysisStateUtil module ToppedVarInfoSet = SetDomain.ToppedSet(CilType.Varinfo)(struct let topname = "All Heap Variables" end) - +module WasMallocCalled = BoolDomain.MustBool module Spec : Analyses.MCPSpec = struct include Analyses.IdentitySpec let name () = "memLeak" - module D = ToppedVarInfoSet + (* module D = ToppedVarInfoSet *) + module D = Lattice.Prod(ToppedVarInfoSet)(WasMallocCalled) module C = D module P = IdentityP (D) + module G = ToppedVarInfoSet + module V = + struct + include ThreadIdDomain.Thread + include StdV + end let context _ d = d (* HELPER FUNCTIONS *) - let warn_for_multi_threaded ctx = - if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) then ( + let warn_for_multi_threaded_due_to_abort ctx = + let state = ctx.local in + if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) && snd state then ( set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program isn't running in single-threaded mode. A memory leak might occur due to multi-threading" + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program aborted while running in multi-threaded mode. A memory leak might occur" + ) + + (* If [is_return] is set to [true], then a thread return occurred, else a thread join *) + let warn_for_thread_return_or_exit current_thread ctx is_return = + let global_state = ctx.global current_thread in + if not (G.is_empty global_state) then ( + set_mem_safety_flag InvalidMemcleanup; + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s" (if is_return then "return" else "join") ) + (* if not (ToppedVarInfoSet.is_empty (fst state)) && snd state then ( + set_mem_safety_flag InvalidMemcleanup; + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s" (if is_return then "return" else "join") + ) *) let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = let state = ctx.local in - if not @@ D.is_empty state then + if not (ToppedVarInfoSet.is_empty (fst state)) then match assert_exp_imprecise, exp with | true, Some exp -> set_mem_safety_flag InvalidMemTrack; @@ -42,6 +62,12 @@ struct (* TRANSFER FUNCTIONS *) let return ctx (exp:exp option) (f:fundec) : D.t = + (* Check for a valid-memcleanup violation in a multi-threaded setting *) + if (ctx.ask (Queries.MayBeThreadReturn)) then ( + match ctx.ask (Queries.CurrentThreadId) with + | `Lifted tid -> warn_for_thread_return_or_exit tid ctx true + | _ -> () + ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) if f.svar.vname = "main" then check_for_mem_leak ctx; ctx.local @@ -53,25 +79,39 @@ struct | Malloc _ | Calloc _ | Realloc _ -> - (* Warn about multi-threaded programs as soon as we encounter a dynamic memory allocation function *) - warn_for_multi_threaded ctx; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with - | `Lifted var -> D.add var state - | _ -> state + | `Lifted var -> + begin match ctx.ask (Queries.CurrentThreadId) with + | `Lifted tid -> + let current_globals = ctx.global tid in + let globals_to_side_effect = G.add var current_globals in + ctx.sideg tid globals_to_side_effect; + | _ -> () + end; + (ToppedVarInfoSet.add var (fst state), true) + | _ -> (fst state, true) end | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with | ad when not (Queries.AD.is_top ad) && Queries.AD.cardinal ad = 1 -> (* Note: Need to always set "ana.malloc.unique_address_count" to a value > 0 *) begin match Queries.AD.choose ad with - | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> D.remove v state (* Unique pointed to heap vars *) + | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> + begin match ctx.ask (Queries.CurrentThreadId) with + | `Lifted tid -> + let current_globals = ctx.global tid in + let globals_to_side_effect = G.remove v current_globals in + ctx.sideg tid globals_to_side_effect + | _ -> () + end; + (ToppedVarInfoSet.remove v (fst state), snd state) (* Unique pointed to heap vars *) | _ -> state end | _ -> state end | Abort -> - (* An "Abort" special function indicates program exit => need to check for memory leaks *) - check_for_mem_leak ctx; + (* Upon a call to the "Abort" special function, we give up and conservatively warn *) + warn_for_multi_threaded_due_to_abort ctx; state | Assert { exp; _ } -> let warn_for_assert_exp = @@ -89,6 +129,12 @@ struct in warn_for_assert_exp; state + | ThreadExit _ -> + begin match ctx.ask (Queries.CurrentThreadId) with + | `Lifted tid -> warn_for_thread_return_or_exit tid ctx false + | _ -> () + end; + state | _ -> state let startstate v = D.bot () From c0fe89e93352f530317cf1a7836684de65b216f3 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Thu, 16 Nov 2023 07:53:21 +0100 Subject: [PATCH 090/517] Add regr. test cases for multi-threaded valid-memcleanup --- .../08-invalid-memcleanup-multi-threaded.c | 33 +++++++++++++++++++ ...-invalid-memcleanup-multi-threaded-abort.c | 33 +++++++++++++++++++ 2 files changed, 66 insertions(+) create mode 100644 tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c create mode 100644 tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c diff --git a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c new file mode 100644 index 0000000000..50b17fa65d --- /dev/null +++ b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c @@ -0,0 +1,33 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include +#include + +int *g; +int *m1; +int *m2; + +void *f1(void *arg) { + m1 = malloc(sizeof(int)); + // Thread t1 leaks m1 here + pthread_exit(NULL); //WARN +} + +void *f2(void *arg) { + m2 = malloc(sizeof(int)); + free(m2); // No leak for thread t2, since it calls free before exiting + pthread_exit(NULL); //NOWARN +} + +int main(int argc, char const *argv[]) { + g = malloc(sizeof(int)); + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + free(g); + + // main thread is not leaking anything + return 0; //NOWARN +} diff --git a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c new file mode 100644 index 0000000000..9aef45198e --- /dev/null +++ b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c @@ -0,0 +1,33 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include +#include + +int *g; +int *m1; +int *m2; + +void *f1(void *arg) { + m1 = malloc(sizeof(int)); + // Thread t1 leaks m1 here + exit(2); //WARN +} + +void *f2(void *arg) { + m2 = malloc(sizeof(int)); + free(m2); // No leak for thread t2, since it calls free before exiting + pthread_exit(NULL); //NOWARN +} + +int main(int argc, char const *argv[]) { + g = malloc(sizeof(int)); + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + free(g); + + // main thread is not leaking anything + return 0; //NOWARN +} From 6f549915ebd3c319422e36acab66eb90c614eea5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 12:57:05 +0200 Subject: [PATCH 091/517] Fix YAML witness invariants for unrolled loops (closes #1225) --- src/witness/yamlWitness.ml | 96 +++++++++++++++++++++++--------------- 1 file changed, 59 insertions(+), 37 deletions(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 9e8ebeff51..dc4890753d 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -145,6 +145,16 @@ struct module FCMap = BatHashtbl.Make (Printable.Prod (CilType.Fundec) (Spec.C)) type con_inv = {node: Node.t; context: Spec.C.t; invariant: Invariant.t; state: Spec.D.t} + (* TODO: fix location hack *) + module LH = BatHashtbl.Make (CilType.Location) + let location2nodes: Node.t list LH.t Lazy.t = lazy ( + let lh = LH.create 113 in + NH.iter (fun n _ -> + LH.modify_def [] (Node.location n) (List.cons n) lh + ) (Lazy.force nh); + lh + ) + let write () = let input_files = GobConfig.get_string_list "files" in let data_model = match GobConfig.get_string "exp.architecture" with @@ -208,26 +218,32 @@ struct (* Generate location invariants (without precondition) *) let entries = if entry_type_enabled YamlWitnessType.LocationInvariant.entry_type then ( - NH.fold (fun n local acc -> - let loc = Node.location n in - if is_invariant_node n then ( - let lvals = local_lvals n local in - match R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals}) with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Node.find_fundec n).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = Entry.invariant (CilType.Exp.show inv) in - let entry = Entry.location_invariant ~task ~location ~invariant in - entry :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) - acc - ) - else + LH.fold (fun loc ns acc -> + let fundec = ref None in + let inv = List.fold_left (fun acc n -> + if is_invariant_node n then ( + fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) + let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in + let lvals = local_lvals n local in + Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) + ) + else + acc + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = Entry.invariant (CilType.Exp.show inv) in + let entry = Entry.location_invariant ~task ~location ~invariant in + entry :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) acc - ) (Lazy.force nh) entries + ) (Lazy.force location2nodes) entries ) else entries @@ -236,25 +252,31 @@ struct (* Generate loop invariants (without precondition) *) let entries = if entry_type_enabled YamlWitnessType.LoopInvariant.entry_type then ( - NH.fold (fun n local acc -> - let loc = Node.location n in - if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( - match R.ask_local_node n ~local (Invariant Invariant.default_context) with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Node.find_fundec n).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = Entry.invariant (CilType.Exp.show inv) in - let entry = Entry.loop_invariant ~task ~location ~invariant in - entry :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) - acc - ) - else + LH.fold (fun loc ns acc -> + let fundec = ref None in + let inv = List.fold_left (fun acc n -> + if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( + fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) + let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in + Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) + ) + else + acc + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = Entry.invariant (CilType.Exp.show inv) in + let entry = Entry.loop_invariant ~task ~location ~invariant in + entry :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) acc - ) (Lazy.force nh) entries + ) (Lazy.force location2nodes) entries ) else entries From 952b90dbfcfd2c8ef4750abf4daca6cd5da6d8bd Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 13:19:09 +0200 Subject: [PATCH 092/517] Fix bisect_ppx build --- src/witness/yamlWitness.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 023212fa42..22800c07dc 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -251,7 +251,7 @@ struct fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in - Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) + Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) else acc @@ -284,7 +284,7 @@ struct if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in - Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) + Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) else acc @@ -448,7 +448,7 @@ struct fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in - Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) + Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) else acc @@ -481,7 +481,7 @@ struct if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in - Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) + Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) else acc From 4ae355695675d2030b00c5df991666b8952d6357 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 15:11:36 +0200 Subject: [PATCH 093/517] Fix missing unrolled iterations in YAML witness invariants Unrolled loop heads are different nodes, which aren't actually loop heads. For sound invariants, they must also be included if at a location if at least one is. --- src/witness/yamlWitness.ml | 152 ++++++++++++++++++------------------- 1 file changed, 76 insertions(+), 76 deletions(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 22800c07dc..1f83c8625e 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -245,29 +245,29 @@ struct let entries = if entry_type_enabled YamlWitnessType.LocationInvariant.entry_type then ( LH.fold (fun loc ns acc -> - let fundec = ref None in - let inv = List.fold_left (fun acc n -> - if is_invariant_node n then ( + if List.exists is_invariant_node ns then ( + let fundec = ref None in + let inv = List.fold_left (fun acc n -> fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) - else - acc - ) (Invariant.bot ()) ns - in - match inv with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = Entry.invariant (CilType.Exp.show inv) in - let entry = Entry.location_invariant ~task ~location ~invariant in - entry :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = Entry.invariant (CilType.Exp.show inv) in + let entry = Entry.location_invariant ~task ~location ~invariant in + entry :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + acc + ) + else acc ) (Lazy.force location2nodes) entries ) @@ -279,28 +279,28 @@ struct let entries = if entry_type_enabled YamlWitnessType.LoopInvariant.entry_type then ( LH.fold (fun loc ns acc -> - let fundec = ref None in - let inv = List.fold_left (fun acc n -> - if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( + if WitnessInvariant.emit_loop_head && List.exists (WitnessUtil.NH.mem WitnessInvariant.loop_heads) ns then ( + let fundec = ref None in + let inv = List.fold_left (fun acc n -> fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) - else - acc - ) (Invariant.bot ()) ns - in - match inv with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = Entry.invariant (CilType.Exp.show inv) in - let entry = Entry.loop_invariant ~task ~location ~invariant in - entry :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = Entry.invariant (CilType.Exp.show inv) in + let entry = Entry.loop_invariant ~task ~location ~invariant in + entry :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + acc + ) + else acc ) (Lazy.force location2nodes) entries ) @@ -442,29 +442,29 @@ struct let invariants = if invariant_type_enabled YamlWitnessType.InvariantSet.LocationInvariant.invariant_type then ( LH.fold (fun loc ns acc -> - let fundec = ref None in - let inv = List.fold_left (fun acc n -> - if is_invariant_node n then ( + if List.exists is_invariant_node ns then ( + let fundec = ref None in + let inv = List.fold_left (fun acc n -> fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) - else - acc - ) (Invariant.bot ()) ns - in - match inv with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = CilType.Exp.show inv in - let invariant = Entry.location_invariant' ~location ~invariant in - invariant :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = CilType.Exp.show inv in + let invariant = Entry.location_invariant' ~location ~invariant in + invariant :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + acc + ) + else acc ) (Lazy.force location2nodes) invariants ) @@ -476,28 +476,28 @@ struct let invariants = if invariant_type_enabled YamlWitnessType.InvariantSet.LoopInvariant.invariant_type then ( LH.fold (fun loc ns acc -> - let fundec = ref None in - let inv = List.fold_left (fun acc n -> - if WitnessInvariant.emit_loop_head && WitnessUtil.NH.mem WitnessInvariant.loop_heads n then ( + if WitnessInvariant.emit_loop_head && List.exists (WitnessUtil.NH.mem WitnessInvariant.loop_heads) ns then ( + let fundec = ref None in + let inv = List.fold_left (fun acc n -> fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) - else - acc - ) (Invariant.bot ()) ns - in - match inv with - | `Lifted inv -> - let invs = WitnessUtil.InvariantExp.process_exp inv in - List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in - let invariant = CilType.Exp.show inv in - let invariant = Entry.loop_invariant' ~location ~invariant in - invariant :: acc - ) acc invs - | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + ) (Invariant.bot ()) ns + in + match inv with + | `Lifted inv -> + let invs = WitnessUtil.InvariantExp.process_exp inv in + List.fold_left (fun acc inv -> + let location_function = (Option.get !fundec).svar.vname in + let location = Entry.location ~location:loc ~location_function in + let invariant = CilType.Exp.show inv in + let invariant = Entry.loop_invariant' ~location ~invariant in + invariant :: acc + ) acc invs + | `Bot | `Top -> (* TODO: 0 for bot (dead code)? *) + acc + ) + else acc ) (Lazy.force location2nodes) invariants ) From 0fb479f506c99e1e415c08d157ae09a8a768fa4c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 15:16:48 +0200 Subject: [PATCH 094/517] Refactor YAML witness fundec lookup --- src/witness/yamlWitness.ml | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 1f83c8625e..1f106c936e 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -246,9 +246,7 @@ struct if entry_type_enabled YamlWitnessType.LocationInvariant.entry_type then ( LH.fold (fun loc ns acc -> if List.exists is_invariant_node ns then ( - let fundec = ref None in let inv = List.fold_left (fun acc n -> - fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) @@ -256,10 +254,11 @@ struct in match inv with | `Lifted inv -> + let fundec = Node.find_fundec (List.hd ns) in (* TODO: fix location hack *) + let location_function = fundec.svar.vname in + let location = Entry.location ~location:loc ~location_function in let invs = WitnessUtil.InvariantExp.process_exp inv in List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in let invariant = Entry.invariant (CilType.Exp.show inv) in let entry = Entry.location_invariant ~task ~location ~invariant in entry :: acc @@ -280,19 +279,18 @@ struct if entry_type_enabled YamlWitnessType.LoopInvariant.entry_type then ( LH.fold (fun loc ns acc -> if WitnessInvariant.emit_loop_head && List.exists (WitnessUtil.NH.mem WitnessInvariant.loop_heads) ns then ( - let fundec = ref None in let inv = List.fold_left (fun acc n -> - fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) (Invariant.bot ()) ns in match inv with | `Lifted inv -> + let fundec = Node.find_fundec (List.hd ns) in (* TODO: fix location hack *) + let location_function = fundec.svar.vname in + let location = Entry.location ~location:loc ~location_function in let invs = WitnessUtil.InvariantExp.process_exp inv in List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in let invariant = Entry.invariant (CilType.Exp.show inv) in let entry = Entry.loop_invariant ~task ~location ~invariant in entry :: acc @@ -443,9 +441,7 @@ struct if invariant_type_enabled YamlWitnessType.InvariantSet.LocationInvariant.invariant_type then ( LH.fold (fun loc ns acc -> if List.exists is_invariant_node ns then ( - let fundec = ref None in let inv = List.fold_left (fun acc n -> - fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) @@ -453,10 +449,11 @@ struct in match inv with | `Lifted inv -> + let fundec = Node.find_fundec (List.hd ns) in (* TODO: fix location hack *) + let location_function = fundec.svar.vname in + let location = Entry.location ~location:loc ~location_function in let invs = WitnessUtil.InvariantExp.process_exp inv in List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in let invariant = CilType.Exp.show inv in let invariant = Entry.location_invariant' ~location ~invariant in invariant :: acc @@ -477,19 +474,18 @@ struct if invariant_type_enabled YamlWitnessType.InvariantSet.LoopInvariant.invariant_type then ( LH.fold (fun loc ns acc -> if WitnessInvariant.emit_loop_head && List.exists (WitnessUtil.NH.mem WitnessInvariant.loop_heads) ns then ( - let fundec = ref None in let inv = List.fold_left (fun acc n -> - fundec := Some (Node.find_fundec n); (* TODO: fix location hack *) let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in Invariant.(acc || R.ask_local_node n ~local (Invariant Invariant.default_context)) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) (Invariant.bot ()) ns in match inv with | `Lifted inv -> + let fundec = Node.find_fundec (List.hd ns) in (* TODO: fix location hack *) + let location_function = fundec.svar.vname in + let location = Entry.location ~location:loc ~location_function in let invs = WitnessUtil.InvariantExp.process_exp inv in List.fold_left (fun acc inv -> - let location_function = (Option.get !fundec).svar.vname in - let location = Entry.location ~location:loc ~location_function in let invariant = CilType.Exp.show inv in let invariant = Entry.loop_invariant' ~location ~invariant in invariant :: acc From 3c89ece9f7630beda3a057b1705a28ea0496dc65 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 15:32:41 +0200 Subject: [PATCH 095/517] Fix YamlWitness indentation --- src/witness/yamlWitness.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 1f106c936e..ee370f2b6a 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -445,7 +445,7 @@ struct let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in let lvals = local_lvals n local in Invariant.(acc || R.ask_local_node n ~local (Invariant {Invariant.default_context with lvals})) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) (Invariant.bot ()) ns + ) (Invariant.bot ()) ns in match inv with | `Lifted inv -> From b57e80d2f4a82102af284c6c6f3a26eba35d24b5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 15:54:27 +0200 Subject: [PATCH 096/517] Bump YAML entry size for large unrolled invariants --- src/witness/yamlWitness.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index ee370f2b6a..c80611c83f 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -148,7 +148,7 @@ let yaml_entries_to_file ?(invariants=0) yaml_entries file = (* Yaml_unix.to_file_exn file yaml *) (* to_file/to_string uses a fixed-size buffer... *) (* estimate how big it should be + extra in case empty *) - let text = match Yaml.to_string ~len:((List.length yaml_entries + invariants) * 4096 + 2048) yaml with + let text = match Yaml.to_string ~len:((List.length yaml_entries + invariants) * 8192 + 2048) yaml with | Ok text -> text | Error (`Msg m) -> failwith ("Yaml.to_string: " ^ m) in From f70948296572a81d36f734522c1441db3fec19bb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 17 Nov 2023 16:07:37 +0200 Subject: [PATCH 097/517] Make YAML output buffer sizing exponential --- src/util/std/gobYaml.ml | 11 +++++++++++ src/witness/yamlWitness.ml | 13 ++++++------- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/src/util/std/gobYaml.ml b/src/util/std/gobYaml.ml index a4f3e597aa..131daaaebb 100644 --- a/src/util/std/gobYaml.ml +++ b/src/util/std/gobYaml.ml @@ -1,3 +1,14 @@ +let to_string' ?(len=65535 * 4) ?encoding ?scalar_style ?layout_style v = + assert (len >= 1); + let rec aux len = + match Yaml.to_string ~len ?encoding ?scalar_style ?layout_style v with + | Ok _ as o -> o + | Error (`Msg ("scalar failed" | "doc_end failed")) when len < Sys.max_string_length / 2 -> + aux (len * 2) + | Error (`Msg _) as e -> e + in + aux len + include Yaml.Util include GobResult.Syntax diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index c80611c83f..635ba4ad72 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -143,12 +143,11 @@ struct } end -let yaml_entries_to_file ?(invariants=0) yaml_entries file = +let yaml_entries_to_file yaml_entries file = let yaml = `A yaml_entries in (* Yaml_unix.to_file_exn file yaml *) (* to_file/to_string uses a fixed-size buffer... *) - (* estimate how big it should be + extra in case empty *) - let text = match Yaml.to_string ~len:((List.length yaml_entries + invariants) * 8192 + 2048) yaml with + let text = match GobYaml.to_string' yaml with | Ok text -> text | Error (`Msg m) -> failwith ("Yaml.to_string: " ^ m) in @@ -432,7 +431,7 @@ struct in (* Generate invariant set *) - let (entries, invariants) = + let entries = if entry_type_enabled YamlWitnessType.InvariantSet.entry_type then ( let invariants = [] in @@ -503,10 +502,10 @@ struct let invariants = List.rev invariants in let entry = Entry.invariant_set ~task ~invariants in - (entry :: entries, List.length invariants) + entry :: entries ) else - (entries, 0) + entries in let yaml_entries = List.rev_map YamlWitnessType.Entry.to_yaml entries in (* reverse to make entries in file in the same order as generation messages *) @@ -515,7 +514,7 @@ struct (Pretty.dprintf "total generation entries: %d" (List.length yaml_entries), None); ]; - yaml_entries_to_file ~invariants yaml_entries (Fpath.v (GobConfig.get_string "witness.yaml.path")) + yaml_entries_to_file yaml_entries (Fpath.v (GobConfig.get_string "witness.yaml.path")) let write () = Timing.wrap "yaml witness" write () From 7289ec341760ab06ce518c7520b076ca50688bb3 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sat, 18 Nov 2023 14:38:13 +0100 Subject: [PATCH 098/517] Use solely local state for multi-threaded valid-memcleanup --- src/analyses/memLeak.ml | 61 ++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 34 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index c64bb95697..64fe7ab957 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -6,6 +6,7 @@ open MessageCategory open AnalysisStateUtil module ToppedVarInfoSet = SetDomain.ToppedSet(CilType.Varinfo)(struct let topname = "All Heap Variables" end) +module ThreadsToHeapVarsMap = MapDomain.MapBot(ThreadIdDomain.Thread)(ToppedVarInfoSet) module WasMallocCalled = BoolDomain.MustBool module Spec : Analyses.MCPSpec = struct @@ -13,16 +14,9 @@ struct let name () = "memLeak" - (* module D = ToppedVarInfoSet *) - module D = Lattice.Prod(ToppedVarInfoSet)(WasMallocCalled) + module D = Lattice.Prod(ThreadsToHeapVarsMap)(WasMallocCalled) module C = D module P = IdentityP (D) - module G = ToppedVarInfoSet - module V = - struct - include ThreadIdDomain.Thread - include StdV - end let context _ d = d @@ -35,21 +29,18 @@ struct M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program aborted while running in multi-threaded mode. A memory leak might occur" ) - (* If [is_return] is set to [true], then a thread return occurred, else a thread join *) + (* If [is_return] is set to [true], then a thread return occurred, else a thread exit *) let warn_for_thread_return_or_exit current_thread ctx is_return = - let global_state = ctx.global current_thread in - if not (G.is_empty global_state) then ( + let state = ctx.local in + let heap_vars_of_curr_tid = ThreadsToHeapVarsMap.find current_thread (fst state) in + if not (ToppedVarInfoSet.is_empty heap_vars_of_curr_tid) then ( set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s" (if is_return then "return" else "join") + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.Thread.pretty current_thread ) - (* if not (ToppedVarInfoSet.is_empty (fst state)) && snd state then ( - set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s" (if is_return then "return" else "join") - ) *) let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = let state = ctx.local in - if not (ToppedVarInfoSet.is_empty (fst state)) then + if not (ThreadsToHeapVarsMap.for_all (fun tid heap_vars -> ToppedVarInfoSet.is_empty heap_vars) (fst state)) then match assert_exp_imprecise, exp with | true, Some exp -> set_mem_safety_flag InvalidMemTrack; @@ -58,14 +49,15 @@ struct | _ -> set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables: %a" D.pretty state + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables" (* TRANSFER FUNCTIONS *) let return ctx (exp:exp option) (f:fundec) : D.t = (* Check for a valid-memcleanup violation in a multi-threaded setting *) if (ctx.ask (Queries.MayBeThreadReturn)) then ( match ctx.ask (Queries.CurrentThreadId) with - | `Lifted tid -> warn_for_thread_return_or_exit tid ctx true + | `Lifted tid -> + warn_for_thread_return_or_exit tid ctx true | _ -> () ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) @@ -83,34 +75,34 @@ struct | `Lifted var -> begin match ctx.ask (Queries.CurrentThreadId) with | `Lifted tid -> - let current_globals = ctx.global tid in - let globals_to_side_effect = G.add var current_globals in - ctx.sideg tid globals_to_side_effect; - | _ -> () - end; - (ToppedVarInfoSet.add var (fst state), true) + ((ThreadsToHeapVarsMap.add tid (ToppedVarInfoSet.singleton var) (fst state)), true) + | _ -> (fst state, true) + end | _ -> (fst state, true) end | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with - | ad when not (Queries.AD.is_top ad) && Queries.AD.cardinal ad = 1 -> + (* TODO: The cardinality of 1 seems to lead to the situation where only free() calls in main() are detected here (affects 76/08 and 76/09) *) + (* | ad when not (Queries.AD.is_top ad) && Queries.AD.cardinal ad = 1 -> *) + | ad when not (Queries.AD.is_top ad) -> (* Note: Need to always set "ana.malloc.unique_address_count" to a value > 0 *) begin match Queries.AD.choose ad with | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> begin match ctx.ask (Queries.CurrentThreadId) with | `Lifted tid -> - let current_globals = ctx.global tid in - let globals_to_side_effect = G.remove v current_globals in - ctx.sideg tid globals_to_side_effect - | _ -> () - end; - (ToppedVarInfoSet.remove v (fst state), snd state) (* Unique pointed to heap vars *) + let heap_vars_of_tid = ThreadsToHeapVarsMap.find tid (fst state) in + let heap_vars_of_tid_without_v = ToppedVarInfoSet.remove v heap_vars_of_tid in + let new_fst_state = ThreadsToHeapVarsMap.add tid heap_vars_of_tid_without_v (fst state) in + (new_fst_state, snd state) + | _ -> state + end | _ -> state end | _ -> state end | Abort -> - (* Upon a call to the "Abort" special function, we give up and conservatively warn *) + check_for_mem_leak ctx; + (* Upon a call to the "Abort" special function in the multi-threaded case, we give up and conservatively warn *) warn_for_multi_threaded_due_to_abort ctx; state | Assert { exp; _ } -> @@ -131,7 +123,8 @@ struct state | ThreadExit _ -> begin match ctx.ask (Queries.CurrentThreadId) with - | `Lifted tid -> warn_for_thread_return_or_exit tid ctx false + | `Lifted tid -> + warn_for_thread_return_or_exit tid ctx false | _ -> () end; state From 6cc01b5177b6bc31899c290b6ae65660bf4aa805 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sat, 18 Nov 2023 15:22:47 +0100 Subject: [PATCH 099/517] Use `unrollType` and `GVarDecl` for global vars Also use `Queries.AD.fold` where applicable and prepend to accumulators --- src/analyses/memLeak.ml | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 51a5a2ff75..c09db2d44f 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -21,15 +21,20 @@ struct (* HELPER FUNCTIONS *) let get_global_vars () = - (* Filtering by GVar seems to account for declarations, as well as definitions of global vars *) - List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + List.filter_map (function GVar (v, _, _) | GVarDecl (v, _) -> Some v | _ -> None) !Cilfacade.current_file.globals let get_global_struct_ptr_vars () = - List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals - |> List.filter (fun v -> match v.vtype with TPtr (TComp _, _) | TPtr ((TNamed ({ttype = TComp _; _}, _)), _) -> true | _ -> false) + get_global_vars () + |> List.filter (fun v -> + match unrollType v.vtype with + | TPtr (TComp _, _) + | TPtr ((TNamed ({ttype = TComp _; _}, _)), _) -> true + | TComp (_, _) + | (TNamed ({ttype = TComp _; _}, _)) -> false + | _ -> false) let get_global_struct_non_ptr_vars () = - List.filter_map (function GVar (v, _, _) -> Some v | _ -> None) !Cilfacade.current_file.globals + get_global_vars () |> List.filter (fun v -> match v.vtype with TComp (_, _) | (TNamed ({ttype = TComp _; _}, _)) -> true | _ -> false) let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = @@ -55,12 +60,13 @@ struct begin match ValueDomain.Structs.get s f with | Queries.VD.Address a -> let reachable_from_addr_set = - List.fold_left (fun acc addr -> + Queries.AD.fold (fun addr acc -> match addr with - | Queries.AD.Addr.Addr (v, _) -> List.append acc (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) + | Queries.AD.Addr.Addr (v, _) -> (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) @ acc | _ -> acc - ) [] (Queries.AD.elements a) - in List.append acc reachable_from_addr_set + ) a [] + in + reachable_from_addr_set @ acc | _ -> acc end else acc @@ -109,14 +115,14 @@ struct let reachable_from_addr_set = List.fold_left (fun acc_addr addr -> match addr with - | Queries.AD.Addr.Addr (v, _) -> List.append acc_addr (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) + | Queries.AD.Addr.Addr (v, _) -> (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) @ acc_addr | _ -> acc_addr ) [] (Queries.AD.elements a) - in List.append acc_field reachable_from_addr_set + in reachable_from_addr_set @ acc_field | _ -> acc_field ) [] fields in - List.append acc_struct reachable_from_fields + reachable_from_fields @ acc_struct ) [] let warn_for_multi_threaded ctx = From 80492ccd1dcad21e49a949a989d1cee42bbb6585 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sat, 18 Nov 2023 15:26:40 +0100 Subject: [PATCH 100/517] Check that addresses in struct fields are singletons and not top --- src/analyses/memLeak.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index c09db2d44f..7e77d62a4e 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -58,7 +58,7 @@ struct List.fold_left (fun acc f -> if isPointerType f.ftype then begin match ValueDomain.Structs.get s f with - | Queries.VD.Address a -> + | Queries.VD.Address a when not (Queries.AD.is_top a) && Queries.AD.cardinal a = 1 -> let reachable_from_addr_set = Queries.AD.fold (fun addr acc -> match addr with From 720cfeebd1987bda44e4b7f4a2d545be6530025d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 19 Nov 2023 17:32:05 +0100 Subject: [PATCH 101/517] IsMallocCalled should be `may` --- src/analyses/memLeak.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 64fe7ab957..336943d407 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -7,7 +7,7 @@ open AnalysisStateUtil module ToppedVarInfoSet = SetDomain.ToppedSet(CilType.Varinfo)(struct let topname = "All Heap Variables" end) module ThreadsToHeapVarsMap = MapDomain.MapBot(ThreadIdDomain.Thread)(ToppedVarInfoSet) -module WasMallocCalled = BoolDomain.MustBool +module WasMallocCalled = BoolDomain.MayBool module Spec : Analyses.MCPSpec = struct include Analyses.IdentitySpec From f2ca6d146e1271709259be24d5b20f9e61aab7dd Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sun, 19 Nov 2023 17:33:24 +0100 Subject: [PATCH 102/517] Use `unrollType` for non-pointer global struct vars --- src/analyses/memLeak.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 7e77d62a4e..ab25d49cc6 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -35,7 +35,11 @@ struct let get_global_struct_non_ptr_vars () = get_global_vars () - |> List.filter (fun v -> match v.vtype with TComp (_, _) | (TNamed ({ttype = TComp _; _}, _)) -> true | _ -> false) + |> List.filter (fun v -> + match unrollType v.vtype with + | TComp (_, _) + | (TNamed ({ttype = TComp _; _}, _)) -> true + | _ -> false) let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = global_vars From 0e09d099d5facf7354014319805eb53e186119d2 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sun, 19 Nov 2023 17:36:22 +0100 Subject: [PATCH 103/517] Don't forget to prepend to `acc` when collecting globally reachable mem --- src/analyses/memLeak.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index ab25d49cc6..3079faae1f 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -91,8 +91,8 @@ struct in global_struct_ptr_vars |> List.fold_left (fun acc var -> - if ctx.ask (Queries.IsHeapVar var) then eval_value_of_heap_var var - else if not (ctx.ask (Queries.IsAllocVar var)) && isPointerType var.vtype then get_pts_of_non_heap_ptr_var var + if ctx.ask (Queries.IsHeapVar var) then (eval_value_of_heap_var var) @ acc + else if not (ctx.ask (Queries.IsAllocVar var)) && isPointerType var.vtype then (get_pts_of_non_heap_ptr_var var) @ acc else acc ) [] From af9ddc766c5b72e7bbd9d3177e1cd028e52cfc52 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 19 Nov 2023 17:36:26 +0100 Subject: [PATCH 104/517] Add unsound example --- tests/regression/76-memleak/10-leak-later.c | 25 +++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 tests/regression/76-memleak/10-leak-later.c diff --git a/tests/regression/76-memleak/10-leak-later.c b/tests/regression/76-memleak/10-leak-later.c new file mode 100644 index 0000000000..6e6e51bbdc --- /dev/null +++ b/tests/regression/76-memleak/10-leak-later.c @@ -0,0 +1,25 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include +#include + +int *g; +int *m1; +int *m2; + +void *f1(void *arg) { + int top; + + // Thread t1 leaks m0 here + exit(2); //WARN +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + int* m0 = malloc(sizeof(int)); + free(m0); + + // main thread is not leaking anything + return 0; +} From ada84914a0da7614e023d6c0bf2ca86725d6551a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 19 Nov 2023 18:14:50 +0100 Subject: [PATCH 105/517] Make sound by accounting for alloc in global invariant --- src/analyses/memLeak.ml | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index b1b57b6694..d2d3ce0d97 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -14,16 +14,19 @@ struct let name () = "memLeak" - module D = Lattice.Prod(ThreadsToHeapVarsMap)(WasMallocCalled) + module D = ThreadsToHeapVarsMap module C = D module P = IdentityP (D) + module V = UnitV + module G = WasMallocCalled + let context _ d = d (* HELPER FUNCTIONS *) let warn_for_multi_threaded_due_to_abort ctx = - let state = ctx.local in - if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) && snd state then ( + let malloc_called = ctx.global () in + if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) && malloc_called then ( set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program aborted while running in multi-threaded mode. A memory leak might occur" @@ -32,7 +35,7 @@ struct (* If [is_return] is set to [true], then a thread return occurred, else a thread exit *) let warn_for_thread_return_or_exit current_thread ctx is_return = let state = ctx.local in - let heap_vars_of_curr_tid = ThreadsToHeapVarsMap.find current_thread (fst state) in + let heap_vars_of_curr_tid = ThreadsToHeapVarsMap.find current_thread state in if not (ToppedVarInfoSet.is_empty heap_vars_of_curr_tid) then ( set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.Thread.pretty current_thread @@ -40,7 +43,7 @@ struct let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = let state = ctx.local in - if not (ThreadsToHeapVarsMap.for_all (fun tid heap_vars -> ToppedVarInfoSet.is_empty heap_vars) (fst state)) then + if not (ThreadsToHeapVarsMap.for_all (fun tid heap_vars -> ToppedVarInfoSet.is_empty heap_vars) state) then match assert_exp_imprecise, exp with | true, Some exp -> set_mem_safety_flag InvalidMemTrack; @@ -71,14 +74,15 @@ struct | Malloc _ | Calloc _ | Realloc _ -> + ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> begin match ctx.ask (Queries.CurrentThreadId) with | `Lifted tid -> - ((ThreadsToHeapVarsMap.add tid (ToppedVarInfoSet.singleton var) (fst state)), true) - | _ -> (fst state, true) + (ThreadsToHeapVarsMap.add tid (ToppedVarInfoSet.singleton var) state) + | _ -> state end - | _ -> (fst state, true) + | _ -> state end | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with @@ -90,10 +94,10 @@ struct | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> begin match ctx.ask (Queries.CurrentThreadId) with | `Lifted tid -> - let heap_vars_of_tid = ThreadsToHeapVarsMap.find tid (fst state) in + let heap_vars_of_tid = ThreadsToHeapVarsMap.find tid state in let heap_vars_of_tid_without_v = ToppedVarInfoSet.remove v heap_vars_of_tid in - let new_fst_state = ThreadsToHeapVarsMap.add tid heap_vars_of_tid_without_v (fst state) in - (new_fst_state, snd state) + let new_fst_state = ThreadsToHeapVarsMap.add tid heap_vars_of_tid_without_v state in + new_fst_state | _ -> state end | _ -> state From e7d630231d2bfce552cbb262bf3f8a4882ddd1ff Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 19 Nov 2023 18:49:03 +0100 Subject: [PATCH 106/517] Cleanup --- src/analyses/memLeak.ml | 53 +++++++------------ .../08-invalid-memcleanup-multi-threaded.c | 2 +- ...-invalid-memcleanup-multi-threaded-abort.c | 2 +- 3 files changed, 20 insertions(+), 37 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index d2d3ce0d97..0f16cec4ab 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -6,7 +6,6 @@ open MessageCategory open AnalysisStateUtil module ToppedVarInfoSet = SetDomain.ToppedSet(CilType.Varinfo)(struct let topname = "All Heap Variables" end) -module ThreadsToHeapVarsMap = MapDomain.MapBot(ThreadIdDomain.Thread)(ToppedVarInfoSet) module WasMallocCalled = BoolDomain.MayBool module Spec : Analyses.MCPSpec = struct @@ -14,7 +13,7 @@ struct let name () = "memLeak" - module D = ThreadsToHeapVarsMap + module D = ToppedVarInfoSet module C = D module P = IdentityP (D) @@ -33,22 +32,20 @@ struct ) (* If [is_return] is set to [true], then a thread return occurred, else a thread exit *) - let warn_for_thread_return_or_exit current_thread ctx is_return = - let state = ctx.local in - let heap_vars_of_curr_tid = ThreadsToHeapVarsMap.find current_thread state in - if not (ToppedVarInfoSet.is_empty heap_vars_of_curr_tid) then ( + let warn_for_thread_return_or_exit ctx is_return = + if not (ToppedVarInfoSet.is_empty ctx.local) then ( set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.Thread.pretty current_thread + let current_thread = ctx.ask (Queries.CurrentThreadId) in + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.ThreadLifted.pretty current_thread ) let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = - let state = ctx.local in - if not (ThreadsToHeapVarsMap.for_all (fun tid heap_vars -> ToppedVarInfoSet.is_empty heap_vars) state) then + if not (ToppedVarInfoSet.is_empty ctx.local) then match assert_exp_imprecise, exp with | true, Some exp -> set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty state + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "assert expression %a is unknown. Memory leak might possibly occur for heap variables: %a" d_exp exp D.pretty ctx.local | _ -> set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; @@ -58,10 +55,7 @@ struct let return ctx (exp:exp option) (f:fundec) : D.t = (* Check for a valid-memcleanup violation in a multi-threaded setting *) if (ctx.ask (Queries.MayBeThreadReturn)) then ( - match ctx.ask (Queries.CurrentThreadId) with - | `Lifted tid -> - warn_for_thread_return_or_exit tid ctx true - | _ -> () + warn_for_thread_return_or_exit ctx true ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) if f.svar.vname = "main" then check_for_mem_leak ctx; @@ -74,35 +68,22 @@ struct | Malloc _ | Calloc _ | Realloc _ -> - ctx.sideg () true; + (ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> - begin match ctx.ask (Queries.CurrentThreadId) with - | `Lifted tid -> - (ThreadsToHeapVarsMap.add tid (ToppedVarInfoSet.singleton var) state) - | _ -> state - end + ToppedVarInfoSet.add var state | _ -> state - end + end) | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with - (* TODO: The cardinality of 1 seems to lead to the situation where only free() calls in main() are detected here (affects 76/08 and 76/09) *) - (* | ad when not (Queries.AD.is_top ad) && Queries.AD.cardinal ad = 1 -> *) - | ad when not (Queries.AD.is_top ad) -> + | ad when (not (Queries.AD.is_top ad)) && Queries.AD.cardinal ad = 1 -> (* Note: Need to always set "ana.malloc.unique_address_count" to a value > 0 *) begin match Queries.AD.choose ad with | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> - begin match ctx.ask (Queries.CurrentThreadId) with - | `Lifted tid -> - let heap_vars_of_tid = ThreadsToHeapVarsMap.find tid state in - let heap_vars_of_tid_without_v = ToppedVarInfoSet.remove v heap_vars_of_tid in - let new_fst_state = ThreadsToHeapVarsMap.add tid heap_vars_of_tid_without_v state in - new_fst_state - | _ -> state - end - | _ -> state + ToppedVarInfoSet.remove v ctx.local + | _ -> ctx.local end - | _ -> state + | _ -> ctx.local end | Abort -> check_for_mem_leak ctx; @@ -128,7 +109,7 @@ struct | ThreadExit _ -> begin match ctx.ask (Queries.CurrentThreadId) with | `Lifted tid -> - warn_for_thread_return_or_exit tid ctx false + warn_for_thread_return_or_exit ctx false | _ -> () end; state @@ -136,6 +117,8 @@ struct let startstate v = D.bot () let exitstate v = D.top () + + let threadenter ctx ~multiple lval f args = [D.bot ()] end let _ = diff --git a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c index 50b17fa65d..513a36db95 100644 --- a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c +++ b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c @@ -4,7 +4,6 @@ int *g; int *m1; -int *m2; void *f1(void *arg) { m1 = malloc(sizeof(int)); @@ -13,6 +12,7 @@ void *f1(void *arg) { } void *f2(void *arg) { + int *m2; m2 = malloc(sizeof(int)); free(m2); // No leak for thread t2, since it calls free before exiting pthread_exit(NULL); //NOWARN diff --git a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c index 9aef45198e..977510b9bb 100644 --- a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c +++ b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c @@ -4,7 +4,6 @@ int *g; int *m1; -int *m2; void *f1(void *arg) { m1 = malloc(sizeof(int)); @@ -13,6 +12,7 @@ void *f1(void *arg) { } void *f2(void *arg) { + int *m2; m2 = malloc(sizeof(int)); free(m2); // No leak for thread t2, since it calls free before exiting pthread_exit(NULL); //NOWARN From e6cee270129731e462b31a0a75cb360d02b784c6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 19 Nov 2023 19:01:11 +0100 Subject: [PATCH 107/517] Fix `memtrack` for multi-threaded case --- src/analyses/memLeak.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 0f16cec4ab..8a067cc80d 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -34,6 +34,7 @@ struct (* If [is_return] is set to [true], then a thread return occurred, else a thread exit *) let warn_for_thread_return_or_exit ctx is_return = if not (ToppedVarInfoSet.is_empty ctx.local) then ( + set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; let current_thread = ctx.ask (Queries.CurrentThreadId) in M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.ThreadLifted.pretty current_thread @@ -53,8 +54,9 @@ struct (* TRANSFER FUNCTIONS *) let return ctx (exp:exp option) (f:fundec) : D.t = - (* Check for a valid-memcleanup violation in a multi-threaded setting *) - if (ctx.ask (Queries.MayBeThreadReturn)) then ( + (* Check for a valid-memcleanup and memtrack violation in a multi-threaded setting *) + (* The check for multi-threadedness is to ensure that valid-memtrack and valid-memclenaup are treated separately for single-threaded programs *) + if (ctx.ask (Queries.MayBeThreadReturn) && not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true }))) then ( warn_for_thread_return_or_exit ctx true ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) From 97eb7156d4a71fce2e84153b1a11906db5e9f2de Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sun, 19 Nov 2023 19:23:20 +0100 Subject: [PATCH 108/517] Account for failing assertions in the multi-threaded case as well --- src/analyses/memLeak.ml | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 8a067cc80d..8d83bcee83 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -98,12 +98,16 @@ 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 - check_for_mem_leak ctx - else () - | None -> check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) + if b = false then ( + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx + ) + else ()) + | None -> + (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 987795ec92c6e03fc9b0b659dbc396b73df41098 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sun, 19 Nov 2023 19:26:39 +0100 Subject: [PATCH 109/517] Add a few more test cases --- .../76-memleak/11-leak-later-nested.c | 34 +++++++++++++++++++ .../76-memleak/12-multi-threaded-assert.c | 34 +++++++++++++++++++ .../13-assert-unknown-multi-threaded.c | 20 +++++++++++ 3 files changed, 88 insertions(+) create mode 100644 tests/regression/76-memleak/11-leak-later-nested.c create mode 100644 tests/regression/76-memleak/12-multi-threaded-assert.c create mode 100644 tests/regression/76-memleak/13-assert-unknown-multi-threaded.c diff --git a/tests/regression/76-memleak/11-leak-later-nested.c b/tests/regression/76-memleak/11-leak-later-nested.c new file mode 100644 index 0000000000..952dc66334 --- /dev/null +++ b/tests/regression/76-memleak/11-leak-later-nested.c @@ -0,0 +1,34 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +#include +#include + +int *g; +int *m1; +int *m2; + +void *f2(void *arg) { + // Thread t2 leaks m0 and t1_ptr here + quick_exit(2); //WARN +} + +void *f1(void *arg) { + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + int *t1_ptr = malloc(sizeof(int)); + + pthread_join(t2, NULL); + // t1_ptr is leaked, since t2 calls quick_exit() potentially before this program point + free(t1_ptr); +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + int* m0 = malloc(sizeof(int)); + free(m0); + + // main thread is not leaking anything + return 0; +} diff --git a/tests/regression/76-memleak/12-multi-threaded-assert.c b/tests/regression/76-memleak/12-multi-threaded-assert.c new file mode 100644 index 0000000000..309a5dde75 --- /dev/null +++ b/tests/regression/76-memleak/12-multi-threaded-assert.c @@ -0,0 +1,34 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --disable warn.assert +#include +#include +#include + +int *g; +int *m1; +int *m2; + +void *f2(void *arg) { + // Thread t2 leaks m0 and t1_ptr here + assert(0); //WARN +} + +void *f1(void *arg) { + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + int *t1_ptr = malloc(sizeof(int)); + assert(1); //NOWARN + pthread_join(t2, NULL); + free(t1_ptr); +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + int* m0 = malloc(sizeof(int)); + free(m0); + + // main thread is not leaking anything + return 0; +} diff --git a/tests/regression/76-memleak/13-assert-unknown-multi-threaded.c b/tests/regression/76-memleak/13-assert-unknown-multi-threaded.c new file mode 100644 index 0000000000..95eb291887 --- /dev/null +++ b/tests/regression/76-memleak/13-assert-unknown-multi-threaded.c @@ -0,0 +1,20 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --disable warn.assert +#include +#include +#include + +void *f1(void *arg) { + int top; + assert(top); //WARN +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + int* m0 = malloc(sizeof(int)); + free(m0); + + // main thread is not leaking anything + return 0; +} From 8d55024d0580b5a4aec7bd32103d0b3f0ab84d72 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Sun, 19 Nov 2023 19:45:27 +0100 Subject: [PATCH 110/517] Add options to produce warnings only for memory leaks due to `memcleanup` or `memtrack` violations --- src/common/util/options.schema.json | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/common/util/options.schema.json b/src/common/util/options.schema.json index 9a6a66ee6b..5923612b5b 100644 --- a/src/common/util/options.schema.json +++ b/src/common/util/options.schema.json @@ -2164,6 +2164,25 @@ "description": "Output messages in deterministic order. Useful for cram testing.", "type": "boolean", "default": false + }, + "memleak": { + "title": "warn.memleak", + "type":"object", + "properties": { + "memcleanup": { + "title": "warn.memleak.memcleanup", + "description": "Enable memory leak warnings only for violations of the SV-COMP \"valid-memcleanup\" category", + "type": "boolean", + "default": false + }, + "memtrack": { + "title": "warn.memleak.memtrack", + "description": "Enable memory leak warnings only for violations of the SV-COMP \"valid-memtrack\" category", + "type": "boolean", + "default": false + } + }, + "additionalProperties": false } }, "additionalProperties": false From ecd48aa318c0720c2f2b8b63a524635170df804e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 20 Nov 2023 10:46:35 +0200 Subject: [PATCH 111/517] Make SV-COMP validation strict --- conf/svcomp24-validate.json | 1 + src/common/util/options.schema.json | 6 ++++++ src/witness/witness.ml | 13 ++++++++++--- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/conf/svcomp24-validate.json b/conf/svcomp24-validate.json index ce11af12f6..2d7e988fdf 100644 --- a/conf/svcomp24-validate.json +++ b/conf/svcomp24-validate.json @@ -114,6 +114,7 @@ }, "yaml": { "enabled": false, + "strict": true, "format-version": "2.0", "entry-types": [ "location_invariant", diff --git a/src/common/util/options.schema.json b/src/common/util/options.schema.json index 328b4f277f..0732debcc9 100644 --- a/src/common/util/options.schema.json +++ b/src/common/util/options.schema.json @@ -2487,6 +2487,12 @@ "type": "string", "default": "" }, + "strict": { + "title": "witness.yaml.strict", + "description": "", + "type": "boolean", + "default": false + }, "unassume": { "title": "witness.yaml.unassume", "description": "YAML witness input path", diff --git a/src/witness/witness.ml b/src/witness/witness.ml index 235461c348..9d6a1ebe02 100644 --- a/src/witness/witness.ml +++ b/src/witness/witness.ml @@ -665,11 +665,18 @@ struct | Some false -> print_svcomp_result "ERROR (verify)" | _ -> if get_string "witness.yaml.validate" <> "" then ( - if !YamlWitness.cnt_refuted > 0 then + match get_bool "witness.yaml.strict" with + | true when !YamlWitness.cnt_error > 0 -> + print_svcomp_result "ERROR (witness error)" + | true when !YamlWitness.cnt_unsupported > 0 -> + print_svcomp_result "ERROR (witness unsupported)" + | true when !YamlWitness.cnt_disabled > 0 -> + print_svcomp_result "ERROR (witness disabled)" + | _ when !YamlWitness.cnt_refuted > 0 -> print_svcomp_result (Result.to_string (False None)) - else if !YamlWitness.cnt_unconfirmed > 0 then + | _ when !YamlWitness.cnt_unconfirmed > 0 -> print_svcomp_result (Result.to_string Unknown) - else + | _ -> write entrystates ) else From 6797cbb9ec941646316ffb689a12135bf1282b6a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 20 Nov 2023 12:21:32 +0200 Subject: [PATCH 112/517] Add ana.autotune.activated schema --- src/common/util/options.schema.json | 32 +++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/src/common/util/options.schema.json b/src/common/util/options.schema.json index 745aecfb57..2b1e738196 100644 --- a/src/common/util/options.schema.json +++ b/src/common/util/options.schema.json @@ -542,9 +542,37 @@ "title": "ana.autotune.activated", "description": "Lists of activated tuning options.", "type": "array", - "items": { "type": "string" }, + "items": { + "type": "string", + "enum": [ + "congruence", + "singleThreaded", + "specification", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "loopUnrollHeuristic", + "forceLoopUnrollForFewLoops", + "arrayDomain", + "octagon", + "wideningThresholds", + "memsafetySpecification", + "termination" + ] + }, "default": [ - "congruence", "singleThreaded", "specification", "mallocWrappers", "noRecursiveIntervals", "enums", "loopUnrollHeuristic", "arrayDomain", "octagon", "wideningThresholds", "memsafetySpecification" + "congruence", + "singleThreaded", + "specification", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "loopUnrollHeuristic", + "arrayDomain", + "octagon", + "wideningThresholds", + "memsafetySpecification", + "termination" ] } }, From 3af192da0600613de1f789e827d98b87d13c41ef Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 20 Nov 2023 13:10:40 +0200 Subject: [PATCH 113/517] Deactivate mhp and region for single-threaded programs --- src/autoTune.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/autoTune.ml b/src/autoTune.ml index 346e9d7b6f..d9a866ffc2 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -184,7 +184,7 @@ let enableAnalyses anas = (*escape is also still enabled, because otherwise we get a warning*) (*does not consider dynamic calls!*) -let notNeccessaryThreadAnalyses = ["race"; "deadlock"; "maylocks"; "symb_locks"; "thread"; "threadid"; "threadJoins"; "threadreturn"] +let notNeccessaryThreadAnalyses = ["race"; "deadlock"; "maylocks"; "symb_locks"; "thread"; "threadid"; "threadJoins"; "threadreturn"; "mhp"; "region"] let reduceThreadAnalyses () = let isThreadCreate = function | LibraryDesc.ThreadCreate _ -> true From 0ee71a02f9fe08381c94eb6704bbc42055a778fa Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 20 Nov 2023 13:48:28 +0200 Subject: [PATCH 114/517] Update SV-COMP releasing guide for 2024 --- docs/developer-guide/releasing.md | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/docs/developer-guide/releasing.md b/docs/developer-guide/releasing.md index 69ffcb2461..fc5f5f68a1 100644 --- a/docs/developer-guide/releasing.md +++ b/docs/developer-guide/releasing.md @@ -97,16 +97,17 @@ This ensures that the environment and the archive have all the correct system libraries. -6. Commit and push the archive to an SV-COMP archives repository branch (but don't open a MR yet): (SV-COMP 2023). -7. Check pushed archive via CoveriTeam-Remote: . +6. Create (or add new version) Zenodo artifact and upload the archive. - 1. Clone coveriteam repository. - 2. Locally modify `actors/goblint.yml` archive location to the raw URL of the pushed archive. - 3. Run Goblint on some sv-benchmarks and properties via CoveriTeam. +7. Open MR with Zenodo version DOI to the [fm-tools](https://gitlab.com/sosy-lab/benchmarking/fm-tools) repository. - This ensures that Goblint runs on SoSy-Lab servers. + ### After all preruns From e19f87e8c0647ebc84db6de4494d07c4817ab4c1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 21 Nov 2023 10:16:58 +0200 Subject: [PATCH 115/517] 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 8b7994869c98119e50e8d19f857baccad7194628 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 21 Nov 2023 11:21:46 +0200 Subject: [PATCH 116/517] Fix invariant_set elements schema in YAML witnesses --- src/witness/yamlWitnessType.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/witness/yamlWitnessType.ml b/src/witness/yamlWitnessType.ml index f9bcf3235f..de9fa151d8 100644 --- a/src/witness/yamlWitnessType.ml +++ b/src/witness/yamlWitnessType.ml @@ -311,13 +311,16 @@ struct } let to_yaml {invariant_type} = - `O ([ - ("type", `String (InvariantType.invariant_type invariant_type)); - ] @ InvariantType.to_yaml' invariant_type) + `O [ + ("invariant", `O ([ + ("type", `String (InvariantType.invariant_type invariant_type)); + ] @ InvariantType.to_yaml' invariant_type) + ) + ] let of_yaml y = let open GobYaml in - let+ invariant_type = y |> InvariantType.of_yaml in + let+ invariant_type = y |> find "invariant" >>= InvariantType.of_yaml in {invariant_type} end From ca61360dd19e18bba2ddeba89c3f4046cf4764ad Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 21 Nov 2023 10:21:49 +0100 Subject: [PATCH 117/517] Add example where better privatization helps --- ...alid-memcleanup-multi-threaded-betterpiv.c | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c diff --git a/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c new file mode 100644 index 0000000000..c701461cb5 --- /dev/null +++ b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c @@ -0,0 +1,33 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.base.privatization mutex-meet-tid --set ana.path_sens[+] threadflag +#include +#include + +int *g; +int *m1; +int *m2; + +void *f1(void *arg) { + m1 = malloc(sizeof(int)); + // Thread t1 leaks m1 here + pthread_exit(NULL); //WARN +} + +void *f2(void *arg) { + m2 = malloc(sizeof(int)); + free(m2); // No leak for thread t2, since it calls free before exiting + pthread_exit(NULL); //NOWARN +} + +int main(int argc, char const *argv[]) { + g = malloc(sizeof(int)); + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + free(g); + + // main thread is not leaking anything + return 0; //NOWARN +} From 2cc915fe1757fcd032d17b8c017f052729430d21 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 21 Nov 2023 17:16:47 +0100 Subject: [PATCH 118/517] Check at end of main thread that the program is certainly single-threaded. If other threads are not joined, they may be killed by the main thread returning. This will possibly leak memory. --- src/analyses/memLeak.ml | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 8d83bcee83..4d37992a21 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -22,10 +22,16 @@ struct let context _ d = d + let must_be_single_threaded ~since_start ctx = + ctx.ask (Queries.MustBeSingleThreaded { since_start }) + + let was_malloc_called ctx = + ctx.global () + (* HELPER FUNCTIONS *) let warn_for_multi_threaded_due_to_abort ctx = - let malloc_called = ctx.global () in - if not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true })) && malloc_called then ( + let malloc_called = was_malloc_called ctx in + if not (must_be_single_threaded ctx ~since_start:true) && malloc_called then ( set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program aborted while running in multi-threaded mode. A memory leak might occur" @@ -56,11 +62,18 @@ struct let return ctx (exp:exp option) (f:fundec) : D.t = (* Check for a valid-memcleanup and memtrack violation in a multi-threaded setting *) (* The check for multi-threadedness is to ensure that valid-memtrack and valid-memclenaup are treated separately for single-threaded programs *) - if (ctx.ask (Queries.MayBeThreadReturn) && not (ctx.ask (Queries.MustBeSingleThreaded { since_start = true }))) then ( - warn_for_thread_return_or_exit ctx true + if (ctx.ask (Queries.MayBeThreadReturn) && not (must_be_single_threaded ctx ~since_start:true)) then ( + warn_for_thread_return_or_exit ctx true ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) - if f.svar.vname = "main" then check_for_mem_leak ctx; + if f.svar.vname = "main" then ( + check_for_mem_leak ctx; + if not (must_be_single_threaded ctx ~since_start:false) && was_malloc_called ctx then begin + set_mem_safety_flag InvalidMemTrack; + set_mem_safety_flag InvalidMemcleanup; + M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Possible memory leak: Memory was allocated in a multithreaded program, but not all threads are joined." + end + ); ctx.local let special ctx (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = From 45ec8a663791d3675ca05ac68355ce1b1ea2c8c1 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 21 Nov 2023 17:18:30 +0100 Subject: [PATCH 119/517] Add test case for memory leaking from a thead that is not joined, add thread_joins to other test cases. --- .../08-invalid-memcleanup-multi-threaded.c | 6 +++++- ...9-invalid-memcleanup-multi-threaded-abort.c | 7 +++++-- ...valid-memcleanup-multi-threaded-betterpiv.c | 5 ++++- .../76-memleak/15-mem-leak-not-joined-thread.c | 18 ++++++++++++++++++ 4 files changed, 32 insertions(+), 4 deletions(-) create mode 100644 tests/regression/76-memleak/15-mem-leak-not-joined-thread.c diff --git a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c index 513a36db95..65e6e4e766 100644 --- a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c +++ b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid #include #include @@ -7,6 +7,7 @@ int *m1; void *f1(void *arg) { m1 = malloc(sizeof(int)); + free(m1); // Thread t1 leaks m1 here pthread_exit(NULL); //WARN } @@ -28,6 +29,9 @@ int main(int argc, char const *argv[]) { free(g); + pthread_join(t1, NULL); + pthread_join(t2, NULL); + // main thread is not leaking anything return 0; //NOWARN } diff --git a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c index 977510b9bb..b991433f4d 100644 --- a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c +++ b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid #include #include @@ -25,9 +25,12 @@ int main(int argc, char const *argv[]) { pthread_t t2; pthread_create(&t2, NULL, f2, NULL); - + free(g); + pthread_join(t1, NULL); + pthread_join(t2, NULL); + // main thread is not leaking anything return 0; //NOWARN } diff --git a/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c index c701461cb5..7ad9194d6e 100644 --- a/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c +++ b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.base.privatization mutex-meet-tid --set ana.path_sens[+] threadflag +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.base.privatization mutex-meet-tid --set ana.path_sens[+] threadflag --set ana.activated[+] thread --set ana.activated[+] threadid #include #include @@ -28,6 +28,9 @@ int main(int argc, char const *argv[]) { free(g); + pthread_join(t1, NULL); + pthread_join(t2, NULL); + // main thread is not leaking anything return 0; //NOWARN } diff --git a/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c new file mode 100644 index 0000000000..c60809a9f4 --- /dev/null +++ b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c @@ -0,0 +1,18 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid +#include +#include + +int *m1; + +void *f1(void *arg) { + m1 = malloc(sizeof(int)); + while (1); +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + // memory from thread f1 which was not joined into main, is not freed + return 0; //WARN +} \ No newline at end of file From 56c4d620be0c7e3a3d2deb92197d3d161a850445 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 21 Nov 2023 17:40:44 +0100 Subject: [PATCH 120/517] Add test case with pthread_exit called in main, remove threadid analysis from params as it is not needed. --- .../08-invalid-memcleanup-multi-threaded.c | 4 ++-- ...-invalid-memcleanup-multi-threaded-abort.c | 3 +-- ...alid-memcleanup-multi-threaded-betterpiv.c | 2 +- .../15-mem-leak-not-joined-thread.c | 2 +- .../16-no-mem-leak-thread-exit-main.c | 23 +++++++++++++++++++ 5 files changed, 28 insertions(+), 6 deletions(-) create mode 100644 tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c diff --git a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c index 65e6e4e766..89dc7a3416 100644 --- a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c +++ b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread #include #include @@ -26,7 +26,7 @@ int main(int argc, char const *argv[]) { pthread_t t2; pthread_create(&t2, NULL, f2, NULL); - + free(g); pthread_join(t1, NULL); diff --git a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c index b991433f4d..eaba1e91b5 100644 --- a/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c +++ b/tests/regression/76-memleak/09-invalid-memcleanup-multi-threaded-abort.c @@ -1,5 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid -#include +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread #include int *g; diff --git a/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c index 7ad9194d6e..9f636ab587 100644 --- a/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c +++ b/tests/regression/76-memleak/14-invalid-memcleanup-multi-threaded-betterpiv.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.base.privatization mutex-meet-tid --set ana.path_sens[+] threadflag --set ana.activated[+] thread --set ana.activated[+] threadid +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.base.privatization mutex-meet-tid --set ana.path_sens[+] threadflag --set ana.activated[+] thread #include #include diff --git a/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c index c60809a9f4..21c1992fc3 100644 --- a/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c +++ b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c @@ -1,4 +1,4 @@ -//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread --set ana.activated[+] threadid +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread #include #include diff --git a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c new file mode 100644 index 0000000000..5fb89113d2 --- /dev/null +++ b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c @@ -0,0 +1,23 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread +#include +#include + +int *m1; + +void *f1(void *arg) { + m1 = malloc(sizeof(int)); + while (1); +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + + pthread_exit(NULL); + + pthread_join(t1, NULL); + + // A pthread_join called in main will wait for other threads to finish + // Therefore, no memory leak here + return 0; // NOWARN +} \ No newline at end of file From 2fef812ff9a11bebb6ac4b78ca010fde6bbfeea9 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 21 Nov 2023 17:57:07 +0100 Subject: [PATCH 121/517] Add testcases for thread return and pthread_exit in thread different from main. --- .../15-mem-leak-not-joined-thread.c | 1 + .../16-no-mem-leak-thread-exit-main.c | 3 +-- .../76-memleak/17-mem-leak-thread-return.c | 26 ++++++++++++++++++ .../76-memleak/18-mem-leak-thread-exit.c | 27 +++++++++++++++++++ 4 files changed, 55 insertions(+), 2 deletions(-) create mode 100644 tests/regression/76-memleak/17-mem-leak-thread-return.c create mode 100644 tests/regression/76-memleak/18-mem-leak-thread-exit.c diff --git a/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c index 21c1992fc3..15f249ffe1 100644 --- a/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c +++ b/tests/regression/76-memleak/15-mem-leak-not-joined-thread.c @@ -7,6 +7,7 @@ int *m1; void *f1(void *arg) { m1 = malloc(sizeof(int)); while (1); + return NULL; } int main(int argc, char const *argv[]) { diff --git a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c index 5fb89113d2..663ea26663 100644 --- a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c +++ b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c @@ -7,6 +7,7 @@ int *m1; void *f1(void *arg) { m1 = malloc(sizeof(int)); while (1); + return NULL; } int main(int argc, char const *argv[]) { @@ -15,8 +16,6 @@ int main(int argc, char const *argv[]) { pthread_exit(NULL); - pthread_join(t1, NULL); - // A pthread_join called in main will wait for other threads to finish // Therefore, no memory leak here return 0; // NOWARN diff --git a/tests/regression/76-memleak/17-mem-leak-thread-return.c b/tests/regression/76-memleak/17-mem-leak-thread-return.c new file mode 100644 index 0000000000..bec64ca22f --- /dev/null +++ b/tests/regression/76-memleak/17-mem-leak-thread-return.c @@ -0,0 +1,26 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread +#include +#include + +int *m1; + +void *f2(void *arg) { + m1 = malloc(sizeof(int)); + while (1); + return NULL; +} + +void *f1(void *arg) { + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + return NULL; +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + pthread_join(t1, NULL); + + return 0; // WARN +} \ No newline at end of file diff --git a/tests/regression/76-memleak/18-mem-leak-thread-exit.c b/tests/regression/76-memleak/18-mem-leak-thread-exit.c new file mode 100644 index 0000000000..e98ae3f346 --- /dev/null +++ b/tests/regression/76-memleak/18-mem-leak-thread-exit.c @@ -0,0 +1,27 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread +#include +#include + +int *m1; + +void *f2(void *arg) { + m1 = malloc(sizeof(int)); + while (1); + return NULL; +} + +void *f1(void *arg) { + pthread_t t2; + pthread_create(&t2, NULL, f2, NULL); + + pthread_exit(NULL); + return NULL; +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + pthread_join(t1, NULL); + + return 0; // WARN +} \ No newline at end of file From 3485100b77209734c346fc063a7f3fdff59cf8e8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 21 Nov 2023 20:11:49 +0200 Subject: [PATCH 122/517] Add test for special function lval --- tests/regression/00-sanity/51-base-special-lval.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 tests/regression/00-sanity/51-base-special-lval.c diff --git a/tests/regression/00-sanity/51-base-special-lval.c b/tests/regression/00-sanity/51-base-special-lval.c new file mode 100644 index 0000000000..8f74a1babe --- /dev/null +++ b/tests/regression/00-sanity/51-base-special-lval.c @@ -0,0 +1,13 @@ +// Making sure special function lval is not invalidated recursively +#include + +extern int * anIntPlease(); +int main() { + int x = 0; + int *p = &x; + p = anIntPlease(); + + __goblint_check(x == 0); + + return 0; +} From 60923ea18f414a2d609497f2f1f03b136d9bb3d0 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 21 Nov 2023 20:15:31 +0200 Subject: [PATCH 123/517] Special function lval not invalidated recursively --- src/analyses/base.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 84be8c7a19..8b6350aa2d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2123,7 +2123,7 @@ struct let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s\n" d_plainlval lv f.vname; - invalidate ~ctx (Analyses.ask_of_ctx ctx) ctx.global st [Cil.mkAddrOrStartOf lv] + invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = @@ -2328,7 +2328,7 @@ struct | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in - let apply_abs ik x = +let apply_abs ik x = let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Int int_x -> From 895bd9fe468a064016f5c130f9f38174f4949369 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 21 Nov 2023 20:35:29 +0200 Subject: [PATCH 124/517] Update cram tests --- tests/regression/04-mutex/49-type-invariants.t | 4 ---- 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 ---- tests/regression/04-mutex/92-distribute-fields-type-deep.t | 4 ---- tests/regression/04-mutex/93-distribute-fields-type-global.t | 2 -- 8 files changed, 30 deletions(-) diff --git a/tests/regression/04-mutex/49-type-invariants.t b/tests/regression/04-mutex/49-type-invariants.t index 4c105d1559..4b8118eec1 100644 --- a/tests/regression/04-mutex/49-type-invariants.t +++ b/tests/regression/04-mutex/49-type-invariants.t @@ -14,8 +14,6 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (49-type-invariants.c:21:3-21:21) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (49-type-invariants.c:21:3-21:21) [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) @@ -39,8 +37,6 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (49-type-invariants.c:21:3-21:21) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (49-type-invariants.c:21:3-21:21) [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) diff --git a/tests/regression/04-mutex/77-type-nested-fields.t b/tests/regression/04-mutex/77-type-nested-fields.t index bb935cb0ed..68d9cdb779 100644 --- a/tests/regression/04-mutex/77-type-nested-fields.t +++ b/tests/regression/04-mutex/77-type-nested-fields.t @@ -15,11 +15,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (77-type-nested-fields.c:31:3-31:20) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (77-type-nested-fields.c:31:3-31:20) [Info][Unsound] Write to unknown address: privatization is unsound. (77-type-nested-fields.c:31:3-31:20) - [Info][Unsound] Unknown address in {&tmp} has escaped. (77-type-nested-fields.c:38:3-38:22) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (77-type-nested-fields.c:38:3-38:22) [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) 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 ba1399d225..85f7bfb709 100644 --- a/tests/regression/04-mutex/79-type-nested-fields-deep1.t +++ b/tests/regression/04-mutex/79-type-nested-fields-deep1.t @@ -15,11 +15,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (79-type-nested-fields-deep1.c:36:3-36:20) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (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:36:3-36:20) - [Info][Unsound] Unknown address in {&tmp} has escaped. (79-type-nested-fields-deep1.c:43:3-43:24) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (79-type-nested-fields-deep1.c:43:3-43:24) [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) 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 71bdcfb2e2..a2e9e2ab15 100644 --- a/tests/regression/04-mutex/80-type-nested-fields-deep2.t +++ b/tests/regression/04-mutex/80-type-nested-fields-deep2.t @@ -15,11 +15,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (80-type-nested-fields-deep2.c:36:3-36:22) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (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:36:3-36:22) - [Info][Unsound] Unknown address in {&tmp} has escaped. (80-type-nested-fields-deep2.c:43:3-43:24) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (80-type-nested-fields-deep2.c:43:3-43:24) [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) 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 46435045b9..a3b5faf083 100644 --- a/tests/regression/04-mutex/90-distribute-fields-type-1.t +++ b/tests/regression/04-mutex/90-distribute-fields-type-1.t @@ -17,11 +17,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (90-distribute-fields-type-1.c:31:3-31:20) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (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:31:3-31:20) - [Info][Unsound] Unknown address in {&tmp} has escaped. (90-distribute-fields-type-1.c:39:3-39:17) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (90-distribute-fields-type-1.c:39:3-39:17) [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) 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 c7e66c0527..5773245114 100644 --- a/tests/regression/04-mutex/91-distribute-fields-type-2.t +++ b/tests/regression/04-mutex/91-distribute-fields-type-2.t @@ -17,11 +17,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (91-distribute-fields-type-2.c:32:3-32:17) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (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:32:3-32:17) - [Info][Unsound] Unknown address in {&tmp} has escaped. (91-distribute-fields-type-2.c:40:3-40:17) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (91-distribute-fields-type-2.c:40:3-40: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) 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 4fc1c7e101..798374d63c 100644 --- a/tests/regression/04-mutex/92-distribute-fields-type-deep.t +++ b/tests/regression/04-mutex/92-distribute-fields-type-deep.t @@ -17,11 +17,7 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (92-distribute-fields-type-deep.c:36:3-36:20) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (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:36:3-36:20) - [Info][Unsound] Unknown address in {&tmp} has escaped. (92-distribute-fields-type-deep.c:44:3-44:17) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (92-distribute-fields-type-deep.c:44:3-44:17) [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) 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 bf34d99936..07999854ff 100644 --- a/tests/regression/04-mutex/93-distribute-fields-type-global.t +++ b/tests/regression/04-mutex/93-distribute-fields-type-global.t @@ -16,8 +16,6 @@ live: 7 dead: 0 total lines: 7 - [Info][Unsound] Unknown address in {&tmp} has escaped. (93-distribute-fields-type-global.c:13:3-13:29) - [Info][Unsound] Unknown value in {?} could be an escaped pointer address! (93-distribute-fields-type-global.c:13:3-13:29) [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) From 645b03cfa678acbf3fdc585d4ee0a7d71e8b9688 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Tue, 21 Nov 2023 20:31:00 +0100 Subject: [PATCH 125/517] ThreadAnalysis: Handle pthread_exit like return from thread. --- src/analyses/threadAnalysis.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/analyses/threadAnalysis.ml b/src/analyses/threadAnalysis.ml index 0264f4b700..d9140dbb37 100644 --- a/src/analyses/threadAnalysis.ml +++ b/src/analyses/threadAnalysis.ml @@ -22,7 +22,7 @@ struct module P = IdentityP (D) (* transfer functions *) - let return ctx (exp:exp option) (f:fundec) : D.t = + let return ctx (exp:exp option) _ : D.t = let tid = ThreadId.get_current (Analyses.ask_of_ctx ctx) in begin match tid with | `Lifted tid -> ctx.sideg tid (false, TS.bot (), not (D.is_empty ctx.local)) @@ -64,6 +64,8 @@ struct | [t] -> join_thread ctx.local t (* single thread *) | _ -> ctx.local (* if several possible threads are may-joined, none are must-joined *) | exception SetDomain.Unsupported _ -> ctx.local) + | ThreadExit { ret_val } -> + return ctx (Some ret_val) () | _ -> ctx.local let query ctx (type a) (q: a Queries.t): a Queries.result = From 9153eb3becd5904b99aa8250e50b2cd22f74a128 Mon Sep 17 00:00:00 2001 From: Stanimir Bozhilov Date: Tue, 21 Nov 2023 21:04:04 +0100 Subject: [PATCH 126/517] Use `AD.fold` instead of `List.fold_left` --- src/analyses/memLeak.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 3079faae1f..f26157fdd0 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -117,12 +117,14 @@ struct match ValueDomain.Structs.get s field with | Queries.VD.Address a -> let reachable_from_addr_set = - List.fold_left (fun acc_addr addr -> + Queries.AD.fold (fun addr acc_addr -> match addr with - | Queries.AD.Addr.Addr (v, _) -> (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) @ acc_addr + | Queries.AD.Addr.Addr (v, _) -> + let reachable_from_v = Queries.AD.of_list (List.map (fun v -> Queries.AD.Addr.Addr (v, `NoOffset)) (get_reachable_mem_from_str_ptr_globals [v] ctx)) in + Queries.AD.join (Queries.AD.add addr reachable_from_v) acc_addr | _ -> acc_addr - ) [] (Queries.AD.elements a) - in reachable_from_addr_set @ acc_field + ) a (Queries.AD.empty ()) + in (Queries.AD.to_var_may reachable_from_addr_set) @ acc_field | _ -> acc_field ) [] fields in From 17ebe80cb217b8d6837f7b892fb75a3e11f0e3b0 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 09:29:30 +0100 Subject: [PATCH 127/517] 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 cb06f70f99b5c149e4afcb1ba6dcae53beb80cd2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 22 Nov 2023 11:31:03 +0200 Subject: [PATCH 128/517] Fix indentation --- 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 8b6350aa2d..98badad489 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2328,7 +2328,7 @@ struct | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in -let apply_abs ik x = + let apply_abs ik x = let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Int int_x -> From c6cb63e48a665e566531213bbc02b4a568f2bf79 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Wed, 22 Nov 2023 10:53:22 +0100 Subject: [PATCH 129/517] Update tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c Co-authored-by: Simmo Saan --- tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c index 663ea26663..77dd299896 100644 --- a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c +++ b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c @@ -16,7 +16,7 @@ int main(int argc, char const *argv[]) { pthread_exit(NULL); - // A pthread_join called in main will wait for other threads to finish + // A pthread_exit called in main will wait for other threads to finish // Therefore, no memory leak here return 0; // NOWARN } \ No newline at end of file From f12a39216068c87cc0785f1ed13f9573b8f2c08e Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Wed, 22 Nov 2023 11:02:01 +0100 Subject: [PATCH 130/517] Remove call to free. --- .../regression/76-memleak/08-invalid-memcleanup-multi-threaded.c | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c index 89dc7a3416..038801f219 100644 --- a/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c +++ b/tests/regression/76-memleak/08-invalid-memcleanup-multi-threaded.c @@ -7,7 +7,6 @@ int *m1; void *f1(void *arg) { m1 = malloc(sizeof(int)); - free(m1); // Thread t1 leaks m1 here pthread_exit(NULL); //WARN } From be9171b2bf6a541358c702a4a62e31a79f3be676 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Wed, 22 Nov 2023 11:04:44 +0100 Subject: [PATCH 131/517] Add annotation of nowarn next to pthread_exit. --- .../regression/76-memleak/16-no-mem-leak-thread-exit-main.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c index 77dd299896..f7340d1d4f 100644 --- a/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c +++ b/tests/regression/76-memleak/16-no-mem-leak-thread-exit-main.c @@ -14,9 +14,9 @@ int main(int argc, char const *argv[]) { pthread_t t1; pthread_create(&t1, NULL, f1, NULL); - pthread_exit(NULL); - // A pthread_exit called in main will wait for other threads to finish // Therefore, no memory leak here - return 0; // NOWARN + pthread_exit(NULL); // NOWARN + + return 0; // NOWARN (unreachable) } \ No newline at end of file From 585a65decbf38ddfdc66ce3c544547b47877b274 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Wed, 22 Nov 2023 11:13:04 +0100 Subject: [PATCH 132/517] Check in TheadAnalysis.return whether the return is actually a threadreturn before side-effecting. --- src/analyses/threadAnalysis.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/analyses/threadAnalysis.ml b/src/analyses/threadAnalysis.ml index d9140dbb37..01c5dd87fa 100644 --- a/src/analyses/threadAnalysis.ml +++ b/src/analyses/threadAnalysis.ml @@ -22,12 +22,15 @@ struct module P = IdentityP (D) (* transfer functions *) - let return ctx (exp:exp option) _ : D.t = + let handle_thread_return ctx (exp: exp option) = let tid = ThreadId.get_current (Analyses.ask_of_ctx ctx) in - begin match tid with + match tid with | `Lifted tid -> ctx.sideg tid (false, TS.bot (), not (D.is_empty ctx.local)) | _ -> () - end; + + let return ctx (exp:exp option) _ : D.t = + if ctx.ask Queries.MayBeThreadReturn then + handle_thread_return ctx exp; ctx.local let rec is_not_unique ctx tid = @@ -65,7 +68,8 @@ struct | _ -> ctx.local (* if several possible threads are may-joined, none are must-joined *) | exception SetDomain.Unsupported _ -> ctx.local) | ThreadExit { ret_val } -> - return ctx (Some ret_val) () + handle_thread_return ctx (Some ret_val); + ctx.local | _ -> ctx.local let query ctx (type a) (q: a Queries.t): a Queries.result = From c5cda332088a48507f44b3c93733c13539189e04 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 11:22:10 +0100 Subject: [PATCH 133/517] 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 bc7694b68b599662a11cafc0c75c259cafa68a0d Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Wed, 22 Nov 2023 11:27:04 +0100 Subject: [PATCH 134/517] Add test case that checking that analysis distinguishes between thread returns and normal returns of a thread. --- .../76-memleak/19-no-mem-leak-return.c | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 tests/regression/76-memleak/19-no-mem-leak-return.c diff --git a/tests/regression/76-memleak/19-no-mem-leak-return.c b/tests/regression/76-memleak/19-no-mem-leak-return.c new file mode 100644 index 0000000000..70e0c66216 --- /dev/null +++ b/tests/regression/76-memleak/19-no-mem-leak-return.c @@ -0,0 +1,32 @@ +//PARAM: --set ana.malloc.unique_address_count 1 --set ana.activated[+] memLeak --set ana.activated[+] thread +#include +#include + + +void *f2(void *arg) { + int* m1 = malloc(sizeof(int)); + free(m1); + return NULL; +} + +// We check here that the analysis can distinguish between thread returns and normal returns + +void startf2(pthread_t* t){ + pthread_create(t, NULL, f2, NULL); + return; //NOWARN +} + +void *f1(void *arg) { + pthread_t t2; + startf2(&t2); + pthread_join(t2, NULL); + return NULL; // NOWARN +} + +int main(int argc, char const *argv[]) { + pthread_t t1; + pthread_create(&t1, NULL, f1, NULL); + pthread_join(t1, NULL); + + return 0; // NOWARN +} \ No newline at end of file From 666795faca6dd5a20e01c78daefde8efc7fbe1de Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 11:50:31 +0100 Subject: [PATCH 135/517] MemLeak: Do not consider unions --- src/analyses/memLeak.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index f26157fdd0..c7a044f8a6 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -27,8 +27,8 @@ struct get_global_vars () |> List.filter (fun v -> match unrollType v.vtype with - | TPtr (TComp _, _) - | TPtr ((TNamed ({ttype = TComp _; _}, _)), _) -> true + | TPtr (TComp (ci,_), _) + | TPtr ((TNamed ({ttype = TComp (ci, _); _}, _)), _) -> ci.cstruct | TComp (_, _) | (TNamed ({ttype = TComp _; _}, _)) -> false | _ -> false) @@ -37,8 +37,8 @@ struct get_global_vars () |> List.filter (fun v -> match unrollType v.vtype with - | TComp (_, _) - | (TNamed ({ttype = TComp _; _}, _)) -> true + | TComp (ci, _) + | (TNamed ({ttype = TComp (ci,_); _}, _)) -> ci.cstruct | _ -> false) let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = From 8ae117253f84b9b419d52a318af06dc7e4518475 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 11:53:08 +0100 Subject: [PATCH 136/517] 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 dd45d1960a6e72083cc2c62f4c857aa24756cb2b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Nov 2023 13:48:28 +0200 Subject: [PATCH 137/517] Add initial CHANGELOG for SV-COMP 2024 --- CHANGELOG.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 97cc399133..ab9bb8fef2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +## v2.3.0 (unreleased) +Functionally equivalent to Goblint in SV-COMP 2024. + +### SV-COMP 2024 +* Add termination analysis (#1093). +* Add OOB analysis (#1094, #1197). +* Add memory leak analysis (???, #1246, #1241). +* Improve multi-threaded use-after-free analysis (#1123, ). +* Support MemSafety in SV-COMP (#1201, #1199, #1262). +* YAML witnesses in SV-COMP mode (#1217, #1226, #1225, #1248). +* YAML witness version 2.0 (#1238, #1240). +* SV-COMP multi-property (#1220, #1228). +* Adapt autotuning (#912, #921, #987, #1214, #1234, #1168). +* Support `alloca` (#1179). +* Fix old thread analysis soundness (#1223, #1230). +* Add library functions (#1242, #1244, #1254, #1239). +* Fix some region escape unsoundness (#1247). + ## v2.2.1 * Bump batteries lower bound to 3.5.0. * Fix flaky dead code elimination transformation test. From bf754c06f343cbde55c4bee6a60524840fe34161 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Nov 2023 13:56:56 +0200 Subject: [PATCH 138/517] Add initial CHANGELOG for v2.3.0 --- CHANGELOG.md | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ab9bb8fef2..c32bf566d2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,19 +1,24 @@ ## v2.3.0 (unreleased) Functionally equivalent to Goblint in SV-COMP 2024. +* Refactor/fix race analysis (#1170, #1198). +* Add library function (#1167, #1174, #1220, #1203, #1205, #1212). +* Refactor/fix `MayPointTo` and `ReachableFrom` queries (#1142, #1176, #1144). +* Add final messages about unsound results (#1190, #1191). + ### SV-COMP 2024 * Add termination analysis (#1093). * Add OOB analysis (#1094, #1197). * Add memory leak analysis (???, #1246, #1241). * Improve multi-threaded use-after-free analysis (#1123, ). -* Support MemSafety in SV-COMP (#1201, #1199, #1262). +* Support MemSafety in SV-COMP (#1201, #1199, #1259, #1262). * YAML witnesses in SV-COMP mode (#1217, #1226, #1225, #1248). * YAML witness version 2.0 (#1238, #1240). * SV-COMP multi-property (#1220, #1228). * Adapt autotuning (#912, #921, #987, #1214, #1234, #1168). * Support `alloca` (#1179). * Fix old thread analysis soundness (#1223, #1230). -* Add library functions (#1242, #1244, #1254, #1239). +* Add library functions (#1242, #1244, #1254, #1239, #1269). * Fix some region escape unsoundness (#1247). ## v2.2.1 From 06f543a0139b12366591f792642167e0e5ca2285 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 22 Nov 2023 13:21:19 +0100 Subject: [PATCH 139/517] 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 9c650571f81b5c4d0b57a466b2adf935b90ddaa4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 22 Nov 2023 14:30:14 +0200 Subject: [PATCH 140/517] Add CHANGELOG for v2.3.0 --- CHANGELOG.md | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c32bf566d2..7300c09206 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,25 +1,14 @@ ## v2.3.0 (unreleased) Functionally equivalent to Goblint in SV-COMP 2024. -* Refactor/fix race analysis (#1170, #1198). -* Add library function (#1167, #1174, #1220, #1203, #1205, #1212). -* Refactor/fix `MayPointTo` and `ReachableFrom` queries (#1142, #1176, #1144). -* Add final messages about unsound results (#1190, #1191). - -### SV-COMP 2024 -* Add termination analysis (#1093). -* Add OOB analysis (#1094, #1197). -* Add memory leak analysis (???, #1246, #1241). -* Improve multi-threaded use-after-free analysis (#1123, ). -* Support MemSafety in SV-COMP (#1201, #1199, #1259, #1262). -* YAML witnesses in SV-COMP mode (#1217, #1226, #1225, #1248). -* YAML witness version 2.0 (#1238, #1240). -* SV-COMP multi-property (#1220, #1228). -* Adapt autotuning (#912, #921, #987, #1214, #1234, #1168). -* Support `alloca` (#1179). -* Fix old thread analysis soundness (#1223, #1230). -* Add library functions (#1242, #1244, #1254, #1239, #1269). -* Fix some region escape unsoundness (#1247). +* Add termination analysis for loops (#1093). +* Add memory out-of-bounds analysis (#1094, #1197). +* Add memory leak analysis (#1127, #1241, #1246). +* Add SV-COMP `termination`, `valid-memsafety` and `valid-memcleanup` properties support (#1220, #1228, #1201, #1199, #1259, #1262). +* Add YAML witness version 2.0 support (#1238, #1240, #1217, #1226, #1225, #1248). +* Add final warnings about unsound results (#1190, #1191). +* Add many library function specifications (#1167, #1174, #1203, #1205, #1212, #1220, #1239, #1242, #1244, #1254, #1269). +* Adapt automatic configuration tuning (#912, #921, #987, #1168, #1214, #1234). ## v2.2.1 * Bump batteries lower bound to 3.5.0. From f2623868f8f6fbcc9230c62389625f89a1e1c7d5 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Thu, 23 Nov 2023 14:06:46 +0100 Subject: [PATCH 141/517] Fix Not_found exception in autotuner with congruences and termination. --- src/autoTune.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/autoTune.ml b/src/autoTune.ml index fefdeb32fd..1fd1fa5ee6 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -99,7 +99,9 @@ let rec setCongruenceRecursive fd depth neigbourFunction = FunctionSet.iter (fun vinfo -> print_endline (" " ^ vinfo.vname); - setCongruenceRecursive (Cilfacade.find_varinfo_fundec vinfo) (depth -1) neigbourFunction + match (Cilfacade.find_varinfo_fundec vinfo) with + | fd -> setCongruenceRecursive fd (depth -1) neigbourFunction + | exception Not_found -> () (* Happens for __goblint_bounded*) ) (FunctionSet.filter (*for extern and builtin functions there is no function definition in CIL*) (fun x -> not (isExtern x.vstorage || BatString.starts_with x.vname "__builtin")) From 5be07e5e96c329ace898bcf973c5d7780bf44da8 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Thu, 23 Nov 2023 14:22:15 +0100 Subject: [PATCH 142/517] Remove unnecessary paranetheses. --- src/autoTune.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/autoTune.ml b/src/autoTune.ml index 1fd1fa5ee6..79f5f51a77 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -99,9 +99,9 @@ let rec setCongruenceRecursive fd depth neigbourFunction = FunctionSet.iter (fun vinfo -> print_endline (" " ^ vinfo.vname); - match (Cilfacade.find_varinfo_fundec vinfo) with + match Cilfacade.find_varinfo_fundec vinfo with | fd -> setCongruenceRecursive fd (depth -1) neigbourFunction - | exception Not_found -> () (* Happens for __goblint_bounded*) + | exception Not_found -> () (* Happens for __goblint_bounded *) ) (FunctionSet.filter (*for extern and builtin functions there is no function definition in CIL*) (fun x -> not (isExtern x.vstorage || BatString.starts_with x.vname "__builtin")) From 9b954b5cd0b14a146267bc80c476d6a81e281643 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Thu, 23 Nov 2023 15:00:25 +0100 Subject: [PATCH 143/517] Add example where autotuner crashed when trying to activate congruence domain when termination was enabled --- tests/regression/78-termination/51-modulo.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 tests/regression/78-termination/51-modulo.c diff --git a/tests/regression/78-termination/51-modulo.c b/tests/regression/78-termination/51-modulo.c new file mode 100644 index 0000000000..5f5b8f1924 --- /dev/null +++ b/tests/regression/78-termination/51-modulo.c @@ -0,0 +1,14 @@ +// SKIP TERM PARAM: --enable ana.autotune.enabled --enable ana.sv-comp.functions --enable ana.sv-comp.enabled --set ana.autotune.activated "['congruence']" --set ana.specification "CHECK( init(main()), LTL(F end) )" + +// This task previously crashed due to the autotuner +int main() { + int a; + int odd, count = 0; + while(a > 1) { + odd = a % 2; + if(!odd) a = a / 2; + else a = a - 1; + count++; + } + return count; +} From 9f3fcac6baee113bfba38e789085e4537988eb64 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 16:25:20 +0200 Subject: [PATCH 144/517] Add ORCiD-s to metadata --- .zenodo.json | 15 ++++++++++----- CITATION.cff | 4 ++++ 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/.zenodo.json b/.zenodo.json index 5557622f9e..22705c2d9c 100644 --- a/.zenodo.json +++ b/.zenodo.json @@ -10,15 +10,18 @@ }, { "name": "Schwarz, Michael", - "affiliation": "Technische Universität München" + "affiliation": "Technische Universität München", + "orcid": "0000-0002-9828-0308" }, { "name": "Erhard, Julian", - "affiliation": "Technische Universität München" + "affiliation": "Technische Universität München", + "orcid": "0000-0002-1729-3925" }, { "name": "Tilscher, Sarah", - "affiliation": "Technische Universität München" + "affiliation": "Technische Universität München", + "orcid": "0009-0009-9644-7475" }, { "name": "Vogler, Ralf", @@ -30,14 +33,16 @@ }, { "name": "Vojdani, Vesal", - "affiliation": "University of Tartu" + "affiliation": "University of Tartu", + "orcid": "0000-0003-4336-7980" } ], "contributors": [ { "name": "Seidl, Helmut", "type": "ProjectLeader", - "affiliation": "Technische Universität München" + "affiliation": "Technische Universität München", + "orcid": "0000-0002-2135-1593" }, { "name": "Schwarz, Martin D.", diff --git a/CITATION.cff b/CITATION.cff index 7a2dcf188d..25d46cf762 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -12,12 +12,15 @@ authors: # same authors as in .zenodo.json and dune-project - given-names: Michael family-names: Schwarz affiliation: "Technische Universität München" + orcid: "https://orcid.org/0000-0002-9828-0308" - given-names: Julian family-names: Erhard affiliation: "Technische Universität München" + orcid: "https://orcid.org/0000-0002-1729-3925" - given-names: Sarah family-names: Tilscher affiliation: "Technische Universität München" + orcid: "https://orcid.org/0009-0009-9644-7475" - given-names: Ralf family-names: Vogler affiliation: "Technische Universität München" @@ -27,6 +30,7 @@ authors: # same authors as in .zenodo.json and dune-project - given-names: Vesal family-names: Vojdani affiliation: "University of Tartu" + orcid: "https://orcid.org/0000-0003-4336-7980" license: MIT repository-code: "https://github.com/goblint/analyzer" From 356136fb5cd85d1af1b38799282f1f64724a2b7a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 16:26:13 +0200 Subject: [PATCH 145/517] Finalize CHANGELOG for v2.3.0 --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7300c09206..d285480259 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ -## v2.3.0 (unreleased) +## v2.3.0 Functionally equivalent to Goblint in SV-COMP 2024. * Add termination analysis for loops (#1093). From 07463bf738482fb0273e32af3c976671dad03325 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 16:31:09 +0200 Subject: [PATCH 146/517] Disable zenodo-validate in metadata CI --- .github/workflows/metadata.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/metadata.yml b/.github/workflows/metadata.yml index 6c7360f9e3..3a48d52fa0 100644 --- a/.github/workflows/metadata.yml +++ b/.github/workflows/metadata.yml @@ -27,6 +27,9 @@ jobs: args: --validate zenodo-validate: + # Zenodo schema URL is dead + if: ${{ false }} + strategy: matrix: node-version: From ade7968858f8d6ad04ba8d5f788557ace5ddf926 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 16:33:55 +0200 Subject: [PATCH 147/517] Replace goblint-cil pin with published 2.0.3 --- dune-project | 2 +- goblint.opam | 5 +++-- goblint.opam.locked | 6 +----- goblint.opam.template | 3 ++- gobview | 2 +- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/dune-project b/dune-project index 05c7d9418c..81c8d2f091 100644 --- a/dune-project +++ b/dune-project @@ -24,7 +24,7 @@ (synopsis "Static analysis framework for C") (depends (ocaml (>= 4.10)) - (goblint-cil (>= 2.0.2)) ; 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. + (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)) (zarith (>= 1.8)) (yojson (>= 2.0.0)) diff --git a/goblint.opam b/goblint.opam index 34912fde26..669b2d9c40 100644 --- a/goblint.opam +++ b/goblint.opam @@ -21,7 +21,7 @@ bug-reports: "https://github.com/goblint/analyzer/issues" depends: [ "dune" {>= "3.7"} "ocaml" {>= "4.10"} - "goblint-cil" {>= "2.0.2"} + "goblint-cil" {>= "2.0.3"} "batteries" {>= "3.5.0"} "zarith" {>= "1.8"} "yojson" {>= "2.0.0"} @@ -75,7 +75,8 @@ dev-repo: "git+https://github.com/goblint/analyzer.git" # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" pin-depends: [ - [ "goblint-cil.2.0.2" "git+https://github.com/goblint/cil.git#c7ffc37ad83216a84d90fdbf427cc02a68ea5331" ] + # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed + # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] ] diff --git a/goblint.opam.locked b/goblint.opam.locked index 6e15ac8900..02eac0bb75 100644 --- a/goblint.opam.locked +++ b/goblint.opam.locked @@ -59,7 +59,7 @@ depends: [ "fileutils" {= "0.6.4"} "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} - "goblint-cil" {= "2.0.2"} + "goblint-cil" {= "2.0.3"} "integers" {= "0.7.0"} "json-data-encoding" {= "0.12.1"} "jsonrpc" {= "1.15.0~5.0preview1"} @@ -130,10 +130,6 @@ post-messages: [ ] # TODO: manually reordered to avoid opam pin crash: https://github.com/ocaml/opam/issues/4936 pin-depends: [ - [ - "goblint-cil.2.0.2" - "git+https://github.com/goblint/cil.git#c7ffc37ad83216a84d90fdbf427cc02a68ea5331" - ] [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" diff --git a/goblint.opam.template b/goblint.opam.template index d8e25cde38..ca2796b3c7 100644 --- a/goblint.opam.template +++ b/goblint.opam.template @@ -2,7 +2,8 @@ # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" pin-depends: [ - [ "goblint-cil.2.0.2" "git+https://github.com/goblint/cil.git#c7ffc37ad83216a84d90fdbf427cc02a68ea5331" ] + # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed + # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] ] diff --git a/gobview b/gobview index b4467d820f..d4eb66b9eb 160000 --- a/gobview +++ b/gobview @@ -1 +1 @@ -Subproject commit b4467d820f28bac578fc0baf7f81393c67f6b82b +Subproject commit d4eb66b9eb277349a75141cb01899dbab9d3ef5d From dbd6479a53dbf76f351f853bbc9092d659a8a631 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 16:40:27 +0200 Subject: [PATCH 148/517] Disable pins for v2.3.0 release --- goblint.opam | 6 +++--- goblint.opam.locked | 7 ------- goblint.opam.template | 6 +++--- 3 files changed, 6 insertions(+), 13 deletions(-) diff --git a/goblint.opam b/goblint.opam index 669b2d9c40..842c03933f 100644 --- a/goblint.opam +++ b/goblint.opam @@ -74,12 +74,12 @@ dev-repo: "git+https://github.com/goblint/analyzer.git" # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" -pin-depends: [ +# pin-depends: [ # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) - [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] -] + # [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] +# ] post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] diff --git a/goblint.opam.locked b/goblint.opam.locked index 02eac0bb75..aba9f38bda 100644 --- a/goblint.opam.locked +++ b/goblint.opam.locked @@ -128,10 +128,3 @@ conflicts: [ post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] -# TODO: manually reordered to avoid opam pin crash: https://github.com/ocaml/opam/issues/4936 -pin-depends: [ - [ - "ppx_deriving.5.2.1" - "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" - ] -] diff --git a/goblint.opam.template b/goblint.opam.template index ca2796b3c7..95f90bcbd1 100644 --- a/goblint.opam.template +++ b/goblint.opam.template @@ -1,12 +1,12 @@ # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" -pin-depends: [ +# pin-depends: [ # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) - [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] -] + # [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] +# ] post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] From c1cced80063009ea5549da7927338f0c12216579 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 20:56:40 +0100 Subject: [PATCH 149/517] 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 150/517] 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 151/517] 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 152/517] 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 8c08a785a02b04d0af4a57f0c5cdce74780efb91 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 24 Nov 2023 23:23:26 +0200 Subject: [PATCH 153/517] Use opam 2.1 in releasing guide opam 2.1 with built-in depext is required to avoid qcheck version conflict with batteries. --- docs/developer-guide/releasing.md | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/docs/developer-guide/releasing.md b/docs/developer-guide/releasing.md index fc5f5f68a1..4f49399f13 100644 --- a/docs/developer-guide/releasing.md +++ b/docs/developer-guide/releasing.md @@ -37,13 +37,11 @@ 2. Extract distribution archive. 3. Run Docker container in extracted directory: `docker run -it --rm -v $(pwd):/goblint ocaml/opam:ubuntu-22.04-ocaml-4.14` (or newer). 4. Navigate to distribution archive inside Docker container: `cd /goblint`. - 5. Pin package from distribution archive: `opam pin add --no-action .`. - 6. Install depexts: `opam depext --with-test goblint`. - 7. Install and test package: `opam install --with-test goblint`. - 8. Activate opam environment: `eval $(opam env)`. - 9. Check version: `goblint --version`. - 10. Check that analysis works: `goblint -v tests/regression/04-mutex/01-simple_rc.c`. - 11. Exit Docker container. + 5. Install and test package from distribution archive: `opam-2.1 install --with-test .`. + 6. Activate opam environment: `eval $(opam env)`. + 7. Check version: `goblint --version`. + 8. Check that analysis works: `goblint -v tests/regression/04-mutex/01-simple_rc.c`. + 9. Exit Docker container. 12. Temporarily enable Zenodo GitHub webhook. From a50b1b86ec1aed6a37b1e6093efb00f5d271e796 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 24 Nov 2023 22:47:47 +0100 Subject: [PATCH 154/517] 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 155/517] 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 156/517] 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 157/517] 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 158/517] 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 159/517] 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 160/517] 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 161/517] 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 162/517] 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 163/517] 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 164/517] 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 165/517] 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 166/517] 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 167/517] 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 168/517] 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 169/517] 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 170/517] 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 171/517] 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 172/517] 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 173/517] 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 174/517] 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 175/517] 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 176/517] 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 177/517] 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 178/517] 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 179/517] 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 180/517] 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 181/517] 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 182/517] 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 183/517] 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 184/517] `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 185/517] 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 ed5f25947405096d5b1851084c230aa2ccf87cf6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 10:16:41 +0200 Subject: [PATCH 186/517] Revert "Disable pins for v2.3.0 release" This reverts commit dbd6479a53dbf76f351f853bbc9092d659a8a631. --- goblint.opam | 6 +++--- goblint.opam.locked | 7 +++++++ goblint.opam.template | 6 +++--- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/goblint.opam b/goblint.opam index 842c03933f..669b2d9c40 100644 --- a/goblint.opam +++ b/goblint.opam @@ -74,12 +74,12 @@ dev-repo: "git+https://github.com/goblint/analyzer.git" # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" -# pin-depends: [ +pin-depends: [ # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) - # [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] -# ] + [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] +] post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] diff --git a/goblint.opam.locked b/goblint.opam.locked index aba9f38bda..02eac0bb75 100644 --- a/goblint.opam.locked +++ b/goblint.opam.locked @@ -128,3 +128,10 @@ conflicts: [ post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] +# TODO: manually reordered to avoid opam pin crash: https://github.com/ocaml/opam/issues/4936 +pin-depends: [ + [ + "ppx_deriving.5.2.1" + "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" + ] +] diff --git a/goblint.opam.template b/goblint.opam.template index 95f90bcbd1..ca2796b3c7 100644 --- a/goblint.opam.template +++ b/goblint.opam.template @@ -1,12 +1,12 @@ # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-distribution != "alpine" & arch != "arm64" -# pin-depends: [ +pin-depends: [ # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed # [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#d2760bacfbfdb25a374254de44f2ff1cb5f42abd" ] # TODO: add back after release, only pinned for optimization (https://github.com/ocaml-ppx/ppx_deriving/pull/252) - # [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] -# ] + [ "ppx_deriving.5.2.1" "git+https://github.com/ocaml-ppx/ppx_deriving.git#0a89b619f94cbbfc3b0fb3255ab4fe5bc77d32d6" ] +] post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] From 6d4f9e78f219edbf81563ac0a37d6fa147fd4bab Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 10:20:36 +0200 Subject: [PATCH 187/517] Add opam pin revert step to releasing guide --- docs/developer-guide/releasing.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/developer-guide/releasing.md b/docs/developer-guide/releasing.md index 4f49399f13..fcf69ea533 100644 --- a/docs/developer-guide/releasing.md +++ b/docs/developer-guide/releasing.md @@ -57,6 +57,7 @@ 15. Create an opam package: `dune-release opam pkg`. 16. Submit the opam package to opam-repository: `dune-release opam submit`. +17. Revert temporary removal of opam pins. ## SV-COMP From 975b502b684c01d4f988ba62a20d4a64d7b52b36 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 10:27:36 +0200 Subject: [PATCH 188/517] Add few people to .mailmap --- .mailmap | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.mailmap b/.mailmap index 9153d55765..9aa2d0cc02 100644 --- a/.mailmap +++ b/.mailmap @@ -23,6 +23,7 @@ Kerem Çakırer Sarah Tilscher <66023521+stilscher@users.noreply.github.com> Karoliine Holter <44437975+karoliineh@users.noreply.github.com> + Elias Brandstetter <15275491+superbr4in@users.noreply.github.com> wherekonshade <80516286+Wherekonshade@users.noreply.github.com> @@ -37,3 +38,6 @@ Mireia Cano Pujol Felix Krayer Felix Krayer <91671586+FelixKrayer@users.noreply.github.com> Manuel Pietsch +Tim Ortel <100865202+TimOrtel@users.noreply.github.com> +Tomáš Dacík + <43824605+TDacik@users.noreply.github.com> From 0d5e145c66365d9f7196a17acddf7eceada00a0c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 10:42:44 +0200 Subject: [PATCH 189/517] Refactor StringDomain to use ResettableLazy --- src/cdomains/stringDomain.ml | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/cdomains/stringDomain.ml b/src/cdomains/stringDomain.ml index 978482a503..0621f37eb6 100644 --- a/src/cdomains/stringDomain.ml +++ b/src/cdomains/stringDomain.ml @@ -4,23 +4,20 @@ let name () = "string" type string_domain = Unit | Disjoint | Flat -let string_domain = ref None +let string_domain: string_domain ResettableLazy.t = + ResettableLazy.from_fun (fun () -> + match GobConfig.get_string "ana.base.strings.domain" with + | "unit" -> Unit + | "disjoint" -> Disjoint + | "flat" -> Flat + | _ -> failwith "ana.base.strings.domain: illegal value" + ) -let string_domain_config = "ana.base.strings.domain" - -let parse config = match config with - | "unit" -> Unit - | "disjoint" -> Disjoint - | "flat" -> Flat - | _ -> raise @@ GobConfig.ConfigError ("Invalid option for " ^ string_domain_config) - -let get_string_domain () = - if !string_domain = None then - string_domain := Some (parse (GobConfig.get_string string_domain_config)); - Option.get !string_domain +let get_string_domain () = ResettableLazy.force string_domain let reset_lazy () = - string_domain := None + ResettableLazy.reset string_domain + type t = string option [@@deriving eq, ord, hash] From 717b6a85cb99521936a1d7e3b5c952dcfafb43af Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:18:53 +0200 Subject: [PATCH 190/517] Add pthread_join_N to Klever library --- src/analyses/libraryFunctions.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index c9afb83617..b94f751568 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -1008,6 +1008,7 @@ let rtnl_lock = AddrOf (Cil.var (Cilfacade.create_var (makeGlobalVar "[rtnl_lock (** LDV Klever functions. *) let klever_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("pthread_create_N", special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [s]; __ "arg" []] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg }); (* TODO: add multiple flag to ThreadCreate *) + ("pthread_join_N", special [__ "thread" []; __ "retval" [w]] @@ fun thread retval -> ThreadJoin {thread; ret_var = retval}); ("ldv_mutex_model_lock", special [__ "lock" []; drop "sign" []] @@ fun lock -> Lock { lock; try_ = get_bool "sem.lock.fail"; write = true; return_on_success = true }); ("ldv_mutex_model_unlock", special [__ "lock" []; drop "sign" []] @@ fun lock -> Unlock lock); ("ldv_spin_model_lock", unknown [drop "sign" []]); From 670e7cfe1665a527ce1c124bad8494e30d452bd4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:23:06 +0200 Subject: [PATCH 191/517] Add test for Klever's multiple threads --- .../51-threadjoins/07-klever-multiple.c | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 tests/regression/51-threadjoins/07-klever-multiple.c diff --git a/tests/regression/51-threadjoins/07-klever-multiple.c b/tests/regression/51-threadjoins/07-klever-multiple.c new file mode 100644 index 0000000000..24b2c0b1ca --- /dev/null +++ b/tests/regression/51-threadjoins/07-klever-multiple.c @@ -0,0 +1,24 @@ +//PARAM: --set ana.activated[+] threadJoins --set lib.activated[+] klever +#include +#include + +int g = 0; + +void *t_fun(void *arg) { + g++; // RACE! + return NULL; +} + +int main() { + pthread_t id; + pthread_create_N(&id, NULL, t_fun, NULL); // spawns multiple threads + pthread_join(id, NULL); + + g++; // RACE! + + pthread_join_N(id, NULL); // TODO: should this join one (do nothing) or all (like assume join)? + + g++; // RACE! + + return 0; +} From 8a95c8a2d4fa776624da179a803c021058563577 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:29:07 +0200 Subject: [PATCH 192/517] Add multiple flag to ThreadCreate --- src/analyses/base.ml | 22 +++++++++++----------- src/analyses/libraryDesc.ml | 2 +- src/analyses/libraryFunctions.ml | 4 ++-- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index bdae887b4a..3630395282 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1953,8 +1953,8 @@ struct - let forkfun (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) (lv: lval option) (f: varinfo) (args: exp list) : (lval option * varinfo * exp list) list * bool = - let create_thread lval arg v = + let forkfun (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) (lv: lval option) (f: varinfo) (args: exp list) : (lval option * varinfo * exp list * bool) list = + let create_thread ~multiple lval arg v = try (* try to get function declaration *) let fd = Cilfacade.find_varinfo_fundec v in @@ -1963,7 +1963,7 @@ struct | Some x -> [x] | None -> List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - Some (lval, v, args) + Some (lval, v, args, multiple) with Not_found -> if LF.use_special f.vname then None (* we handle this function *) else if isFunctionType v.vtype then @@ -1973,7 +1973,7 @@ struct | Some x -> [x] | None -> List.map (fun x -> MyCFG.unknown_exp) (Cil.argsToList v_args) in - Some (lval, v, args) + Some (lval, v, args, multiple) else ( M.debug ~category:Analyzer "Not creating a thread from %s because its type is %a" v.vname d_type v.vtype; None @@ -1982,7 +1982,7 @@ struct let desc = LF.find f in match desc.special args, f.vname with (* handling thread creations *) - | ThreadCreate { thread = id; start_routine = start; arg = ptc_arg }, _ -> begin + | ThreadCreate { thread = id; start_routine = start; arg = ptc_arg; multiple }, _ -> begin (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) @@ -1994,7 +1994,7 @@ struct else start_funvars in - List.filter_map (create_thread (Some (Mem id, NoOffset)) (Some ptc_arg)) start_funvars_with_unknown, false + List.filter_map (create_thread ~multiple (Some (Mem id, NoOffset)) (Some ptc_arg)) start_funvars_with_unknown end | _, _ when get_bool "sem.unknown_function.spawn" -> (* TODO: Remove sem.unknown_function.spawn check because it is (and should be) really done in LibraryFunctions. @@ -2008,8 +2008,8 @@ struct let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; - List.filter_map (create_thread None None) addrs, true - | _, _ -> [], false + List.filter_map (create_thread ~multiple:true None None) addrs + | _, _ -> [] let assert_fn ctx e refine = (* make the state meet the assertion in the rest of the code *) @@ -2140,9 +2140,9 @@ struct let addr = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (addr, AD.type_of addr) in - let forks, multiple = forkfun ctx lv f args in - if M.tracing then if not (List.is_empty forks) then M.tracel "spawn" "Base.special %s: spawning functions %a\n" f.vname (d_list "," CilType.Varinfo.pretty) (List.map BatTuple.Tuple3.second forks); - List.iter (BatTuple.Tuple3.uncurry (ctx.spawn ~multiple)) forks; + let forks = forkfun ctx lv f args in + if M.tracing then if not (List.is_empty forks) then M.tracel "spawn" "Base.special %s: spawning functions %a\n" f.vname (d_list "," CilType.Varinfo.pretty) (List.map BatTuple.Tuple4.second forks); + List.iter (fun (lval, f, args, multiple) -> ctx.spawn ~multiple lval f args) forks; let st: store = ctx.local in let gs = ctx.global in let desc = LF.find f in diff --git a/src/analyses/libraryDesc.ml b/src/analyses/libraryDesc.ml index 4997b306a9..e426c32235 100644 --- a/src/analyses/libraryDesc.ml +++ b/src/analyses/libraryDesc.ml @@ -53,7 +53,7 @@ type special = | Assert of { exp: Cil.exp; check: bool; refine: bool; } | Lock of { lock: Cil.exp; try_: bool; write: bool; return_on_success: bool; } | Unlock of Cil.exp - | ThreadCreate of { thread: Cil.exp; start_routine: Cil.exp; arg: Cil.exp; } + | ThreadCreate of { thread: Cil.exp; start_routine: Cil.exp; arg: Cil.exp; multiple: bool } | ThreadJoin of { thread: Cil.exp; ret_var: Cil.exp; } | ThreadExit of { ret_val: Cil.exp; } | Signal of Cil.exp diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index b94f751568..ab0d04d3ec 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -422,7 +422,7 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ (** Pthread functions. *) let pthread_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ - ("pthread_create", special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [s]; __ "arg" []] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg }); (* For precision purposes arg is not considered accessed here. Instead all accesses (if any) come from actually analyzing start_routine. *) + ("pthread_create", special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [s]; __ "arg" []] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg; multiple = false }); (* For precision purposes arg is not considered accessed here. Instead all accesses (if any) come from actually analyzing start_routine. *) ("pthread_exit", special [__ "retval" []] @@ fun retval -> ThreadExit { ret_val = retval }); (* Doesn't dereference the void* itself, but just passes to pthread_join. *) ("pthread_join", special [__ "thread" []; __ "retval" [w]] @@ fun thread retval -> ThreadJoin {thread; ret_var = retval}); ("pthread_kill", unknown [drop "thread" []; drop "sig" []]); @@ -1007,7 +1007,7 @@ let rtnl_lock = AddrOf (Cil.var (Cilfacade.create_var (makeGlobalVar "[rtnl_lock (** LDV Klever functions. *) let klever_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ - ("pthread_create_N", special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [s]; __ "arg" []] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg }); (* TODO: add multiple flag to ThreadCreate *) + ("pthread_create_N", special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [s]; __ "arg" []] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg; multiple = true }); ("pthread_join_N", special [__ "thread" []; __ "retval" [w]] @@ fun thread retval -> ThreadJoin {thread; ret_var = retval}); ("ldv_mutex_model_lock", special [__ "lock" []; drop "sign" []] @@ fun lock -> Lock { lock; try_ = get_bool "sem.lock.fail"; write = true; return_on_success = true }); ("ldv_mutex_model_unlock", special [__ "lock" []; drop "sign" []] @@ fun lock -> Unlock lock); From 0e64a8f2abff122c78e5fbea2d3f338ee73db7fe Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 12:36:24 +0200 Subject: [PATCH 193/517] 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 194/517] 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 195/517] 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 196/517] 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 197/517] 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 198/517] 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 199/517] 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 5a6362e1c0bda3ad0feb3332bf64e95fcea810b8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 27 Nov 2023 14:32:47 +0200 Subject: [PATCH 200/517] Fix LibraryDslTest compilation --- unittest/analyses/libraryDslTest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unittest/analyses/libraryDslTest.ml b/unittest/analyses/libraryDslTest.ml index e1fa23281c..077b81b8fa 100644 --- a/unittest/analyses/libraryDslTest.ml +++ b/unittest/analyses/libraryDslTest.ml @@ -11,7 +11,7 @@ let pthread_mutex_lock_desc: LibraryDesc.t = LibraryDsl.( ) let pthread_create_desc: LibraryDesc.t = LibraryDsl.( - special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [r]; __ "arg" [r]] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg } + special [__ "thread" [w]; drop "attr" [r]; __ "start_routine" [r]; __ "arg" [r]] @@ fun thread start_routine arg -> ThreadCreate { thread; start_routine; arg; multiple = false } ) let realloc_desc: LibraryDesc.t = LibraryDsl.( From 209a5607204f960a0de6d6d7f81c754354306211 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 27 Nov 2023 15:18:49 +0100 Subject: [PATCH 201/517] 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 202/517] 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 203/517] 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 204/517] 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 205/517] 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 206/517] 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 207/517] 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 208/517] 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 209/517] 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 210/517] 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 211/517] 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 212/517] 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 213/517] 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 214/517] 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 215/517] 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 216/517] 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 217/517] 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 218/517] 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 219/517] 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 220/517] 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 221/517] 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 222/517] 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 223/517] 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 224/517] 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 225/517] 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 226/517] 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 227/517] 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 228/517] 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 229/517] 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 230/517] 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 231/517] 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 a3923237a01b4f6476911655e8b006b139337a8a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 30 Nov 2023 12:58:30 +0200 Subject: [PATCH 232/517] Generalize mutex-meet-tid privatization to arbitrary digest --- src/analyses/apron/relationPriv.apron.ml | 41 +++++++++--------- src/analyses/basePriv.ml | 39 +++++++++-------- src/analyses/commonPriv.ml | 54 ++++++++++++++++-------- 3 files changed, 79 insertions(+), 55 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index b386af162b..ad55c425cd 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -844,7 +844,7 @@ struct end (** Per-mutex meet with TIDs. *) -module PerMutexMeetPrivTID (Cluster: ClusterArg): S = functor (RD: RelationDomain.RD) -> +module PerMutexMeetPrivTID (Digest: Digest) (Cluster: ClusterArg): S = functor (RD: RelationDomain.RD) -> struct open CommonPerMutex(RD) include MutexGlobals @@ -854,10 +854,7 @@ struct module Cluster = NC module LRD = NC.LRD - include PerMutexTidCommon(struct - let exclude_not_started () = GobConfig.get_bool "ana.relation.priv.not-started" - let exclude_must_joined () = GobConfig.get_bool "ana.relation.priv.must-joined" - end)(LRD) + include PerMutexTidCommon (Digest) (LRD) module AV = RD.V module P = UnitP @@ -865,10 +862,9 @@ struct let name () = "PerMutexMeetPrivTID(" ^ (Cluster.name ()) ^ (if GobConfig.get_bool "ana.relation.priv.must-joined" then ",join" else "") ^ ")" let get_relevant_writes (ask:Q.ask) m v = - let current = ThreadId.get_current ask in - let must_joined = ask.f Queries.MustJoinedThreads in + let current = Digest.current ask in GMutex.fold (fun k v acc -> - if compatible ask current must_joined k then + if Digest.compatible ask current k then LRD.join acc (Cluster.keep_only_protected_globals ask m v) else acc @@ -946,8 +942,8 @@ struct (* unlock *) let rel_side = RD.keep_vars rel_local [g_var] in let rel_side = Cluster.unlock (W.singleton g) rel_side in - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid rel_side in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest rel_side in sideg (V.global g) (G.create_global sidev); let l' = L.add lm rel_side l in let rel_local' = @@ -984,8 +980,8 @@ struct else let rel_side = keep_only_protected_globals ask m rel in let rel_side = Cluster.unlock w rel_side in - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid rel_side in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest rel_side in sideg (V.mutex m) (G.create_mutex sidev); let lm = LLock.mutex m in let l' = L.add lm rel_side l in @@ -1069,8 +1065,8 @@ struct in let rel_side = RD.keep_vars rel g_vars in let rel_side = Cluster.unlock (W.top ()) rel_side in (* top W to avoid any filtering *) - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid rel_side in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest rel_side in sideg V.mutex_inits (G.create_mutex sidev); (* Introduction into local state not needed, will be read via initializer *) (* Also no side-effect to mutex globals needed, the value here will either by read via the initializer, *) @@ -1202,17 +1198,24 @@ end let priv_module: (module S) Lazy.t = lazy ( + let module TIDDigest = ThreadDigest ( + struct + let exclude_not_started () = GobConfig.get_bool "ana.relation.priv.not-started" + let exclude_must_joined () = GobConfig.get_bool "ana.relation.priv.must-joined" + end + ) + in let module Priv: S = (val match get_string "ana.relation.privatization" with | "top" -> (module Top : S) | "protection" -> (module ProtectionBasedPriv (struct let path_sensitive = false end)) | "protection-path" -> (module ProtectionBasedPriv (struct let path_sensitive = true end)) | "mutex-meet" -> (module PerMutexMeetPriv) - | "mutex-meet-tid" -> (module PerMutexMeetPrivTID (NoCluster)) - | "mutex-meet-tid-cluster12" -> (module PerMutexMeetPrivTID (DownwardClosedCluster (Clustering12))) - | "mutex-meet-tid-cluster2" -> (module PerMutexMeetPrivTID (ArbitraryCluster (Clustering2))) - | "mutex-meet-tid-cluster-max" -> (module PerMutexMeetPrivTID (ArbitraryCluster (ClusteringMax))) - | "mutex-meet-tid-cluster-power" -> (module PerMutexMeetPrivTID (DownwardClosedCluster (ClusteringPower))) + | "mutex-meet-tid" -> (module PerMutexMeetPrivTID (TIDDigest) (NoCluster)) + | "mutex-meet-tid-cluster12" -> (module PerMutexMeetPrivTID (TIDDigest) (DownwardClosedCluster (Clustering12))) + | "mutex-meet-tid-cluster2" -> (module PerMutexMeetPrivTID (TIDDigest) (ArbitraryCluster (Clustering2))) + | "mutex-meet-tid-cluster-max" -> (module PerMutexMeetPrivTID (TIDDigest) (ArbitraryCluster (ClusteringMax))) + | "mutex-meet-tid-cluster-power" -> (module PerMutexMeetPrivTID (TIDDigest) (DownwardClosedCluster (ClusteringPower))) | _ -> failwith "ana.relation.privatization: illegal value" ) in diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 3843dda300..0c67347d3f 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -391,14 +391,11 @@ struct st end -module PerMutexMeetTIDPriv: S = +module PerMutexMeetTIDPriv (Digest: Digest): S = struct open Queries.Protection include PerMutexMeetPrivBase - include PerMutexTidCommon(struct - let exclude_not_started () = GobConfig.get_bool "ana.base.priv.not-started" - let exclude_must_joined () = GobConfig.get_bool "ana.base.priv.must-joined" - end)(CPA) + include PerMutexTidCommon (Digest) (CPA) let iter_sys_vars getg vq vf = match vq with @@ -425,11 +422,10 @@ struct r let get_relevant_writes (ask:Q.ask) m v = - let current = ThreadId.get_current ask in - let must_joined = ask.f Queries.MustJoinedThreads in + let current = Digest.current ask in let is_in_Gm x _ = is_protected_by ~protection:Weak ask m x in GMutex.fold (fun k v acc -> - if compatible ask current must_joined k then + if Digest.compatible ask current k then CPA.join acc (CPA.filter is_in_Gm v) else acc @@ -474,8 +470,8 @@ struct CPA.add x v st.cpa in if M.tracing then M.tracel "priv" "WRITE GLOBAL SIDE %a = %a\n" CilType.Varinfo.pretty x VD.pretty v; - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid (CPA.singleton x v) in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest (CPA.singleton x v) in let l' = L.add lm (CPA.singleton x v) l in let is_recovered_st = ask.f (Queries.MustBeSingleThreaded {since_start = false}) && not @@ ask.f (Queries.MustBeSingleThreaded {since_start = true}) in let l' = if is_recovered_st then @@ -517,8 +513,8 @@ struct {st with cpa = cpa'; priv = (w',lmust,l)} else let is_in_Gm x _ = is_protected_by ~protection:Weak ask m x in - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid (CPA.filter is_in_Gm st.cpa) in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest (CPA.filter is_in_Gm st.cpa) in sideg (V.mutex m) (G.create_mutex sidev); let lm = LLock.mutex m in let l' = L.add lm (CPA.filter is_in_Gm st.cpa) l in @@ -568,13 +564,13 @@ struct let escape ask getg sideg (st: BaseComponents (D).t) escaped = let escaped_cpa = CPA.filter (fun x _ -> EscapeDomain.EscapedVars.mem x escaped) st.cpa in - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid escaped_cpa in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest escaped_cpa in sideg V.mutex_inits (G.create_mutex sidev); let cpa' = CPA.fold (fun x v acc -> if EscapeDomain.EscapedVars.mem x escaped (* && is_unprotected ask x *) then ( if M.tracing then M.tracel "priv" "ESCAPE SIDE %a = %a\n" CilType.Varinfo.pretty x VD.pretty v; - let sidev = GMutex.singleton tid (CPA.singleton x v) in + let sidev = GMutex.singleton digest (CPA.singleton x v) in sideg (V.global x) (G.create_global sidev); CPA.remove x acc ) @@ -587,8 +583,8 @@ struct let enter_multithreaded ask getg sideg (st: BaseComponents (D).t) = let cpa = st.cpa in let cpa_side = CPA.filter (fun x _ -> is_global ask x) cpa in - let tid = ThreadId.get_current ask in - let sidev = GMutex.singleton tid cpa_side in + let digest = Digest.current ask in + let sidev = GMutex.singleton digest cpa_side in sideg V.mutex_inits (G.create_mutex sidev); (* Introduction into local state not needed, will be read via initializer *) (* Also no side-effect to mutex globals needed, the value here will either by read via the initializer, *) @@ -1790,12 +1786,19 @@ end let priv_module: (module S) Lazy.t = lazy ( + let module TIDDigest = ThreadDigest ( + struct + let exclude_not_started () = GobConfig.get_bool "ana.relation.priv.not-started" + let exclude_must_joined () = GobConfig.get_bool "ana.relation.priv.must-joined" + end + ) + in let module Priv: S = (val match get_string "ana.base.privatization" with | "none" -> (module NonePriv: S) | "mutex-oplus" -> (module PerMutexOplusPriv) | "mutex-meet" -> (module PerMutexMeetPriv) - | "mutex-meet-tid" -> (module PerMutexMeetTIDPriv) + | "mutex-meet-tid" -> (module PerMutexMeetTIDPriv (TIDDigest)) | "protection" -> (module ProtectionBasedPriv (struct let check_read_unprotected = false end)) | "protection-read" -> (module ProtectionBasedPriv (struct let check_read_unprotected = true end)) | "mine" -> (module MinePriv) diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 88181000b9..3c8056bb34 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -154,12 +154,44 @@ struct end end +module type Digest = +sig + include Printable.S + + val current: Q.ask -> t + val compatible: Q.ask -> t -> t -> bool +end + module type PerMutexTidCommonArg = sig val exclude_not_started: unit -> bool val exclude_must_joined: unit -> bool end -module PerMutexTidCommon (Conf:PerMutexTidCommonArg) (LD:Lattice.S) = +module ThreadDigest (Conf: PerMutexTidCommonArg): Digest = +struct + include ThreadIdDomain.ThreadLifted + + module TID = ThreadIdDomain.Thread + + let current (ask: Q.ask) = + ThreadId.get_current ask + + let compatible (ask: Q.ask) (current: t) (other: t) = + let must_joined = ask.f Queries.MustJoinedThreads in + match current, other with + | `Lifted current, `Lifted other -> + if (TID.is_unique current) && (TID.equal current other) then + false (* self-read *) + else if Conf.exclude_not_started () && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then + false (* other is not started yet *) + else if Conf.exclude_must_joined () && MHP.must_be_joined other must_joined then + false (* accounted for in local information *) + else + true + | _ -> true +end + +module PerMutexTidCommon (Digest: Digest) (LD:Lattice.S) = struct include ConfCheck.RequireThreadFlagPathSensInit @@ -196,7 +228,7 @@ struct (* Map from locks to last written values thread-locally *) module L = MapDomain.MapBot_LiftTop (LLock) (LD) - module GMutex = MapDomain.MapBot_LiftTop (ThreadIdDomain.ThreadLifted) (LD) + module GMutex = MapDomain.MapBot_LiftTop (Digest) (LD) module GThread = Lattice.Prod (LMust) (L) module G = @@ -218,24 +250,10 @@ struct module D = Lattice.Prod3 (W) (LMust) (L) - let compatible (ask:Q.ask) current must_joined other = - match current, other with - | `Lifted current, `Lifted other -> - if (TID.is_unique current) && (TID.equal current other) then - false (* self-read *) - else if Conf.exclude_not_started () && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then - false (* other is not started yet *) - else if Conf.exclude_must_joined () && MHP.must_be_joined other must_joined then - false (* accounted for in local information *) - else - true - | _ -> true - let get_relevant_writes_nofilter (ask:Q.ask) v = - let current = ThreadId.get_current ask in - let must_joined = ask.f Queries.MustJoinedThreads in + let current = Digest.current ask in GMutex.fold (fun k v acc -> - if compatible ask current must_joined k then + if Digest.compatible ask current k then LD.join acc v else acc From 6dfc08ff3aa493a0808edd0ac19914fe8ecde375 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 30 Nov 2023 13:34:26 +0200 Subject: [PATCH 233/517] Simplify CommonPriv.ThreadDigest --- src/analyses/apron/relationPriv.apron.ml | 17 +++++------------ src/analyses/basePriv.ml | 9 +-------- src/analyses/commonPriv.ml | 11 +++-------- 3 files changed, 9 insertions(+), 28 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index ad55c425cd..a34e052602 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -1198,24 +1198,17 @@ end let priv_module: (module S) Lazy.t = lazy ( - let module TIDDigest = ThreadDigest ( - struct - let exclude_not_started () = GobConfig.get_bool "ana.relation.priv.not-started" - let exclude_must_joined () = GobConfig.get_bool "ana.relation.priv.must-joined" - end - ) - in let module Priv: S = (val match get_string "ana.relation.privatization" with | "top" -> (module Top : S) | "protection" -> (module ProtectionBasedPriv (struct let path_sensitive = false end)) | "protection-path" -> (module ProtectionBasedPriv (struct let path_sensitive = true end)) | "mutex-meet" -> (module PerMutexMeetPriv) - | "mutex-meet-tid" -> (module PerMutexMeetPrivTID (TIDDigest) (NoCluster)) - | "mutex-meet-tid-cluster12" -> (module PerMutexMeetPrivTID (TIDDigest) (DownwardClosedCluster (Clustering12))) - | "mutex-meet-tid-cluster2" -> (module PerMutexMeetPrivTID (TIDDigest) (ArbitraryCluster (Clustering2))) - | "mutex-meet-tid-cluster-max" -> (module PerMutexMeetPrivTID (TIDDigest) (ArbitraryCluster (ClusteringMax))) - | "mutex-meet-tid-cluster-power" -> (module PerMutexMeetPrivTID (TIDDigest) (DownwardClosedCluster (ClusteringPower))) + | "mutex-meet-tid" -> (module PerMutexMeetPrivTID (ThreadDigest) (NoCluster)) + | "mutex-meet-tid-cluster12" -> (module PerMutexMeetPrivTID (ThreadDigest) (DownwardClosedCluster (Clustering12))) + | "mutex-meet-tid-cluster2" -> (module PerMutexMeetPrivTID (ThreadDigest) (ArbitraryCluster (Clustering2))) + | "mutex-meet-tid-cluster-max" -> (module PerMutexMeetPrivTID (ThreadDigest) (ArbitraryCluster (ClusteringMax))) + | "mutex-meet-tid-cluster-power" -> (module PerMutexMeetPrivTID (ThreadDigest) (DownwardClosedCluster (ClusteringPower))) | _ -> failwith "ana.relation.privatization: illegal value" ) in diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 0c67347d3f..e600c2a05d 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -1786,19 +1786,12 @@ end let priv_module: (module S) Lazy.t = lazy ( - let module TIDDigest = ThreadDigest ( - struct - let exclude_not_started () = GobConfig.get_bool "ana.relation.priv.not-started" - let exclude_must_joined () = GobConfig.get_bool "ana.relation.priv.must-joined" - end - ) - in let module Priv: S = (val match get_string "ana.base.privatization" with | "none" -> (module NonePriv: S) | "mutex-oplus" -> (module PerMutexOplusPriv) | "mutex-meet" -> (module PerMutexMeetPriv) - | "mutex-meet-tid" -> (module PerMutexMeetTIDPriv (TIDDigest)) + | "mutex-meet-tid" -> (module PerMutexMeetTIDPriv (ThreadDigest)) | "protection" -> (module ProtectionBasedPriv (struct let check_read_unprotected = false end)) | "protection-read" -> (module ProtectionBasedPriv (struct let check_read_unprotected = true end)) | "mine" -> (module MinePriv) diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 3c8056bb34..23ed36f7fb 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -162,12 +162,7 @@ sig val compatible: Q.ask -> t -> t -> bool end -module type PerMutexTidCommonArg = sig - val exclude_not_started: unit -> bool - val exclude_must_joined: unit -> bool -end - -module ThreadDigest (Conf: PerMutexTidCommonArg): Digest = +module ThreadDigest: Digest = struct include ThreadIdDomain.ThreadLifted @@ -182,9 +177,9 @@ struct | `Lifted current, `Lifted other -> if (TID.is_unique current) && (TID.equal current other) then false (* self-read *) - else if Conf.exclude_not_started () && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then + else if GobConfig.get_bool "ana.relation.priv.not-started" && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then false (* other is not started yet *) - else if Conf.exclude_must_joined () && MHP.must_be_joined other must_joined then + else if GobConfig.get_bool "ana.relation.priv.must-joined" && MHP.must_be_joined other must_joined then false (* accounted for in local information *) else true From 05198f9640c3b39f8d7e2d661f76904c76f52d9a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 30 Nov 2023 13:35:36 +0200 Subject: [PATCH 234/517] Avoid MustJoinedThreads query in ThreadDigest if not needed --- src/analyses/commonPriv.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 23ed36f7fb..2e7ed570fd 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -172,14 +172,13 @@ struct ThreadId.get_current ask let compatible (ask: Q.ask) (current: t) (other: t) = - let must_joined = ask.f Queries.MustJoinedThreads in match current, other with | `Lifted current, `Lifted other -> - if (TID.is_unique current) && (TID.equal current other) then + if TID.is_unique current && TID.equal current other then false (* self-read *) else if GobConfig.get_bool "ana.relation.priv.not-started" && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then false (* other is not started yet *) - else if GobConfig.get_bool "ana.relation.priv.must-joined" && MHP.must_be_joined other must_joined then + else if GobConfig.get_bool "ana.relation.priv.must-joined" && MHP.must_be_joined other (ask.f Queries.MustJoinedThreads) then false (* accounted for in local information *) else true From 71489df7d186e4a3ad81c88c95adda5a1e55b99a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 1 Dec 2023 20:12:09 +0100 Subject: [PATCH 235/517] 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 236/517] 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 237/517] 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 238/517] 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 239/517] 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 240/517] 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 241/517] 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 242/517] 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 243/517] 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 244/517] `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 245/517] 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 246/517] 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 247/517] 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 248/517] 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 249/517] 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 250/517] 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 251/517] 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 252/517] 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 253/517] 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 bda139ff7d12e2b59b20b289d89c60fdeef37304 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 5 Dec 2023 17:09:32 +0200 Subject: [PATCH 254/517] Rename Digest.compatible -> accounted_for --- src/analyses/apron/relationPriv.apron.ml | 2 +- src/analyses/basePriv.ml | 2 +- src/analyses/commonPriv.ml | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index a34e052602..6c330e8798 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -864,7 +864,7 @@ struct let get_relevant_writes (ask:Q.ask) m v = let current = Digest.current ask in GMutex.fold (fun k v acc -> - if Digest.compatible ask current k then + if Digest.accounted_for ask ~current ~other:k then LRD.join acc (Cluster.keep_only_protected_globals ask m v) else acc diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index e600c2a05d..26fb5850a8 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -425,7 +425,7 @@ struct let current = Digest.current ask in let is_in_Gm x _ = is_protected_by ~protection:Weak ask m x in GMutex.fold (fun k v acc -> - if Digest.compatible ask current k then + if Digest.accounted_for ask ~current ~other:k then CPA.join acc (CPA.filter is_in_Gm v) else acc diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 2e7ed570fd..5f89eecdd8 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -159,7 +159,7 @@ sig include Printable.S val current: Q.ask -> t - val compatible: Q.ask -> t -> t -> bool + val accounted_for: Q.ask -> current:t -> other:t -> bool end module ThreadDigest: Digest = @@ -171,7 +171,7 @@ struct let current (ask: Q.ask) = ThreadId.get_current ask - let compatible (ask: Q.ask) (current: t) (other: t) = + let accounted_for (ask: Q.ask) ~(current: t) ~(other: t) = match current, other with | `Lifted current, `Lifted other -> if TID.is_unique current && TID.equal current other then @@ -247,7 +247,7 @@ struct let get_relevant_writes_nofilter (ask:Q.ask) v = let current = Digest.current ask in GMutex.fold (fun k v acc -> - if Digest.compatible ask current k then + if Digest.accounted_for ask ~current ~other:k then LD.join acc v else acc From 0704cd55cb41cdfb628f6ce96bc137515fd25149 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 5 Dec 2023 17:11:21 +0200 Subject: [PATCH 255/517] Flip Digest.accounted_for implementation to match name --- src/analyses/apron/relationPriv.apron.ml | 2 +- src/analyses/basePriv.ml | 2 +- src/analyses/commonPriv.ml | 12 ++++++------ 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index 6c330e8798..31dd1fc4f5 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -864,7 +864,7 @@ struct let get_relevant_writes (ask:Q.ask) m v = let current = Digest.current ask in GMutex.fold (fun k v acc -> - if Digest.accounted_for ask ~current ~other:k then + if not (Digest.accounted_for ask ~current ~other:k) then LRD.join acc (Cluster.keep_only_protected_globals ask m v) else acc diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 26fb5850a8..20ef13244b 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -425,7 +425,7 @@ struct let current = Digest.current ask in let is_in_Gm x _ = is_protected_by ~protection:Weak ask m x in GMutex.fold (fun k v acc -> - if Digest.accounted_for ask ~current ~other:k then + if not (Digest.accounted_for ask ~current ~other:k) then CPA.join acc (CPA.filter is_in_Gm v) else acc diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 5f89eecdd8..2739578957 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -175,14 +175,14 @@ struct match current, other with | `Lifted current, `Lifted other -> if TID.is_unique current && TID.equal current other then - false (* self-read *) + true (* self-read *) else if GobConfig.get_bool "ana.relation.priv.not-started" && MHP.definitely_not_started (current, ask.f Q.CreatedThreads) other then - false (* other is not started yet *) + true (* other is not started yet *) else if GobConfig.get_bool "ana.relation.priv.must-joined" && MHP.must_be_joined other (ask.f Queries.MustJoinedThreads) then - false (* accounted for in local information *) + true (* accounted for in local information *) else - true - | _ -> true + false + | _ -> false end module PerMutexTidCommon (Digest: Digest) (LD:Lattice.S) = @@ -247,7 +247,7 @@ struct let get_relevant_writes_nofilter (ask:Q.ask) v = let current = Digest.current ask in GMutex.fold (fun k v acc -> - if Digest.accounted_for ask ~current ~other:k then + if not (Digest.accounted_for ask ~current ~other:k) then LD.join acc v else acc From 02721c64ade754dc77e2032647994ba46fbb8050 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 6 Dec 2023 15:31:28 +0200 Subject: [PATCH 256/517] 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 257/517] 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 258/517] 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 259/517] 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 260/517] 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 261/517] 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 262/517] 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 263/517] 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 264/517] 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 265/517] 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 266/517] 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 267/517] 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 268/517] 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 269/517] 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 270/517] 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 271/517] 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 272/517] 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 273/517] 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 274/517] 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 275/517] 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 276/517] 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 277/517] 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 278/517] 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 279/517] 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 280/517] 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 281/517] 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 282/517] 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 283/517] 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 284/517] 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 285/517] 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 286/517] 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 287/517] 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 288/517] 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 289/517] 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 290/517] 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 291/517] 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 292/517] 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 293/517] 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 294/517] 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 295/517] 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 296/517] 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 297/517] 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 298/517] 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 299/517] 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 300/517] 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 301/517] 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 302/517] 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 303/517] 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 304/517] 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 305/517] 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 306/517] 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 307/517] 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 308/517] 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 309/517] 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 310/517] 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 311/517] 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 312/517] 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 313/517] 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 314/517] 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 315/517] 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 316/517] 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 317/517] 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 318/517] 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 319/517] 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 320/517] 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 321/517] 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 322/517] 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 323/517] 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 a568620dd4f45361863f208f7c8be85c1e657bce Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:10:24 +0200 Subject: [PATCH 324/517] Remove gs from set signature in base --- src/analyses/base.ml | 70 ++++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 912d1f3bff..f24e9419d9 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1417,7 +1417,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) ?(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 set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (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 *) @@ -1476,7 +1476,7 @@ struct * side-effects here, but the code still distinguishes these cases. *) if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then begin if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: update a global var '%s' ...\n" x.vname; - let priv_getg = priv_getg gs in + let priv_getg = priv_getg ctx.global in (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) @@ -1590,7 +1590,7 @@ struct let set_many ~ctx a (gs:glob_fun) (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = - set ~ctx a gs acc lval typ value + set ~ctx a acc lval typ value in (* And fold over the list starting from the store turned wstore: *) List.fold_left f st lval_value_list @@ -1640,7 +1640,7 @@ struct let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true gs st lval lval_type ?lval_raw value + let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -1660,8 +1660,8 @@ struct let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with - | Top -> set ~ctx ask gs st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw - | v -> set ~ctx ask gs st adr lval_t v ?lval_raw ?rval_raw + | Top -> set ~ctx ask st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw + | v -> set ~ctx ask st adr lval_t v ?lval_raw ?rval_raw (************************************************************************** @@ -1834,7 +1834,7 @@ struct | ret -> ret in let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in - let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) ctx.global nst (return_var ()) t_override rv in + let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1851,7 +1851,7 @@ struct let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in - set ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval v.vtype new_value + set ~ctx (Analyses.ask_of_ctx ctx) ctx.local lval v.vtype new_value (************************************************************************** * Function calls @@ -2173,7 +2173,7 @@ struct else VD.top_value (unrollType dest_typ) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value in + set ~ctx (Analyses.ask_of_ctx ctx) 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 *) @@ -2219,15 +2219,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 *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + set ~ctx (Analyses.ask_of_ctx ctx) 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) + set ~ctx (Analyses.ask_of_ctx ctx) 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)) + set ~ctx (Analyses.ask_of_ctx ctx) 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)) + set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else @@ -2235,11 +2235,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 ~blob_destructive:true (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) st lv_a lv_typ (op_array array_s1 array_s2) | 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) + set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) 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 @@ -2248,7 +2248,7 @@ struct 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) + set ~ctx (Analyses.ask_of_ctx ctx) 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 @@ -2259,19 +2259,19 @@ struct 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) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array empty_array array_s2) | _, 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 *) 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)) + set ~ctx (Analyses.ask_of_ctx ctx) 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) 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)) + set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in let st = match desc.special args, f.vname with @@ -2286,13 +2286,13 @@ struct | _ -> VD.top_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | Bzero { dest; count; }, _ -> (* TODO: share something with memset special case? *) (* TODO: check count *) let dest_a, dest_typ = addr_type_of_exp dest in let value = VD.zero_init_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | Memcpy { dest = dst; src; n; }, _ -> (* TODO: use n *) memory_copying dst src (Some n) | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) @@ -2315,7 +2315,7 @@ struct | 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 + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> @@ -2374,10 +2374,10 @@ struct match ID.to_int x with | Some z -> if M.tracing then M.tracel "attr" "setting\n"; - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) - | None -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) + | None -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end - | _ -> set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + | _ -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end | Identity e, _ -> begin match lv with @@ -2452,7 +2452,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) gs st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2470,7 +2470,7 @@ struct | 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? *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st ret_a (Cilfacade.typeOf ret_var) v + set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] end | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] @@ -2573,14 +2573,14 @@ struct let st' = match eval_rv ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in - let r = set ~ctx ask gs st jmp_buf (Cilfacade.typeOf env) value in + let r = set ~ctx ask st jmp_buf (Cilfacade.typeOf env) value in if M.tracing then M.tracel "setjmp" "setting setjmp %a on %a -> %a\n" d_exp env D.pretty st D.pretty r; r | _ -> failwith "problem?!" in begin match lv with | Some lv -> - set ~ctx ask gs st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx ask st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2603,12 +2603,12 @@ struct in let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in - set ~ctx ~t_override:t ask ctx.global ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) + set ~ctx ~t_override:t ask ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2843,7 +2843,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false gs st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = @@ -2887,7 +2887,7 @@ struct WideningTokens.with_side_tokens (WideningTokens.TS.of_list uuids) (fun () -> CPA.fold (fun x v acc -> let addr: AD.t = AD.of_mval (x, `NoOffset) in - set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false ctx.global acc addr x.vtype v + set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false acc addr x.vtype v ) e_d.cpa ctx.local ) in @@ -2911,7 +2911,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx (Analyses.ask_of_ctx ctx) ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> From fcb52df193a0ec4bca6bcf0c668f47d16daf7114 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:15:24 +0200 Subject: [PATCH 325/517] Remove gs from set_many signature in base --- src/analyses/base.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f24e9419d9..209dc21279 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1587,7 +1587,7 @@ struct (* if M.tracing then M.tracel "set" ~var:firstvar "set got an exception '%s'\n" x; *) M.info ~category:Unsound "Assignment to unknown address, assuming no write happened."; st - let set_many ~ctx a (gs:glob_fun) (st: store) lval_value_list: store = + let set_many ~ctx a (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = set ~ctx a acc lval typ value @@ -1809,7 +1809,7 @@ struct let init_var v = (AD.of_var v, v.vtype, VD.init_value ~varAttr:v.vattr v.vtype) in (* Apply it to all the locals and then assign them all *) let inits = List.map init_var f.slocals in - set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local inits + set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.local inits let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then @@ -1903,7 +1903,7 @@ struct let vs = List.map (Tuple3.third) invalids' in M.tracel "invalidate" "Setting addresses [%a] to values [%a]\n" (d_list ", " AD.pretty) addrs (d_list ", " VD.pretty) vs ); - set_many ~ctx ask gs st invalids' + set_many ~ctx ask st invalids' let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = @@ -2485,7 +2485,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2498,7 +2498,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2514,7 +2514,7 @@ struct let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [ + set_many ~ctx (Analyses.ask_of_ctx ctx) st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] @@ -2522,7 +2522,7 @@ struct else ( let blobsize = ID.mul (ID.cast_to ik @@ sizeval) (ID.cast_to ik @@ countval) in (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) - set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [ + set_many ~ctx (Analyses.ask_of_ctx ctx) st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] @@ -2556,7 +2556,7 @@ struct heap_addr in let lv_addr = eval_lv ask gs st lv in - set_many ~ctx ask gs st [ + set_many ~ctx ask st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); ] (* TODO: free (i.e. invalidate) old blob if successful? *) From ae56428aa66592c1b4ea4642c4e8547d182e705d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:20:00 +0200 Subject: [PATCH 326/517] Remove gs from invalidate signature in base --- src/analyses/base.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 209dc21279..dd4f91b0e6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1876,11 +1876,12 @@ struct List.map mpt exps ) - let invalidate ?(deep=true) ~ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = + let invalidate ?(deep=true) ~ctx ask (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_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) + let gs = ctx.global in let invalidate_address st a = let t = AD.type_of a in let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) @@ -2041,8 +2042,8 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) gs st shallow_addrs in - invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) gs st' deep_addrs + let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st shallow_addrs in + invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = let has_non_heap_var = AD.exists (function @@ -2132,7 +2133,7 @@ struct let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s\n" d_plainlval lv f.vname; - invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global st [Cil.mkAddrOrStartOf lv] + invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = @@ -2466,14 +2467,14 @@ 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 when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) 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? *) set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] + | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] end - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] + | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] in let st' = invalidate_ret_lv st' in Priv.thread_join (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) id st' From 9d13dd19432a7bcb1e2ab0925b27835e4d1f1419 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:22:49 +0200 Subject: [PATCH 327/517] Remove gs from special_unknown_invalidate signature in base --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index dd4f91b0e6..1d3de4b3c8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2021,7 +2021,7 @@ struct newst end - let special_unknown_invalidate ctx ask gs st f args = + let special_unknown_invalidate ctx ask st f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2614,7 +2614,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) gs st f args + special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2744,7 +2744,7 @@ struct | exception Not_found -> (* Unknown functions *) let st = ctx.local in - let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) ctx.global st f args in + let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 55bc2d66f9c2c9f3ee73fff0e9790bf9698204e9 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:46:46 +0200 Subject: [PATCH 328/517] Remove ask from set signature in base --- src/analyses/base.ml | 69 ++++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 1d3de4b3c8..f28484de10 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1417,7 +1417,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) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = + let set ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (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 *) @@ -1430,6 +1430,7 @@ struct (* Updating a single varinfo*offset pair. NB! This function's type does * not include the flag. *) let update_one_addr (x, offs) (st: store): store = + let a = (Analyses.ask_of_ctx ctx) in let cil_offset = Offs.to_cil_offset offs in let t = match t_override with | Some t -> t @@ -1590,7 +1591,7 @@ struct let set_many ~ctx a (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = - set ~ctx a acc lval typ value + set ~ctx acc lval typ value in (* And fold over the list starting from the store turned wstore: *) List.fold_left f st lval_value_list @@ -1640,7 +1641,7 @@ struct let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:true st lval lval_type ?lval_raw value + let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -1660,8 +1661,8 @@ struct let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with - | Top -> set ~ctx ask st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw - | v -> set ~ctx ask st adr lval_t v ?lval_raw ?rval_raw + | Top -> set ~ctx st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw + | v -> set ~ctx st adr lval_t v ?lval_raw ?rval_raw (************************************************************************** @@ -1834,7 +1835,7 @@ struct | ret -> ret in let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in - let st' = set ~ctx ~t_override (Analyses.ask_of_ctx ctx) nst (return_var ()) t_override rv in + let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1851,7 +1852,7 @@ struct let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in - set ~ctx (Analyses.ask_of_ctx ctx) ctx.local lval v.vtype new_value + set ~ctx ctx.local lval v.vtype new_value (************************************************************************** * Function calls @@ -2174,7 +2175,7 @@ struct else VD.top_value (unrollType dest_typ) in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value in + set ~ctx 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 *) @@ -2220,15 +2221,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 *) - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (f s1_a s2_a) + set ~ctx 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) st lv_a lv_typ (f s1_a s2_a) + set ~ctx st lv_a lv_typ (f s1_a s2_a) else - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx 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) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else @@ -2236,11 +2237,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 ~blob_destructive:true (Analyses.ask_of_ctx ctx) st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | 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) st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx ~blob_destructive:true 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 @@ -2249,7 +2250,7 @@ struct 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) st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx 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 @@ -2260,19 +2261,19 @@ struct 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) st lv_a lv_typ (op_array empty_array array_s2) + set ~ctx st lv_a lv_typ (op_array empty_array array_s2) | _, 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 *) let _ = AD.string_writing_defined s1_a in - set ~ctx (Analyses.ask_of_ctx ctx) st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~ctx 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) st lv_a lv_typ (op_array array_s1 array_s2) + set ~ctx st lv_a lv_typ (op_array array_s1 array_s2) | _ -> - set ~ctx (Analyses.ask_of_ctx ctx) st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~ctx st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in let st = match desc.special args, f.vname with @@ -2287,13 +2288,13 @@ struct | _ -> VD.top_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | Bzero { dest; count; }, _ -> (* TODO: share something with memset special case? *) (* TODO: check count *) let dest_a, dest_typ = addr_type_of_exp dest in let value = VD.zero_init_value dest_typ in - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | Memcpy { dest = dst; src; n; }, _ -> (* TODO: use n *) memory_copying dst src (Some n) | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) @@ -2316,7 +2317,7 @@ struct | 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) st dest_a dest_typ value + set ~ctx st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> @@ -2375,10 +2376,10 @@ struct match ID.to_int x with | Some z -> if M.tracing then M.tracel "attr" "setting\n"; - set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) - | None -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) + | None -> set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end - | _ -> set ~ctx (Analyses.ask_of_ctx ctx) st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + | _ -> set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end | Identity e, _ -> begin match lv with @@ -2453,7 +2454,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2471,7 +2472,7 @@ struct | 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? *) - set ~ctx (Analyses.ask_of_ctx ctx) st ret_a (Cilfacade.typeOf ret_var) v + set ~ctx st ret_a (Cilfacade.typeOf ret_var) v | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] end | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] @@ -2574,14 +2575,14 @@ struct let st' = match eval_rv ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in - let r = set ~ctx ask st jmp_buf (Cilfacade.typeOf env) value in + let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in if M.tracing then M.tracel "setjmp" "setting setjmp %a on %a -> %a\n" d_exp env D.pretty st D.pretty r; r | _ -> failwith "problem?!" in begin match lv with | Some lv -> - set ~ctx ask st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2604,12 +2605,12 @@ struct in let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in - set ~ctx ~t_override:t ask ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) + set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx (Analyses.ask_of_ctx ctx) st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2844,7 +2845,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get a gs st addrs exp = get a gs st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set a ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = @@ -2888,7 +2889,7 @@ struct WideningTokens.with_side_tokens (WideningTokens.TS.of_list uuids) (fun () -> CPA.fold (fun x v acc -> let addr: AD.t = AD.of_mval (x, `NoOffset) in - set (Analyses.ask_of_ctx ctx) ~ctx ~invariant:false acc addr x.vtype v + set ~ctx ~invariant:false acc addr x.vtype v ) e_d.cpa ctx.local ) in @@ -2912,7 +2913,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx (Analyses.ask_of_ctx ctx) ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> From c740996b56c6e58453c58c321bb2773cd590f9d2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:48:25 +0200 Subject: [PATCH 329/517] Remove ask from set_many signature in base --- src/analyses/base.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f28484de10..89cbe59b16 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1588,7 +1588,7 @@ struct (* if M.tracing then M.tracel "set" ~var:firstvar "set got an exception '%s'\n" x; *) M.info ~category:Unsound "Assignment to unknown address, assuming no write happened."; st - let set_many ~ctx a (st: store) lval_value_list: store = + let set_many ~ctx (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = set ~ctx acc lval typ value @@ -1810,7 +1810,7 @@ struct let init_var v = (AD.of_var v, v.vtype, VD.init_value ~varAttr:v.vattr v.vtype) in (* Apply it to all the locals and then assign them all *) let inits = List.map init_var f.slocals in - set_many ~ctx (Analyses.ask_of_ctx ctx) ctx.local inits + set_many ~ctx ctx.local inits let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then @@ -1905,7 +1905,7 @@ struct let vs = List.map (Tuple3.third) invalids' in M.tracel "invalidate" "Setting addresses [%a] to values [%a]\n" (d_list ", " AD.pretty) addrs (d_list ", " VD.pretty) vs ); - set_many ~ctx ask st invalids' + set_many ~ctx st invalids' let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = @@ -2487,7 +2487,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2500,7 +2500,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2516,7 +2516,7 @@ struct let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( - set_many ~ctx (Analyses.ask_of_ctx ctx) st [ + set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] @@ -2524,7 +2524,7 @@ struct else ( let blobsize = ID.mul (ID.cast_to ik @@ sizeval) (ID.cast_to ik @@ countval) in (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) - set_many ~ctx (Analyses.ask_of_ctx ctx) st [ + set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] @@ -2558,7 +2558,7 @@ struct heap_addr in let lv_addr = eval_lv ask gs st lv in - set_many ~ctx ask st [ + set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); ] (* TODO: free (i.e. invalidate) old blob if successful? *) From 05abd0df6fde2ba5f309b991aa43d6fb102414e4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:51:39 +0200 Subject: [PATCH 330/517] Remove ask from invalidate signature --- src/analyses/base.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 89cbe59b16..f55e497f9e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1877,12 +1877,13 @@ struct List.map mpt exps ) - let invalidate ?(deep=true) ~ctx ask (st:store) (exps: exp list): store = + let invalidate ?(deep=true) ~ctx (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_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let gs = ctx.global in + let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) @@ -2043,8 +2044,8 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st shallow_addrs in - invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) st' deep_addrs + let st' = invalidate ~deep:false ~ctx st shallow_addrs in + invalidate ~deep:true ~ctx st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = let has_non_heap_var = AD.exists (function @@ -2134,7 +2135,7 @@ struct let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s\n" d_plainlval lv f.vname; - invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) st [Cil.mkAddrOrStartOf lv] + invalidate ~deep:false ~ctx st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = @@ -2468,14 +2469,14 @@ 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) st [ret_var] + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx 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? *) set ~ctx st ret_a (Cilfacade.typeOf ret_var) v - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] + | _ -> invalidate ~ctx st [ret_var] end - | _ -> invalidate ~ctx (Analyses.ask_of_ctx ctx) st [ret_var] + | _ -> invalidate ~ctx st [ret_var] in let st' = invalidate_ret_lv st' in Priv.thread_join (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) id st' From 5c27f2b1ad8e0ab3f6aa4bee5ce197e048687a1e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:52:53 +0200 Subject: [PATCH 331/517] Remove ask from special_unknown_invalidate signature --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f55e497f9e..9e20cfc522 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2023,7 +2023,7 @@ struct newst end - let special_unknown_invalidate ctx ask st f args = + let special_unknown_invalidate ctx st f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2616,7 +2616,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args + special_unknown_invalidate ctx st f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2746,7 +2746,7 @@ struct | exception Not_found -> (* Unknown functions *) let st = ctx.local in - let st = special_unknown_invalidate ctx (Analyses.ask_of_ctx ctx) st f args in + let st = special_unknown_invalidate ctx st f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 1575f7e2749b28db119dc233d7b008a9e1c56d6f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 12:54:30 +0200 Subject: [PATCH 332/517] Remove unneccessary parentheses and rename a -> ask --- src/analyses/base.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 9e20cfc522..d216838de0 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1430,12 +1430,12 @@ struct (* Updating a single varinfo*offset pair. NB! This function's type does * not include the flag. *) let update_one_addr (x, offs) (st: store): store = - let a = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in let cil_offset = Offs.to_cil_offset offs in let t = match t_override with | Some t -> t | None -> - if a.f (Q.IsAllocVar x) then + if ask.f (Q.IsAllocVar x) then (* the vtype of heap vars will be TVoid, so we need to trust the pointer we got to this to be of the right type *) (* i.e. use the static type of the pointer here *) lval_type @@ -1450,8 +1450,8 @@ struct in 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 ~blob_destructive (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in + let projected_value = project_val (Queries.to_value_domain_ask ask) None None value (is_global ask x) in + let new_value = VD.update_offset ~blob_destructive (Queries.to_value_domain_ask ask) 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 ( @@ -1475,20 +1475,20 @@ struct end else (* Check if we need to side-effect this one. We no longer generate * side-effects here, but the code still distinguishes these cases. *) - if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then begin + if (!earlyglobs || ThreadFlag.has_ever_been_multi ask) && is_global ask x then begin if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: update a global var '%s' ...\n" x.vname; let priv_getg = priv_getg ctx.global in (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) - let old_value = if not invariant && Cil.isIntegralType x.vtype && not (a.f (IsAllocVar x)) && offs = `NoOffset then begin + let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ask.f (IsAllocVar x)) && offs = `NoOffset then begin VD.bot_value ~varAttr:x.vattr lval_type end else - Priv.read_global a priv_getg st x + Priv.read_global ask priv_getg st x in let new_value = update_offset old_value in 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 + let r = Priv.write_global ~invariant ask 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 end else begin @@ -1565,7 +1565,7 @@ struct else let x_updated = update_variable x t new_value st.cpa in let with_dep = add_partitioning_dependencies x new_value {st with cpa = x_updated } in - effect_on_arrays a with_dep + effect_on_arrays ask with_dep end in let update_one x store = From 16c9a8be199303b8bace8ea1056000daa35a6751 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 13:20:13 +0200 Subject: [PATCH 333/517] Remove st from special_unknown_invalidate signature --- src/analyses/base.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d216838de0..c1aa47f17a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2023,7 +2023,7 @@ struct newst end - let special_unknown_invalidate ctx st f args = + let special_unknown_invalidate ctx f args = (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown function ptr called"); let desc = LF.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in @@ -2044,7 +2044,7 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~deep:false ~ctx st shallow_addrs in + let st' = invalidate ~deep:false ~ctx ctx.local shallow_addrs in invalidate ~deep:true ~ctx st' deep_addrs let check_invalid_mem_dealloc ctx special_fn ptr = @@ -2616,7 +2616,7 @@ struct end | _, _ -> let st = - special_unknown_invalidate ctx st f args + special_unknown_invalidate ctx f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2745,8 +2745,7 @@ struct [make_entry ~thread:true ctx fd args] | exception Not_found -> (* Unknown functions *) - let st = ctx.local in - let st = special_unknown_invalidate ctx st f args in + let st = special_unknown_invalidate ctx f args in [st] let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = From 8187ac9c210f9e3b9f6b2eddd4507325e2632a54 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 14:20:10 +0200 Subject: [PATCH 334/517] Add ctx to almost everywhere in base --- src/analyses/base.ml | 297 ++++++++++++++++++---------------- src/analyses/baseInvariant.ml | 26 +-- 2 files changed, 169 insertions(+), 154 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c1aa47f17a..7d78e91302 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -679,14 +679,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let rec eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint a gs st exp + eval_rv_ask_evalint ~ctx a gs st exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -695,8 +695,8 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint a gs st exp = - let eval_next () = eval_rv_no_ask_evalint a gs st exp in + and eval_rv_ask_evalint ~ctx a gs st exp = + let eval_next () = eval_rv_no_ask_evalint ~ctx a gs st exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with @@ -719,24 +719,24 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint a gs st exp = - eval_rv_base a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx a gs st exp = + eval_rv_base ~ctx a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up a gs st exp = + and eval_rv_back_up ~ctx a gs st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv a gs st exp + eval_rv ~ctx a gs st exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base a gs st exp (* bypass all queries *) + eval_rv_base ~ctx a gs st exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + and eval_rv_base ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -758,7 +758,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -774,12 +774,12 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv a gs st e1 in - let a2 = eval_rv a gs st e2 in + let a1 = eval_rv ~ctx a gs st e1 in + let a2 = eval_rv ~ctx a gs st e2 in let extra_is_safe = match evalbinop_base a st op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -788,7 +788,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop a gs st op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx a gs st op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -821,8 +821,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv a gs st e in (* value of common exp *) - let vs = List.map (eval_rv a gs st) es in (* values of other sides *) + let v = eval_rv ~ctx a gs st e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx a gs st) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -864,25 +864,25 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop a gs st LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx a gs st LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop a gs st op ~e1 ~e2 typ + evalbinop ~ctx a gs st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv a gs st arg1 in + let a1 = eval_rv ~ctx a gs st arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv a gs st lval) + | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv a gs st lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv a gs st (Const (CStr (x,e))) (* TODO safe? *) + Address (AD.map array_start (eval_lv ~ctx a gs st lval)) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx a gs st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv a gs st exp in + let v = eval_rv ~ctx a gs st exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -898,9 +898,9 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv a gs st (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get a gs st (eval_lv ~ctx a gs st (Var v, ofs)) (Some exp) (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -913,7 +913,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv a gs st b in (* abstract base addresses *) + let p = eval_lv ~ctx a gs st b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -951,19 +951,19 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset a gs st ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx a gs st ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal a gs st op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx a gs st op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let a1 = eval_rv a gs st e1 in - let a2 = eval_rv a gs st e2 in + let a1 = eval_rv ~ctx a gs st e1 in + let a2 = eval_rv ~ctx a gs st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base a st op t1 a1 t2 a2 t in @@ -1002,48 +1002,48 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv a (gs:glob_fun) st (exp:exp): AD.t = + and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv a gs st lval - | _ -> eval_tv a gs st exp + | Lval lval -> eval_lv ~ctx a gs st lval + | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) - and eval_tv a (gs:glob_fun) st (exp:exp): AD.t = - match (eval_rv a gs st exp) with + and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + match (eval_rv ~ctx a gs st exp) with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int a gs st exp = - match eval_rv a gs st exp with + and eval_int ~ctx a gs st exp = + match eval_rv ~ctx a gs st exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset a (gs:glob_fun) (st: store) (ofs: offset) = + and convert_offset ~ctx a (gs:glob_fun) (st: store) (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset a gs st ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx a gs st ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset a gs st ofs) + `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) | Index (exp, ofs) -> - match eval_rv a gs st exp with - | Int i -> `Index (iDtoIdx i, convert_offset a gs st ofs) - | Address add -> `Index (AD.to_int add, convert_offset a gs st ofs) - | Top -> `Index (IdxDom.top (), convert_offset a gs st ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset a gs st ofs) + match eval_rv ~ctx a gs st exp with + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = + and eval_lv ~ctx (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset a gs st ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx a gs st ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match (eval_rv a gs st n) with + match (eval_rv ~ctx a gs st n) with | Address adr -> ( if AD.is_null adr then ( @@ -1063,7 +1063,7 @@ struct M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx a gs st ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr @@ -1075,17 +1075,17 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = try - let r = eval_rv a gs st exp in + let r = eval_rv ~ctx a gs st exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ask gs st e = + let query_evalint ~ctx ask gs st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ask gs st e with + let r = match eval_rv_no_ask_evalint ~ctx ask gs st e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) @@ -1107,17 +1107,32 @@ struct else ( let asked' = Queries.Set.add anyq asked in match q with - | EvalInt e -> query_evalint (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and ask asked = { Queries.f = fun (type a) (q: a Queries.t) -> query asked q } (* our version of ask *) - and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) in (* the expression is guaranteed to not contain globals *) - match (eval_rv (ask Queries.Set.empty) gs st exp) with + and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) + and ctx = + { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in base eval_exp context.") + ; node = MyCFG.dummy_node + ; prev_node = MyCFG.dummy_node + ; control_context = (fun () -> ctx_failwith "Base eval_exp has no context.") + ; context = (fun () -> ctx_failwith "Base eval_exp has no context.") + ; edge = MyCFG.Skip + ; local = st + ; global = gs + ; spawn = (fun ?(multiple=false) _ -> failwith "Base eval_exp should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Base eval_exp trying to split paths.") + ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") + } + in + match (eval_rv ~ctx (ask Queries.Set.empty) gs st exp) with | Int x -> ValueDomain.ID.to_int x | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in + let fp = eval_fv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -1128,14 +1143,14 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ask gs st e = + let eval_rv_address ~ctx ask gs st e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ask gs st e + eval_rv ~ctx ask gs st e (* interpreter end *) @@ -1227,7 +1242,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + begin match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1248,15 +1263,15 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1271,9 +1286,9 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1307,14 +1322,14 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1322,7 +1337,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1342,7 +1357,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1352,7 +1367,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1645,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine a gs st exp lval = eval_rv a gs st (Lval lval) + let eval_rv_lval_refine ~ctx a gs st exp lval = eval_rv ~ctx a gs st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1705,9 +1720,9 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in + let rval_val = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1739,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1761,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let valu = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1834,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1849,9 +1864,9 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in + let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in + let current_value = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1859,18 +1874,18 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps - let collect_invalidate ~deep ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_invalidate ~deep ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = if deep then - collect_funargs ask ~warn gs st exps + collect_funargs ~ctx ask ~warn gs st exps else ( - let mpt e = match eval_rv_address ask gs st e with + let mpt e = match eval_rv_address ~ctx ask gs st e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -1893,7 +1908,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~warn:true ask gs st exps in + let args = collect_invalidate ~deep ~ctx ~warn:true ask gs st exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -1912,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv (Analyses.ask_of_ctx ctx) ctx.global st) args in + let vals = List.map (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -1989,7 +2004,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in + let start_addr = eval_tv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2006,8 +2021,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in - let deep_flist = collect_invalidate ~deep:true (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; @@ -2056,7 +2071,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with + match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; @@ -2140,7 +2155,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let addr = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2167,12 +2182,12 @@ struct in 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 + let src_typ = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n 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) + eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2181,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv (Analyses.ask_of_ctx ctx) gs st n with + begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2207,10 +2222,10 @@ struct | _ -> 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 + let s1_v = eval_rv ~ctx (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_v = eval_rv ~ctx (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 *) @@ -2219,7 +2234,7 @@ struct 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_a = eval_lv ~ctx (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 st lv_a lv_typ (f s1_a s2_a) @@ -2235,7 +2250,7 @@ struct (* 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 + | Some lv_val -> eval_lv ~ctx (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 ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2280,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv (Analyses.ask_of_ctx ctx) gs st ch in + let eval_ch = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2303,9 +2318,9 @@ struct | 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_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv (Analyses.ask_of_ctx ctx) gs st s in + let v = eval_rv ~ctx (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 *) @@ -2331,8 +2346,8 @@ struct 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 + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (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 @@ -2350,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2365,13 +2380,13 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv (Analyses.ask_of_ctx ctx) gs st lval in + let address = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv (Analyses.ask_of_ctx ctx) gs st mtyp with + let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in + match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st mtyp with | Int x -> begin match ID.to_int x with @@ -2390,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in - let eval_y = eval_rv (Analyses.ask_of_ctx ctx) gs st y in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_y = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2455,7 +2470,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2465,10 +2480,10 @@ struct | 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 + match (eval_rv ~ctx (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 -> - begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with + begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx 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 @@ -2488,8 +2503,8 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2501,8 +2516,8 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2514,12 +2529,12 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int (Analyses.ask_of_ctx ctx) gs st size in - let countval = eval_int (Analyses.ask_of_ctx ctx) gs st n in + let sizeval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size in + let countval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2527,7 +2542,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2538,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ask gs st p in + let p_rv = eval_rv ~ctx ask gs st p in let p_addr = match p_rv with | Address a -> a @@ -2549,7 +2564,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ask gs st size in + let size_int = eval_int ~ctx ask gs st size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = @@ -2558,7 +2573,7 @@ struct else heap_addr in - let lv_addr = eval_lv ask gs st lv in + let lv_addr = eval_lv ~ctx ask gs st lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2573,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ask gs st env with + let st' = match eval_rv ~ctx ask gs st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2583,7 +2598,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2604,14 +2619,14 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ask ctx.global ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx ask ctx.global ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2636,7 +2651,7 @@ struct | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ask ctx.global st lval in + let address = eval_lv ~ctx ask ctx.global st lval in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with @@ -2735,7 +2750,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2837,10 +2852,10 @@ struct let ost = octx.local (* all evals happen in octx with non-top values *) - let eval_rv a gs st e = eval_rv oa gs ost e - let eval_rv_address a gs st e = eval_rv_address oa gs ost e - let eval_lv a gs st lv = eval_lv oa gs ost lv - let convert_offset a gs st o = convert_offset oa gs ost o + let eval_rv ~ctx a gs st e = eval_rv ~ctx oa gs ost e + let eval_rv_address ~ctx a gs st e = eval_rv_address ~ctx oa gs ost e + let eval_lv ~ctx a gs st lv = eval_lv ~ctx oa gs ost lv + let convert_offset ~ctx a gs st o = convert_offset ~ctx oa gs ost o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2850,9 +2865,9 @@ struct let refine_entire_var = false let map_oldval oldval t_lval = if VD.is_bot oldval then VD.top_value t_lval else oldval - let eval_rv_lval_refine a gs st exp lv = + let eval_rv_lval_refine ~ctx a gs st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c @@ -2913,7 +2928,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f18eeed24f..174cda8ac2 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,10 +15,10 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t - val eval_rv_address: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t - val eval_lv: Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t - val convert_offset: Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t @@ -26,7 +26,7 @@ sig val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t - val eval_rv_lval_refine: Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t + val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t val id_meet_down: old:ID.t -> c:ID.t -> ID.t val fd_meet_down: old:FD.t -> c:FD.t -> FD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx a gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv a gs st lval in + let addr = eval_lv ~ctx a gs st lval in if (AD.is_top addr) then st else let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,13 +92,13 @@ struct else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set a gs st (eval_lv ~ctx a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var a gs st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset a gs st o in + let offs = convert_offset ~ctx a gs st o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st @@ -111,7 +111,7 @@ struct | Var _, _ | Mem _, _ -> (* For accesses via pointers, not yet *) - let old_val = eval_rv_lval_refine a gs st exp x in + let old_val = eval_rv_lval_refine ~ctx a gs st exp x in let old_val = map_oldval old_val (Cilfacade.typeOfLval x) in let v = apply_invariant ~old_val ~new_val:c' in if is_some_bot v then contra st @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address a gs st (Lval x) with + match eval_rv_address ~ctx a gs st (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv a gs st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx a gs st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv a gs st (Lval x) with + (match eval_rv ~ctx a gs st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv a gs st e in + let eval e st = eval_rv ~ctx a gs st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From d4ef5c04e29a87a28b66471769b1ce4589a2aa68 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:16:13 +0200 Subject: [PATCH 335/517] Remove ask and gs from eval_rv signature --- src/analyses/base.ml | 96 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 12 ++--- 2 files changed, 52 insertions(+), 56 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7d78e91302..5cdf12d02e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -679,14 +679,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let rec eval_rv ~(ctx: _ ctx) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx a gs st exp + eval_rv_ask_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -724,7 +724,7 @@ struct and eval_rv_back_up ~ctx a gs st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv ~ctx a gs st exp + eval_rv ~ctx exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then @@ -962,8 +962,8 @@ struct (** Evaluate BinOp using MustBeEqual query as fallback. *) and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let a1 = eval_rv ~ctx a gs st e1 in - let a2 = eval_rv ~ctx a gs st e2 in + let a1 = eval_rv ~ctx e1 in + let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base a st op t1 a1 t2 a2 t in @@ -1008,11 +1008,11 @@ struct | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = - match (eval_rv ~ctx a gs st exp) with + match eval_rv ~ctx exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" and eval_int ~ctx a gs st exp = - match eval_rv ~ctx a gs st exp with + match eval_rv ~ctx exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of @@ -1075,9 +1075,9 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + let eval_rv ~ctx (st: store) (exp:exp): value = try - let r = eval_rv ~ctx a gs st exp in + let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> @@ -1127,7 +1127,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match (eval_rv ~ctx (ask Queries.Set.empty) gs st exp) with + match eval_rv ~ctx st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1150,7 +1150,7 @@ struct VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx ask gs st e + eval_rv ~ctx st e (* interpreter end *) @@ -1266,7 +1266,7 @@ struct query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv ~ctx ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end @@ -1286,7 +1286,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + eval_rv ~ctx ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) @@ -1329,7 +1329,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let v = eval_rv ~ctx ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1660,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx a gs st exp lval = eval_rv ~ctx a gs st (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1720,7 +1720,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in + let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1754,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1776,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let valu = eval_rv ~ctx ctx.local exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1849,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1865,8 +1865,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local) current_value v.vtype in + let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx ask gs st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1927,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st) args in + let vals = List.map (eval_rv ~ctx st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st (Lval src_cast_lval) + eval_rv ~ctx st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st n with + begin match eval_rv ~ctx st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s1 in + let s1_v = eval_rv ~ctx 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 ~ctx (Analyses.ask_of_ctx ctx) gs st s2 in + let s2_v = eval_rv ~ctx 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 *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ch in + let eval_ch = eval_rv ~ctx st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st s in + let v = eval_rv ~ctx st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp in + let rv = eval_rv ~ctx ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2386,7 +2386,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st mtyp with + match eval_rv ~ctx st mtyp with | Int x -> begin match ID.to_int x with @@ -2405,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in - let eval_y = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st y in + let eval_x = eval_rv ~ctx st x in + let eval_y = eval_rv ~ctx st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2480,10 +2480,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match (eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st ret_var) with + match eval_rv ~ctx st ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx (Analyses.ask_of_ctx ctx) gs st id with + begin match eval_rv ~ctx st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx 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 @@ -2553,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ~ctx ask gs st p in + let p_rv = eval_rv ~ctx st p in let p_addr = match p_rv with | Address a -> a @@ -2588,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ~ctx ask gs st env with + let st' = match eval_rv ~ctx st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2602,7 +2602,6 @@ struct | None -> st' end | Longjmp {env; value}, _ -> - let ask = Analyses.ask_of_ctx ctx in let ensure_not_zero (rv:value) = match rv with | Int i -> begin match ID.to_bool i with @@ -2619,7 +2618,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx ask ctx.global ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> @@ -2848,14 +2847,11 @@ struct module V = V module G = G - let oa = Analyses.ask_of_ctx octx - let ost = octx.local - (* all evals happen in octx with non-top values *) - let eval_rv ~ctx a gs st e = eval_rv ~ctx oa gs ost e - let eval_rv_address ~ctx a gs st e = eval_rv_address ~ctx oa gs ost e - let eval_lv ~ctx a gs st lv = eval_lv ~ctx oa gs ost lv - let convert_offset ~ctx a gs st o = convert_offset ~ctx oa gs ost o + let eval_rv ~ctx e = eval_rv ~ctx:octx e + let eval_rv_address ~ctx e = eval_rv_address ~ctx:octx e + let eval_lv ~ctx lv = eval_lv ~ctx:octx lv + let convert_offset ~ctx o = convert_offset ~ctx:octx o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2865,9 +2861,9 @@ struct let refine_entire_var = false let map_oldval oldval t_lval = if VD.is_bot oldval then VD.top_value t_lval else oldval - let eval_rv_lval_refine ~ctx a gs st exp lv = + let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 174cda8ac2..734d526391 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,7 +15,7 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -26,7 +26,7 @@ sig val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t - val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> lval -> VD.t + val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> lval -> VD.t val id_meet_down: old:ID.t -> c:ID.t -> ID.t val fd_meet_down: old:FD.t -> c:FD.t -> FD.t @@ -111,7 +111,7 @@ struct | Var _, _ | Mem _, _ -> (* For accesses via pointers, not yet *) - let old_val = eval_rv_lval_refine ~ctx a gs st exp x in + let old_val = eval_rv_lval_refine ~ctx st exp x in let old_val = map_oldval old_val (Cilfacade.typeOfLval x) in let v = apply_invariant ~old_val ~new_val:c' in if is_some_bot v then contra st @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx a gs st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx a gs st (Lval x) with + (match eval_rv ~ctx st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx a gs st e in + let eval e st = eval_rv ~ctx st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From 77c6f208d5a7f9ba6e66b03e7ac4eb25db59678b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:28:15 +0200 Subject: [PATCH 336/517] Remove st from eval_rv signature --- src/analyses/base.ml | 62 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 8 ++--- 2 files changed, 35 insertions(+), 35 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 5cdf12d02e..012ff60ee3 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1075,7 +1075,7 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (st: store) (exp:exp): value = + let eval_rv ~ctx (exp:exp): value = try let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; @@ -1127,7 +1127,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx st exp with + match eval_rv ~ctx exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1150,7 +1150,7 @@ struct VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx st e + eval_rv ~ctx e (* interpreter end *) @@ -1266,7 +1266,7 @@ struct query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx ctx.local e with + match eval_rv ~ctx e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end @@ -1286,7 +1286,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx ctx.local e + eval_rv ~ctx e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) @@ -1329,7 +1329,7 @@ struct | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx ctx.local e in + let v = eval_rv ~ctx e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1660,7 +1660,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1720,7 +1720,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx ctx.local rval in + let rval_val = eval_rv ~ctx rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1776,7 +1776,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx ctx.local exp in + let valu = eval_rv ~ctx exp in let refine () = let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1849,7 +1849,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx ctx.local exp in + let rv = eval_rv ~ctx exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> @@ -1865,8 +1865,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in - let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in + let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1927,7 +1927,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx st) args in + let vals = List.map (eval_rv ~ctx) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx st (Lval src_cast_lval) + eval_rv ~ctx (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx st n with + begin match eval_rv ~ctx n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx st s1 in + let s1_v = eval_rv ~ctx 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 ~ctx st s2 in + let s2_v = eval_rv ~ctx 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 *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx st ch in + let eval_ch = eval_rv ~ctx ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx st s in + let v = eval_rv ~ctx s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx ctx.local exp in + let rv = eval_rv ~ctx exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2386,7 +2386,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in - match eval_rv ~ctx st mtyp with + match eval_rv ~ctx mtyp with | Int x -> begin match ID.to_int x with @@ -2405,22 +2405,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx st x in + let eval_x = eval_rv ~ctx x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx st x in - let eval_y = eval_rv ~ctx st y in + let eval_x = eval_rv ~ctx x in + let eval_y = eval_rv ~ctx y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx st x in + let eval_x = eval_rv ~ctx x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2480,10 +2480,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match eval_rv ~ctx st ret_var with + match eval_rv ~ctx ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx st id with + begin match eval_rv ~ctx id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx 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 @@ -2553,7 +2553,7 @@ struct begin match lv with | Some lv -> let ask = Analyses.ask_of_ctx ctx in - let p_rv = eval_rv ~ctx st p in + let p_rv = eval_rv ~ctx p in let p_addr = match p_rv with | Address a -> a @@ -2588,7 +2588,7 @@ struct | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> let ask = Analyses.ask_of_ctx ctx in - let st' = match eval_rv ~ctx st env with + let st' = match eval_rv ~ctx env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2618,7 +2618,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in + let rv = ensure_not_zero @@ eval_rv ~ctx value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 734d526391..5dba02bb65 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,7 +15,7 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx st (Lval x) with + (match eval_rv ~ctx (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx st e in + let eval e st = eval_rv ~ctx e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From c0c8de3d475559515d64d58dc7f9a009a5d80f8e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:32:32 +0200 Subject: [PATCH 337/517] Remove ask, gs and st from eval_rv_address signature --- src/analyses/base.ml | 20 ++++++++++---------- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 012ff60ee3..6285c64cbd 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1143,7 +1143,7 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ~ctx ask gs st e = + let eval_rv_address ~ctx e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) @@ -1242,7 +1242,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + begin match eval_rv_address ~ctx e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1271,7 +1271,7 @@ struct | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1288,7 +1288,7 @@ struct | Q.EvalValue e -> eval_rv ~ctx e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e in + let p = eval_rv_address ~ctx e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1322,7 +1322,7 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i @@ -1337,7 +1337,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1357,7 +1357,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1367,7 +1367,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e with + match eval_rv_address ~ctx e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1885,7 +1885,7 @@ struct if deep then collect_funargs ~ctx ask ~warn gs st exps else ( - let mpt e = match eval_rv_address ~ctx ask gs st e with + let mpt e = match eval_rv_address ~ctx e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -2071,7 +2071,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local ptr with + match eval_rv_address ~ctx ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 5dba02bb65..d2e535403d 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -16,7 +16,7 @@ sig module G: Lattice.S val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address ~ctx a gs st (Lval x) with + match eval_rv_address ~ctx (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> From 7ae6bdda4a0e4e222d0de877a96ce4febb642c5a Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:40:17 +0200 Subject: [PATCH 338/517] Remove ask, gs and st from eval_rv_back_up signature --- src/analyses/base.ml | 44 ++++++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6285c64cbd..67f25dec8d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -686,7 +686,7 @@ struct if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp + eval_rv_ask_evalint ~ctx exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -695,14 +695,15 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint ~ctx a gs st exp = - let eval_next () = eval_rv_no_ask_evalint ~ctx a gs st exp in + and eval_rv_ask_evalint ~ctx exp = + let ask = Analyses.ask_of_ctx ctx in + let eval_next () = eval_rv_no_ask_evalint ~ctx exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with | typ when Cil.isIntegralType typ && not (Cil.isConstant exp) -> (* don't EvalInt integer constants, base can do them precisely itself *) if M.tracing then M.traceli "evalint" "base ask EvalInt %a\n" d_exp exp; - let a = a.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) + let a = ask.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) if M.tracing then M.traceu "evalint" "base ask EvalInt %a -> %a\n" d_exp exp Queries.ID.pretty a; begin match a with | `Bot -> eval_next () (* Base EvalInt returns bot on incorrect type (e.g. pthread_t); ignore and continue. *) @@ -719,10 +720,10 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint ~ctx a gs st exp = - eval_rv_base ~ctx a gs st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx exp = + eval_rv_base ~ctx exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up ~ctx a gs st exp = + and eval_rv_back_up ~ctx exp = if get_bool "ana.base.eval.deep-query" then eval_rv ~ctx exp else ( @@ -730,13 +731,16 @@ struct if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base ~ctx a gs st exp (* bypass all queries *) + eval_rv_base ~ctx exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp:exp): value = + and eval_rv_base ~ctx (exp:exp): value = + let a = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -758,7 +762,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv ~ctx a gs st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -778,8 +782,8 @@ struct (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv ~ctx a gs st e1 in - let a2 = eval_rv ~ctx a gs st e2 in + let a1 = eval_rv ~ctx e1 in + let a2 = eval_rv ~ctx e2 in let extra_is_safe = match evalbinop_base a st op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -821,8 +825,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv ~ctx a gs st e in (* value of common exp *) - let vs = List.map (eval_rv ~ctx a gs st) es in (* values of other sides *) + let v = eval_rv ~ctx e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -870,7 +874,7 @@ struct evalbinop ~ctx a gs st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv ~ctx a gs st arg1 in + let a1 = eval_rv ~ctx arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) @@ -880,9 +884,9 @@ struct let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in Address (AD.map array_start (eval_lv ~ctx a gs st lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx a gs st (Const (CStr (x,e))) (* TODO safe? *) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv ~ctx a gs st exp in + let v = eval_rv ~ctx exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -1025,7 +1029,7 @@ struct | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) | Index (exp, ofs) -> - match eval_rv ~ctx a gs st exp with + match eval_rv ~ctx exp with | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) @@ -1043,7 +1047,7 @@ struct * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match (eval_rv ~ctx a gs st n) with + match eval_rv ~ctx n with | Address adr -> ( if AD.is_null adr then ( @@ -1085,7 +1089,7 @@ struct let query_evalint ~ctx ask gs st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ~ctx ask gs st e with + let r = match eval_rv_no_ask_evalint ~ctx e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) From 7b6005ea9af720f0d0b739ded266a37e8406045c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:51:33 +0200 Subject: [PATCH 339/517] Remove ask, gs and st from eval_lv signature --- src/analyses/base.ml | 62 ++++++++++++++++++----------------- src/analyses/baseInvariant.ml | 6 ++-- 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 67f25dec8d..3338c4f3f6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -877,13 +877,13 @@ struct let a1 = eval_rv ~ctx arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv ~ctx a gs st lval) + | AddrOf lval -> Address (eval_lv ~ctx lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv ~ctx a gs st lval)) + Address (AD.map array_start (eval_lv ~ctx lval)) | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> let v = eval_rv ~ctx exp in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv ~ctx a gs st (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -917,7 +917,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv ~ctx a gs st b in (* abstract base addresses *) + let p = eval_lv ~ctx b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -1008,7 +1008,7 @@ struct * address, e.g. when calling functions. *) and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv ~ctx a gs st lval + | Lval lval -> eval_lv ~ctx lval | _ -> eval_tv ~ctx a gs st exp (* Used also for thread creation: *) and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = @@ -1036,7 +1036,10 @@ struct | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv ~ctx (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = + and eval_lv ~ctx (lval:lval): AD.t = + let a = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just @@ -1726,7 +1729,7 @@ struct char_array_hack (); let rval_val = eval_rv ~ctx rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let lval_val = eval_lv ~ctx lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1868,7 +1871,7 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (Var v, NoOffset) in + let lval = eval_lv ~ctx (Var v, NoOffset) in let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value @@ -2159,7 +2162,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in + let addr = eval_lv ~ctx lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2186,7 +2189,7 @@ struct in 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 ~ctx (Analyses.ask_of_ctx ctx) gs st src_lval + let src_typ = eval_lv ~ctx src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then @@ -2238,7 +2241,7 @@ struct 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 ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_a = eval_lv ~ctx 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 st lv_a lv_typ (f s1_a s2_a) @@ -2254,7 +2257,7 @@ struct (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~ctx 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 ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2322,7 +2325,7 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv_val in + let dest_a = eval_lv ~ctx lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in let v = eval_rv ~ctx s in let a = address_from_value v in @@ -2350,8 +2353,8 @@ struct 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 ~ctx (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2384,12 +2387,12 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lval in + let address = eval_lv ~ctx lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st dst_lval in + let dest_a = eval_lv ~ctx dst_lval in match eval_rv ~ctx mtyp with | Int x -> begin @@ -2474,7 +2477,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2508,7 +2511,7 @@ struct let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2521,7 +2524,7 @@ struct in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2538,7 +2541,7 @@ struct if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2546,7 +2549,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv ~ctx (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2577,7 +2580,7 @@ struct else heap_addr in - let lv_addr = eval_lv ~ctx ask gs st lv in + let lv_addr = eval_lv ~ctx lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2591,7 +2594,6 @@ struct st | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> - let ask = Analyses.ask_of_ctx ctx in let st' = match eval_rv ~ctx env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in @@ -2602,7 +2604,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ~ctx ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2629,7 +2631,7 @@ struct begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2649,12 +2651,12 @@ struct let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = let ask = (Analyses.ask_of_ctx ctx) in - AD.fold (fun addr st -> + AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ~ctx ask ctx.global st lval in + let address = eval_lv ~ctx lval in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with @@ -2753,7 +2755,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2928,7 +2930,7 @@ struct Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index d2e535403d..ef72e6d961 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -17,7 +17,7 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> lval -> AD.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx a gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv ~ctx a gs st lval in + let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,7 +92,7 @@ struct else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv ~ctx a gs st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set a gs st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) From b11d327082ba2dab91cfa899182d487f101d18f2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 15:57:17 +0200 Subject: [PATCH 340/517] Remove ask, gs and st from convert_offset signature --- src/analyses/base.ml | 25 +++++++++++-------------- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3338c4f3f6..7f0afb3168 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -955,7 +955,7 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx a gs st ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1021,31 +1021,28 @@ struct | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset ~ctx a (gs:glob_fun) (st: store) (ofs: offset) = + and convert_offset ~ctx (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx a gs st ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) + `Index (IdxDom.top (), convert_offset ~ctx ofs) | Index (exp, ofs) -> match eval_rv ~ctx exp with - | Int i -> `Index (iDtoIdx i, convert_offset ~ctx a gs st ofs) - | Address add -> `Index (AD.to_int add, convert_offset ~ctx a gs st ofs) - | Top -> `Index (IdxDom.top (), convert_offset ~ctx a gs st ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx a gs st ofs) + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) and eval_lv ~ctx (lval:lval): AD.t = - let a = Analyses.ask_of_ctx ctx in - let gs = ctx.global in - let st = ctx.local in let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset ~ctx a gs st ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) @@ -1063,14 +1060,14 @@ 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, _) -> not (CPA.mem v ctx.local.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset ~ctx a gs st ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index ef72e6d961..71e0977813 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -18,7 +18,7 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t - val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> offset -> ID.t Offset.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t @@ -98,7 +98,7 @@ struct (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var a gs st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset ~ctx a gs st o in + let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st From 5f18ee7f2100f0ce8557c50662b18b9416ef7154 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:01:25 +0200 Subject: [PATCH 341/517] Remove unused parameter st from evalbinop_base signature --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7f0afb3168..c6a8a4af5b 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -249,7 +249,7 @@ struct | _ -> false (* Evaluate binop for two abstract values: *) - let evalbinop_base (a: Q.ask) (st: store) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = + let evalbinop_base (a: Q.ask) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = if M.tracing then M.tracel "eval" "evalbinop %a %a %a\n" d_binop op VD.pretty a1 VD.pretty a2; (* We define a conversion function for the easy cases when we can just use * the integer domain operations. *) @@ -785,7 +785,7 @@ struct let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let extra_is_safe = - match evalbinop_base a st op t1 a1 t2 a2 typ with + match evalbinop_base a op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -970,7 +970,7 @@ struct let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base a st op t1 a1 t2 a2 t in + let r = evalbinop_base a op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) From 292bd8de21d21b49465ea8ab5f23a56d043e3a9b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:06:30 +0200 Subject: [PATCH 342/517] Remove ask, gs and st from evalbinop signature --- src/analyses/base.ml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c6a8a4af5b..714a4fdd3d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -792,7 +792,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop ~ctx a gs st op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -868,10 +868,10 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop ~ctx a gs st LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop ~ctx a gs st op ~e1 ~e2 typ + evalbinop ~ctx op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> let a1 = eval_rv ~ctx arg1 in @@ -960,24 +960,25 @@ struct in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal ~ctx a gs st op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) + let ask = Analyses.ask_of_ctx ctx in let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base a op t1 a1 t2 a2 t in + let r = evalbinop_base ask op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) | _ -> (* Fallback to MustBeEqual query, could get extra precision from exprelation/var_eq. *) let must_be_equal () = - let r = Q.must_be_equal a e1 e2 in + let r = Q.must_be_equal ask e1 e2 in if M.tracing then M.tracel "query" "MustBeEqual (%a, %a) = %b\n" d_exp e1 d_exp e2 r; r in From 4bd149386ad4885f5b5ce7b435307e0022b0d79b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:10:06 +0200 Subject: [PATCH 343/517] Remove ask, gs and st from eval_fv, eval_tv and eval_int signatures --- src/analyses/base.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 714a4fdd3d..59efc68d09 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1007,16 +1007,16 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + and eval_fv ~ctx (exp:exp): AD.t = match exp with | Lval lval -> eval_lv ~ctx lval - | _ -> eval_tv ~ctx a gs st exp + | _ -> eval_tv ~ctx exp (* Used also for thread creation: *) - and eval_tv ~ctx a (gs:glob_fun) st (exp:exp): AD.t = + and eval_tv ~ctx (exp:exp): AD.t = match eval_rv ~ctx exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int ~ctx a gs st exp = + and eval_int ~ctx exp = match eval_rv ~ctx exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) @@ -1137,7 +1137,7 @@ struct | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in + let fp = eval_fv ~ctx fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -2009,7 +2009,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local start in + let start_addr = eval_tv ~ctx start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2508,7 +2508,7 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2521,7 +2521,7 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size, true)); + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end @@ -2534,8 +2534,8 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st size in - let countval = eval_int ~ctx (Analyses.ask_of_ctx ctx) gs st n in + let sizeval = eval_int ~ctx size in + let countval = eval_int ~ctx n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); @@ -2569,7 +2569,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ~ctx ask gs st size in + let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = From ac2839aac0321c8be6273da824d4ffeb3ff26ac1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:18:50 +0200 Subject: [PATCH 344/517] Remove unused parameters ask and gs from set_savetop signature --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 59efc68d09..475c1378b8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1678,7 +1678,7 @@ struct let invariant = Invariant.invariant - let set_savetop ~ctx ?lval_raw ?rval_raw ask (gs:glob_fun) st adr lval_t v : store = + let set_savetop ~ctx ?lval_raw ?rval_raw st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a\n" AD.pretty adr d_type lval_t VD.pretty v; match v with | Top -> set ~ctx st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw @@ -1769,15 +1769,15 @@ struct let iv = VD.bot_value ~varAttr:v.vattr t in (* correct bottom value for top level variable *) if M.tracing then M.tracel "set" "init bot value: %a\n" VD.pretty iv; let nv = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) iv offs rval_val (Some (Lval lval)) lval t in (* do desired update to value *) - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local (AD.of_var v) lval_t nv ~lval_raw:lval ~rval_raw:rval (* set top-level variable to updated value *) + set_savetop ~ctx ctx.local (AD.of_var v) lval_t nv ~lval_raw:lval ~rval_raw:rval (* set top-level variable to updated value *) | None -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval let branch ctx (exp:exp) (tv:bool) : store = @@ -2666,7 +2666,7 @@ struct | _, _ -> begin let new_val = get ask ctx.global fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; - let st' = set_savetop ~ctx ask ctx.global st address lval_type new_val in + let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in match partDep with | None -> st' @@ -2753,7 +2753,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after From f68cfa7247f32ef360799539a58c9b0b8f679af4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:32:32 +0200 Subject: [PATCH 345/517] Repetitive usages of (Analyses.ask_of_ctx ctx) to one variable --- src/analyses/base.ml | 66 ++++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 475c1378b8..6a45bc1422 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1243,6 +1243,7 @@ struct Invariant.none let query ctx (type a) (q: a Q.t): a Q.result = + let ask = Analyses.ask_of_ctx ctx in match q with | Q.EvalFunvar e -> eval_funvar ctx e @@ -1251,7 +1252,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~top:(VD.bot ()) (Analyses.ask_of_ctx ctx) ctx.global ctx.local jmp_buf None with + begin match get ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1268,7 +1269,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e + query_evalint ~ctx ask ctx.global ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx e with @@ -1312,12 +1313,12 @@ struct else a in - let r = get ~full:true (Analyses.ask_of_ctx ctx) ctx.global ctx.local a None in + let r = get ~full:true ask ctx.global ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> (* unroll into array for Calloc calls *) - (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -1347,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars (Analyses.ask_of_ctx ctx) [a'] ctx.global ctx.local in + let addrs = reachable_vars ask [a'] ctx.global ctx.local in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1783,14 +1784,15 @@ struct let branch ctx (exp:exp) (tv:bool) : store = let valu = eval_rv ~ctx exp in let refine () = - let res = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local exp tv in + let ask = Analyses.ask_of_ctx ctx in + let res = invariant ctx ask ctx.global ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx (Analyses.ask_of_ctx ctx) ctx.global res e tv + invariant ctx ask ctx.global res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -1835,6 +1837,7 @@ struct let return ctx exp fundec: store = if Cil.hasAttribute "noreturn" fundec.svar.vattr then M.warn ~category:(Behavior (Undefined Other)) "Function declared 'noreturn' could return"; + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in match fundec.svar.vname with | "__goblint_dummy_init" -> @@ -1842,11 +1845,11 @@ struct publish_all ctx `Init; (* otherfun uses __goblint_dummy_init, where we can properly side effect global initialization *) (* TODO: move into sync `Init *) - Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | _ -> let locals = List.filter (fun v -> not (WeakUpdates.mem v st.weak)) (fundec.sformals @ fundec.slocals) in - let nst_part = rem_many_partitioning (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) ctx.local locals in - let nst: store = rem_many (Analyses.ask_of_ctx ctx) nst_part locals in + let nst_part = rem_many_partitioning (Queries.to_value_domain_ask ask) ctx.local locals in + let nst: store = rem_many ask nst_part locals in match exp with | None -> nst | Some exp -> @@ -1856,13 +1859,13 @@ struct in let rv = eval_rv ~ctx exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in - match ThreadId.get_current (Analyses.ask_of_ctx ctx) with - | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> + match ThreadId.get_current ask with + | `Lifted tid when ThreadReturn.is_current ask -> (* Evaluate exp and cast the resulting value to the void-pointer-type. Casting to the right type here avoids precision loss on joins. *) let rv = VD.cast ~torg:(Cilfacade.typeOf exp) Cil.voidPtrType rv in ctx.sideg (V.thread tid) (G.create_thread rv); - Priv.thread_return (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st' + Priv.thread_return ask (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st' | _ -> st' let vdecl ctx (v:varinfo) = @@ -1930,6 +1933,7 @@ struct let make_entry ?(thread=false) (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) fundec args: D.t = + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in (* Evaluate the arguments. *) let vals = List.map (eval_rv ~ctx) args in @@ -1942,12 +1946,12 @@ struct Otherwise thread is analyzed with no global inits, reading globals gives bot, which turns into top, which might get published... sync `Thread doesn't help us here, it's not specific to entering multithreaded mode. EnterMultithreaded events only execute after threadenter and threadspawn. *) - if not (ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx)) then - ignore (Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st); - Priv.threadenter (Analyses.ask_of_ctx ctx) st + if not (ThreadFlag.has_ever_been_multi ask) then + ignore (Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st); + Priv.threadenter ask st ) else (* use is_global to account for values that became globals because they were saved into global variables *) - let globals = CPA.filter (fun k v -> is_global (Analyses.ask_of_ctx ctx) k) st.cpa in + let globals = CPA.filter (fun k v -> is_global ask k) st.cpa in (* let new_cpa = if !earlyglobs || ThreadFlag.is_multi ctx.ask then CPA.filter (fun k v -> is_private ctx.ask ctx.local k) globals else globals in *) let new_cpa = globals in {st with cpa = new_cpa} @@ -1957,13 +1961,13 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars (Analyses.ask_of_ctx ctx) (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ask (get_ptrs vals) ctx.global st) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in (* Projection to Precision of the Callee *) let p = PU.int_precision_from_fundec fundec in - let new_cpa = project (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (Some p) new_cpa fundec in + let new_cpa = project (Queries.to_value_domain_ask ask) (Some p) new_cpa fundec in (* Identify locals of this fundec for which an outer copy (from a call down the callstack) is reachable *) let reachable_other_copies = List.filter (fun v -> match Cilfacade.find_scope_fundec v with Some scope -> CilType.Fundec.equal scope fundec | None -> false) reachable in @@ -2375,9 +2379,10 @@ struct (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) publish_all ctx `Return; (* like normal return *) - match ThreadId.get_current (Analyses.ask_of_ctx ctx) with - | `Lifted tid when ThreadReturn.is_current (Analyses.ask_of_ctx ctx) -> - ignore @@ Priv.thread_return (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st + let ask = Analyses.ask_of_ctx ctx in + match ThreadId.get_current ask with + | `Lifted tid when ThreadReturn.is_current ask -> + ignore @@ Priv.thread_return ask (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st | _ -> ()) | _ -> () end; @@ -2648,7 +2653,7 @@ struct if get_bool "sem.noreturn.dead_code" && Cil.hasAttribute "noreturn" f.vattr then raise Deadcode else st let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = - let ask = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> @@ -2691,7 +2696,7 @@ struct let add_globals (st: store) (fun_st: store) = (* Remove the return value as this is dealt with separately. *) let cpa_noreturn = CPA.remove (return_varinfo ()) fun_st.cpa in - let ask = (Analyses.ask_of_ctx ctx) in + let ask = Analyses.ask_of_ctx ctx in let tainted = f_ask.f Q.MayBeTainted in if M.tracing then M.trace "taintPC" "combine for %s in base: tainted: %a\n" f.svar.vname AD.pretty tainted; if M.tracing then M.trace "taintPC" "combine base:\ncaller: %a\ncallee: %a\n" CPA.pretty st.cpa CPA.pretty fun_st.cpa; @@ -2911,21 +2916,22 @@ struct D.join ctx.local e_d' let event ctx e octx = + let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in match e with - | Events.Lock (addr, _) when ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) -> (* TODO: is this condition sound? *) + | Events.Lock (addr, _) when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) if M.tracing then M.tracel "priv" "LOCK EVENT %a\n" LockDomain.Addr.pretty addr; - Priv.lock (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) st addr - | Events.Unlock addr when ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) -> (* TODO: is this condition sound? *) + Priv.lock ask (priv_getg ctx.global) st addr + | Events.Unlock addr when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) if addr = UnknownPtr then M.info ~category:Unsound "Unknown mutex unlocked, base privatization unsound"; (* TODO: something more sound *) WideningTokens.with_local_side_tokens (fun () -> - Priv.unlock (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st addr + Priv.unlock ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st addr ) | Events.Escape escaped -> - Priv.escape (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st escaped + Priv.escape ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st escaped | Events.EnterMultiThreaded -> - Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) From dd1b75386f72a4c56950941b40d07cd32f11aa1f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:36:26 +0200 Subject: [PATCH 346/517] Remove ask, gs and st from collect_funargs and collect_invalidate signatures --- src/analyses/base.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6a45bc1422..c630cc7e96 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1882,16 +1882,19 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_funargs ~ctx ?(warn=false) (exps: exp list) = + let ask = Analyses.ask_of_ctx ctx in + let gs = ctx.global in + let st = ctx.local in let do_exp e = let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ask [immediately_reachable] gs st in List.concat_map do_exp exps - let collect_invalidate ~deep ~ctx ask ?(warn=false) (gs:glob_fun) (st:store) (exps: exp list) = + let collect_invalidate ~deep ~ctx ?(warn=false) (exps: exp list) = if deep then - collect_funargs ~ctx ask ~warn gs st exps + collect_funargs ~ctx ~warn exps else ( let mpt e = match eval_rv_address ~ctx e with | Address a -> AD.remove NullPtr a @@ -1916,7 +1919,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~ctx ~warn:true ask gs st exps in + let args = collect_invalidate ~deep ~ctx ~warn:true exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -2030,8 +2033,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local shallow_args in - let deep_flist = collect_invalidate ~deep:true ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; From c065fa4599095f76f8c2464ffeded52c9a82ef8f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 16:43:21 +0200 Subject: [PATCH 347/517] Fix some commented out code --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c630cc7e96..42df030c22 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -905,7 +905,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) - (*| Lval (Mem e, ofs) -> get a gs st (eval_lv a gs st (Mem e, ofs)) *) + (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) let rec contains_vla (t:typ) = match t with @@ -2515,7 +2515,7 @@ struct match lv with | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in - (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) + (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st @@ -2528,7 +2528,7 @@ struct then AD.join (AD.of_var (heap_var false ctx)) AD.null_ptr else AD.of_var (heap_var false ctx) in - (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ctx.ask gs st size); *) + (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st From 50afde7439d17071b4daadf15ccfae0d67f14bcd Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:04:20 +0200 Subject: [PATCH 348/517] Add ctx as parameter to reachable_vars --- src/analyses/base.ml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 42df030c22..9d5520baf7 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -512,7 +512,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = + let rec reachable_from_value ~ctx (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -524,12 +524,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ask gs st e t description + | Union (f,e) -> reachable_from_value ~ctx ask gs st e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ask gs st e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ask gs st v t description) acc) s empty + | Array a -> reachable_from_value ~ctx ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ~ctx ask gs st e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx ask gs st v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -540,9 +540,9 @@ struct (* 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 * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address (ask: Q.ask) (gs:glob_fun) st (adr: address): address = + let reachable_from_address ~ctx (ask: Q.ask) (gs:glob_fun) st (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -550,7 +550,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = + let reachable_vars ~ctx (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -563,7 +563,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ask gs st var) acc in + AD.union (reachable_from_address ~ctx ask gs st var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -572,7 +572,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ask args gs st = Timing.wrap "reachability" (reachable_vars ask args gs) st + let reachable_vars ~ctx ask args gs st = Timing.wrap "reachability" (reachable_vars ~ctx ask args gs) st let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else @@ -1348,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ask [a'] ctx.global ctx.local in + let addrs = reachable_vars ~ctx ask [a'] ctx.global ctx.local in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1887,8 +1887,8 @@ struct let gs = ctx.global in let st = ctx.local in let do_exp e = - let immediately_reachable = reachable_from_value ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ask [immediately_reachable] gs st + let immediately_reachable = reachable_from_value ~ctx ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + reachable_vars ~ctx ask [immediately_reachable] gs st in List.concat_map do_exp exps @@ -1964,7 +1964,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ask (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx ask (get_ptrs vals) ctx.global st) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From 1b617af98034f72e4f9356833bc02066ee684941 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:12:29 +0200 Subject: [PATCH 349/517] Remove ask, gs and st from reachable_vars signatures --- src/analyses/base.ml | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 9d5520baf7..e075072807 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -512,7 +512,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value ~ctx (ask: Q.ask) (gs:glob_fun) st (value: value) (t: typ) (description: string) = + let rec reachable_from_value ~ctx (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -524,12 +524,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ~ctx ask gs st e t description + | Union (f,e) -> reachable_from_value ~ctx e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ~ctx ask gs st (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ~ctx ask gs st e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx ask gs st v t description) acc) s empty + | Array a -> reachable_from_value ~ctx (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ~ctx e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -540,9 +540,9 @@ struct (* 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 * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address ~ctx (ask: Q.ask) (gs:glob_fun) st (adr: address): address = + let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx ask gs st (get ask gs st adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -550,7 +550,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars ~ctx (ask: Q.ask) (args: address list) (gs:glob_fun) (st: store): address list = + let reachable_vars ~ctx (args: address list): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -563,7 +563,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ~ctx ask gs st var) acc in + AD.union (reachable_from_address ~ctx var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -572,7 +572,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ~ctx ask args gs st = Timing.wrap "reachability" (reachable_vars ~ctx ask args gs) st + let reachable_vars ~ctx args = Timing.wrap "reachability" (reachable_vars ~ctx) args let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else @@ -1348,7 +1348,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ~ctx ask [a'] ctx.global ctx.local in + let addrs = reachable_vars ~ctx [a'] in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1883,12 +1883,9 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (exps: exp list) = - let ask = Analyses.ask_of_ctx ctx in - let gs = ctx.global in - let st = ctx.local in let do_exp e = - let immediately_reachable = reachable_from_value ~ctx ask gs st (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ~ctx ask [immediately_reachable] gs st + let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps @@ -1964,7 +1961,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx ask (get_ptrs vals) ctx.global st) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx (get_ptrs vals)) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From dc6527cbd32174f08a48a660b0e75c5354df14f4 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:14:49 +0200 Subject: [PATCH 350/517] Remove the unused parameters ask, gs and st from query_evalint --- src/analyses/base.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index e075072807..0f77fef495 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1088,7 +1088,7 @@ struct with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ~ctx ask gs st e = + let query_evalint ~ctx e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; let r = match eval_rv_no_ask_evalint ~ctx e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) @@ -1110,12 +1110,10 @@ struct if Queries.Set.mem anyq asked then Queries.Result.top q (* query cycle *) else ( - let asked' = Queries.Set.add anyq asked in match q with - | EvalInt e -> query_evalint ~ctx (ask asked') gs st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) - and ask asked = { Queries.f = fun (type a) (q: a Queries.t) -> query asked q } (* our version of ask *) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) and ctx = { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) @@ -1269,7 +1267,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx ask ctx.global ctx.local e + query_evalint ~ctx e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx e with From c26c83e8fca0ad859e405a8fa0c65cf1028a7998 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 27 Dec 2023 17:20:31 +0200 Subject: [PATCH 351/517] 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 352/517] 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 a5d0f39537933c3a3464cb386f2f9e82c668acc7 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 18:38:06 +0100 Subject: [PATCH 353/517] Code cleanup --- .../apron/affineEqualityDomain.apron.ml | 109 +++++++++++------- 1 file changed, 69 insertions(+), 40 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 5aa1090dd4..5cd7714682 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -291,15 +291,21 @@ struct let meet t1 t2 = let sup_env = Environment.lce t1.env t2.env in - let t1, t2 = change_d t1 sup_env true false, change_d t2 sup_env true false - in if is_bot t1 || is_bot t2 then bot() else + let t1, t2 = change_d t1 sup_env true false, change_d t2 sup_env true false in + if is_bot t1 || is_bot t2 then + bot () + else + (* TODO: Why can I be sure that m1 && m2 are all Some here? *) let m1, m2 = Option.get t1.d, Option.get t2.d in - match m1, m2 with - | x, y when is_top_env t1-> {d = Some (dim_add (Environment.dimchange t2.env sup_env) y); env = sup_env} - | x, y when is_top_env t2 -> {d = Some (dim_add (Environment.dimchange t1.env sup_env) x); env = sup_env} - | x, y -> - let rref_matr = Matrix.rref_matrix_with (Matrix.copy x) (Matrix.copy y) in - if Option.is_none rref_matr then bot () else + if is_top_env t1 then + {d = Some (dim_add (Environment.dimchange t2.env sup_env) m2); env = sup_env} + else if is_top_env t2 then + {d = Some (dim_add (Environment.dimchange t1.env sup_env) m1); env = sup_env} + else + let rref_matr = Matrix.rref_matrix_with (Matrix.copy m1) (Matrix.copy m2) in + if Option.is_none rref_matr then + bot () + else {d = rref_matr; env = sup_env} @@ -312,12 +318,20 @@ struct let leq t1 t2 = let env_comp = Environment.compare t1.env t2.env in (* Apron's Environment.compare has defined return values. *) - if env_comp = -2 || env_comp > 0 then false else - if is_bot t1 || is_top_env t2 then true else - if is_bot t2 || is_top_env t1 then false else ( + if env_comp = -2 || env_comp > 0 then + (* -2: environments are not compatible (a variable has different types in the 2 environements *) + (* -1: if env1 is a subset of env2, (OK) *) + (* 0: if equality, (OK) *) + (* +1: if env1 is a superset of env2, and +2 otherwise (the lce exists and is a strict superset of both) *) + false + else if is_bot t1 || is_top_env t2 then + true + else if is_bot t2 || is_top_env t1 then + false + else let m1, m2 = Option.get t1.d, Option.get t2.d in let m1' = if env_comp = 0 then m1 else dim_add (Environment.dimchange t1.env t2.env) m1 in - Matrix.is_covered_by m2 m1') + Matrix.is_covered_by m2 m1' let leq a b = timing_wrap "leq" (leq a) b @@ -371,7 +385,11 @@ struct lin_disjunc new_r (s + 1) new_a new_b | _ -> failwith "Matrix not in rref form" end in - if is_bot a then b else if is_bot b then a else + if is_bot a then + b + else if is_bot b then + a + else match Option.get a.d, Option.get b.d with | x, y when is_top_env a || is_top_env b -> {d = Some (Matrix.empty ()); env = Environment.lce a.env b.env} | x, y when (Environment.compare a.env b.env <> 0) -> @@ -388,33 +406,34 @@ struct let res = join a b in if M.tracing then M.tracel "join" "join a: %s b: %s -> %s \n" (show a) (show b) (show res) ; res + let widen a b = - let a_env = a.env in - let b_env = b.env in - if Environment.equal a_env b_env then + if Environment.equal a.env b.env then join a b - else b + else + b let narrow a b = a + let pretty_diff () (x, y) = dprintf "%s: %a not leq %a" (name ()) pretty x pretty y - let remove_rels_with_var x var env imp = + let remove_rels_with_var x var env inplace = let j0 = Environment.dim_of_var env var in - if imp then (Matrix.reduce_col_with x j0; x) else Matrix.reduce_col x j0 + if inplace then + (Matrix.reduce_col_with x j0; x) + else + Matrix.reduce_col x j0 - let remove_rels_with_var x var env imp = timing_wrap "remove_rels_with_var" (remove_rels_with_var x var env) imp + let remove_rels_with_var x var env inplace = timing_wrap "remove_rels_with_var" (remove_rels_with_var x var env) inplace let forget_vars t vars = - if is_bot t || is_top_env t then t + if is_bot t || is_top_env t || List.is_empty vars then + t else let m = Option.get t.d in - if List.is_empty vars then t else - let rec rem_vars m vars' = - begin match vars' with - | [] -> m - | x :: xs -> rem_vars (remove_rels_with_var m x t.env true) xs end - in {d = Some (Matrix.remove_zero_rows @@ rem_vars (Matrix.copy m) vars); env = t.env} + let rem_from m = List.fold_left (fun m' x -> remove_rels_with_var m' x t.env true) m vars in + {d = Some (Matrix.remove_zero_rows @@ rem_from (Matrix.copy m)); env = t.env} let forget_vars t vars = let res = forget_vars t vars in @@ -472,6 +491,7 @@ struct if M.tracing then M.tracel "ops" "assign_exp t:\n %s \n var: %s \n exp: %a\n no_ov: %b -> \n %s\n" (show t) (Var.to_string var) d_exp exp (Lazy.force no_ov) (show res) ; res + let assign_var (t: VarManagement(Vc)(Mx).t) v v' = let t = add_vars t [v; v'] in let texpr1 = Texpr1.of_expr (t.env) (Var v') in @@ -489,14 +509,20 @@ struct let t_primed = add_vars t primed_vars in let multi_t = List.fold_left2 (fun t' v_prime (_,v') -> assign_var t' v_prime v') t_primed primed_vars vv's in match multi_t.d with - | Some m when not @@ is_top_env multi_t -> let replace_col m x y = let dim_x, dim_y = Environment.dim_of_var multi_t.env x, Environment.dim_of_var multi_t.env y in - let col_x = Matrix.get_col m dim_x in - Matrix.set_col_with m col_x dim_y in + | Some m when not @@ is_top_env multi_t -> + let replace_col m x y = + let dim_x, dim_y = Environment.dim_of_var multi_t.env x, Environment.dim_of_var multi_t.env y in + let col_x = Matrix.get_col m dim_x in + Matrix.set_col_with m col_x dim_y + in let m_cp = Matrix.copy m in - let switched_m = List.fold_left2 (fun m' x y -> replace_col m' x y) m_cp primed_vars assigned_vars in + let switched_m = List.fold_left2 replace_col m_cp primed_vars assigned_vars in let res = drop_vars {d = Some switched_m; env = multi_t.env} primed_vars true in let x = Option.get res.d in - if Matrix.normalize_with x then {d = Some x; env = res.env} else bot () + if Matrix.normalize_with x then + {d = Some x; env = res.env} + else + bot () | _ -> t let assign_var_parallel t vv's = @@ -561,14 +587,17 @@ struct | _, _ -> overflow_res res let meet_tcons t tcons expr = - let check_const cmp c = if cmp c Mpqf.zero then bot_env else t - in + let check_const cmp c = if cmp c Mpqf.zero then bot_env else t in let meet_vec e = (*Flip the sign of the const. val in coeff vec*) Vector.mapi_with (fun i x -> if Vector.compare_length_with e (i + 1) = 0 then Mpqf.mone *: x else x) e; - let res = if is_bot t then bot () else - let opt_m = Matrix.rref_vec_with (Matrix.copy @@ Option.get t.d) e - in if Option.is_none opt_m then bot () else {d = opt_m; env = t.env} in + let res = + if is_bot t then + bot () + else + let opt_m = Matrix.rref_vec_with (Matrix.copy @@ Option.get t.d) e in + if Option.is_none opt_m then bot () else {d = opt_m; env = t.env} + in meet_tcons_one_var_eq res expr in match get_coeff_vec t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with @@ -615,9 +644,7 @@ struct let relift t = t let invariant t = - match t.d with - | None -> [] - | Some m -> + let invariant m = let earray = Lincons1.array_make t.env (Matrix.num_rows m) in for i = 0 to Lincons1.array_length earray do let row = Matrix.get_row m i in @@ -631,6 +658,8 @@ struct Lincons1.{lincons0; env = array_env} ) |> List.of_enum + in + BatOption.map_default invariant [] t.d let cil_exp_of_lincons1 = Convert.cil_exp_of_lincons1 From fe4a58f5153a7edbfae229a35d0b393d93ab93cc Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 18:57:27 +0100 Subject: [PATCH 354/517] Fix constant printing --- .../apron/affineEqualityDomain.apron.ml | 38 +++++++++++-------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 5cd7714682..4f47f6f494 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -243,31 +243,37 @@ struct Vector.of_array @@ row in let vec_to_constraint vec env = - let vars, _ = Environment.vars env - in let dim_to_str var = - let vl = Vector.nth vec (Environment.dim_of_var env var) - in let var_str = Var.to_string var - in if vl =: Mpqf.one then "+" ^ var_str - else if vl =: Mpqf.mone then "-" ^ var_str - else if vl <: Mpqf.mone then Mpqf.to_string vl ^ var_str - else if vl >: Mpqf.one then Format.asprintf "+%s" (Mpqf.to_string vl) ^ var_str - else "" + let vars, _ = Environment.vars env in + let dim_to_str var = + let vl = Vector.nth vec (Environment.dim_of_var env var) in + let var_str = Var.to_string var in + if vl =: Mpqf.one then "+" ^ var_str + else if vl =: Mpqf.mone then "-" ^ var_str + else if vl <: Mpqf.mone then Mpqf.to_string vl ^ var_str + else if vl >: Mpqf.one then Format.asprintf "+%s" (Mpqf.to_string vl) ^ var_str + else "" in let c_to_str vl = - if vl >: Mpqf.zero then "-" ^ Mpqf.to_string vl - else if vl <: Mpqf.zero then "+" ^ Mpqf.to_string vl - else "" + if vl =: Mpqf.zero then + "" + else + let negated = vl *: Mpqf.mone in + if negated >: Mpqf.zero then "+" ^ Mpqf.to_string negated + else Mpqf.to_string negated in let res = (String.concat "" @@ Array.to_list @@ Array.map dim_to_str vars) - ^ (c_to_str @@ Vector.nth vec (Vector.length vec - 1)) ^ "=0" - in if String.starts_with res "+" then String.sub res 1 (String.length res - 1) else res + ^ (c_to_str @@ Vector.nth vec (Vector.length vec - 1)) ^ "=0" in + if String.starts_with res "+" then + String.sub res 1 (String.length res - 1) + else + res in match t.d with | None -> "Bottom Env" | Some m when Matrix.is_empty m -> "⊤" | Some m -> - let constraint_list = List.init (Matrix.num_rows m) (fun i -> vec_to_constraint (conv_to_ints @@ Matrix.get_row m i) t.env) - in Format.asprintf "%s" ("[|"^ (String.concat "; " constraint_list) ^"|]") + let constraint_list = List.init (Matrix.num_rows m) (fun i -> vec_to_constraint (conv_to_ints @@ Matrix.get_row m i) t.env) in + Format.asprintf "%s" ("[|"^ (String.concat "; " constraint_list) ^"|]") let pretty () (x:t) = text (show x) let printXml f x = BatPrintf.fprintf f "\n\n\nmatrix\n\n\n%s\n\nenv\n\n\n%s\n\n\n" (XmlUtil.escape (Format.asprintf "%s" (show x) )) (XmlUtil.escape (Format.asprintf "%a" (Environment.print: Format.formatter -> Environment.t -> unit) (x.env))) From 31065ed0addc6471416ae81b8b915f04dda9eb42 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 19:47:11 +0100 Subject: [PATCH 355/517] Make computations in show directly on Z --- .../apron/affineEqualityDomain.apron.ml | 50 ++++++++++--------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 4f47f6f494..a1653bb423 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -230,39 +230,41 @@ struct let show t = let conv_to_ints row = - let module BI = IntOps.BigIntOps in - let row = Array.copy @@ Vector.to_array row - in - for i = 0 to Array.length row -1 do - let val_i = Mpqf.of_mpz @@ Z_mlgmpidl.mpzf_of_z @@ Mpqf.get_den row.(i) - in Array.iteri(fun j x -> row.(j) <- val_i *: x) row - done; - let int_arr = Array.init (Array.length row) (fun i -> Mpqf.get_num row.(i)) - in let div = Mpqf.of_mpz @@ Z_mlgmpidl.mpzf_of_z @@ Array.fold_left BI.gcd int_arr.(0) int_arr - in Array.iteri (fun i x -> row.(i) <- x /: div) row; - Vector.of_array @@ row + let row = Array.copy @@ Vector.to_array row in + let mpqf_of_z x = Mpqf.of_mpz @@ Z_mlgmpidl.mpzf_of_z x in + let lcm = mpqf_of_z @@ Array.fold_left (fun x y -> Z.lcm x (Mpqf.get_den y)) Z.one row in + Array.modify (fun x -> x *: lcm) row; + let int_arr = Array.map (fun x -> Mpqf.get_num x) row in + let div = Array.fold_left Z.gcd int_arr.(0) int_arr in + Array.modify (fun x -> Z.div x div) int_arr; + int_arr in - let vec_to_constraint vec env = + let vec_to_constraint arr env = let vars, _ = Environment.vars env in let dim_to_str var = - let vl = Vector.nth vec (Environment.dim_of_var env var) in + let vl = arr.(Environment.dim_of_var env var) in let var_str = Var.to_string var in - if vl =: Mpqf.one then "+" ^ var_str - else if vl =: Mpqf.mone then "-" ^ var_str - else if vl <: Mpqf.mone then Mpqf.to_string vl ^ var_str - else if vl >: Mpqf.one then Format.asprintf "+%s" (Mpqf.to_string vl) ^ var_str - else "" + if Z.equal vl Z.zero then + "" + else if Z.equal vl Z.one then + "+" ^ var_str + else if Z.equal vl Z.minus_one then + "-" ^ var_str + else if Z.lt vl Z.minus_one then + Z.to_string vl ^ var_str + else + Format.asprintf "+%s" (Z.to_string vl) ^ var_str in - let c_to_str vl = - if vl =: Mpqf.zero then + let const_to_str vl = + if Z.equal vl Z.zero then "" else - let negated = vl *: Mpqf.mone in - if negated >: Mpqf.zero then "+" ^ Mpqf.to_string negated - else Mpqf.to_string negated + let negated = Z.mul vl Z.minus_one in + if Z.gt negated Z.zero then "+" ^ Z.to_string negated + else Z.to_string negated in let res = (String.concat "" @@ Array.to_list @@ Array.map dim_to_str vars) - ^ (c_to_str @@ Vector.nth vec (Vector.length vec - 1)) ^ "=0" in + ^ (const_to_str arr.(Array.length arr - 1)) ^ "=0" in if String.starts_with res "+" then String.sub res 1 (String.length res - 1) else From 29b8ca2f0d60e0654f83dc7b158f50064406879c Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 20:00:52 +0100 Subject: [PATCH 356/517] A bit more refactoring --- .../apron/affineEqualityDomain.apron.ml | 85 ++++++++++--------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index a1653bb423..6c5112c279 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -59,7 +59,9 @@ struct let dim_add ch m = timing_wrap "dim add" (dim_add ch) m let dim_remove (ch: Apron.Dim.change) m del = - if Array.length ch.dim = 0 || Matrix.is_empty m then m else ( + if Array.length ch.dim = 0 || Matrix.is_empty m then + m + else ( Array.iteri (fun i x-> ch.dim.(i) <- x + i) ch.dim; let m' = if not del then let m = Matrix.copy m in Array.fold_left (fun y x -> Matrix.reduce_col_with y x; y) m ch.dim else m in Matrix.remove_zero_rows @@ Matrix.del_cols m' ch.dim) @@ -146,47 +148,46 @@ struct let is_const_vec v = Vector.compare_length_with (Vector.filteri (fun i x -> (*Inefficient*) Vector.compare_length_with v (i + 1) > 0 && x <>: Mpqf.zero) v) 1 = 0 in - let rec convert_texpr texp = - begin match texp with - (*If x is a constant, replace it with its const. val. immediately*) - | Cst x -> let of_union union = - let open Coeff in - match union with - | Interval _ -> failwith "Not a constant" - | Scalar x -> (match x with - | Float x -> Mpqf.of_float x - | Mpqf x -> x - | Mpfrf x -> Mpfr.to_mpq x) in Vector.set_val zero_vec ((Vector.length zero_vec) - 1) (of_union x) - | Var x -> - let zero_vec_cp = Vector.copy zero_vec in - let entry_only v = Vector.set_val_with v (Environment.dim_of_var t.env x) Mpqf.one; v in - begin match t.d with - | Some m -> let row = Matrix.find_opt (fun r -> Vector.nth r (Environment.dim_of_var t.env x) =: Mpqf.one) m in - begin match row with - | Some v when is_const_vec v -> - Vector.set_val_with zero_vec_cp ((Vector.length zero_vec) - 1) (Vector.nth v (Vector.length v - 1)); zero_vec_cp - | _ -> entry_only zero_vec_cp end - | None -> entry_only zero_vec_cp end - | Unop (u, e, _, _) -> - begin match u with - | Neg -> neg @@ convert_texpr e - | Cast -> convert_texpr e (*Ignore since casts in apron are used for floating point nums and rounding in contrast to CIL casts*) - | Sqrt -> raise NotLinear end - | Binop (b, e1, e2, _, _) -> - begin match b with - | Add -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (convert_texpr e2); v1 - | Sub -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (neg @@ convert_texpr e2); v1 - | Mul -> - let x1, x2 = convert_texpr e1, convert_texpr e2 in - begin match get_c x1, get_c x2 with - | _, Some c -> Vector.apply_with_c_with ( *:) c x1; x1 - | Some c, _ -> Vector.apply_with_c_with ( *:) c x2; x2 - | _, _ -> raise NotLinear end - | _ -> raise NotLinear end - end - in match convert_texpr texp with - | exception NotLinear -> None - | x -> Some(x) + let rec convert_texpr = function + (*If x is a constant, replace it with its const. val. immediately*) + | Cst x -> + let of_union = function + | Coeff.Interval _ -> failwith "Not a constant" + | Scalar Float x -> Mpqf.of_float x + | Scalar Mpqf x -> x + | Scalar Mpfrf x -> Mpfr.to_mpq x + in + Vector.set_val zero_vec ((Vector.length zero_vec) - 1) (of_union x) + | Var x -> + let zero_vec_cp = Vector.copy zero_vec in + let entry_only v = Vector.set_val_with v (Environment.dim_of_var t.env x) Mpqf.one; v in + begin match t.d with + | Some m -> + let row = Matrix.find_opt (fun r -> Vector.nth r (Environment.dim_of_var t.env x) =: Mpqf.one) m in + begin match row with + | Some v when is_const_vec v -> + Vector.set_val_with zero_vec_cp ((Vector.length zero_vec) - 1) (Vector.nth v (Vector.length v - 1)); zero_vec_cp + | _ -> entry_only zero_vec_cp + end + | None -> entry_only zero_vec_cp end + | Unop (Neg, e, _, _) -> neg @@ convert_texpr e + | Unop (Cast, e, _, _) -> convert_texpr e (*Ignore since casts in apron are used for floating point nums and rounding in contrast to CIL casts*) + | Unop (Sqrt, e, _, _) -> raise NotLinear + | Binop (b, e1, e2, _, _) -> + begin match b with + | Add -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (convert_texpr e2); v1 + | Sub -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (neg @@ convert_texpr e2); v1 + | Mul -> + let x1, x2 = convert_texpr e1, convert_texpr e2 in + begin match get_c x1, get_c x2 with + | _, Some c -> Vector.apply_with_c_with ( *:) c x1; x1 + | Some c, _ -> Vector.apply_with_c_with ( *:) c x2; x2 + | _, _ -> raise NotLinear end + | _ -> raise NotLinear end + in + try + Some (convert_texpr texp) + with NotLinear -> None let get_coeff_vec t texp = timing_wrap "coeff_vec" (get_coeff_vec t) texp end From 4f113e1618883ca8a193c40e2481aab14726049e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 20:12:36 +0100 Subject: [PATCH 357/517] Use modifyi where appropriate --- src/cdomains/apron/affineEqualityDomain.apron.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 6c5112c279..9febdb5778 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -53,7 +53,7 @@ struct let copy t = {t with d = Option.map Matrix.copy t.d} let dim_add (ch: Apron.Dim.change) m = - Array.iteri (fun i x -> ch.dim.(i) <- x + i) ch.dim; + Array.modifyi (fun i x -> x + i) ch.dim; (* could be written Array.modifyi (+) ch.dim; but that's too smart *) Matrix.add_empty_columns m ch.dim let dim_add ch m = timing_wrap "dim add" (dim_add ch) m @@ -62,7 +62,7 @@ struct if Array.length ch.dim = 0 || Matrix.is_empty m then m else ( - Array.iteri (fun i x-> ch.dim.(i) <- x + i) ch.dim; + Array.modifyi (fun i x -> x + i) ch.dim; let m' = if not del then let m = Matrix.copy m in Array.fold_left (fun y x -> Matrix.reduce_col_with y x; y) m ch.dim else m in Matrix.remove_zero_rows @@ Matrix.del_cols m' ch.dim) From e874d5de5aa6d65e26f1560c18bb3cb5e9c0d4f5 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 27 Dec 2023 20:26:10 +0100 Subject: [PATCH 358/517] Some formatting --- .../apron/affineEqualityDomain.apron.ml | 24 ++++++++++++------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 9febdb5778..ecd4bdc1d5 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -69,12 +69,19 @@ struct let dim_remove ch m del = timing_wrap "dim remove" (dim_remove ch m) del let change_d t new_env add del = - if Environment.equal t.env new_env then t else - let dim_change = if add then Environment.dimchange t.env new_env - else Environment.dimchange new_env t.env - in match t.d with + if Environment.equal t.env new_env then + t + else + match t.d with | None -> bot_env - | Some m -> {d = Some (if add then dim_add dim_change m else dim_remove dim_change m del); env = new_env} + | Some m -> + let dim_change = + if add then + Environment.dimchange t.env new_env + else + Environment.dimchange new_env t.env + in + {d = Some (if add then dim_add dim_change m else dim_remove dim_change m del); env = new_env} let change_d t new_env add del = timing_wrap "dimension change" (change_d t new_env add) del @@ -133,7 +140,8 @@ struct include ConvenienceOps(Mpqf) - let get_c v = match Vector.findi (fun x -> x <>: Mpqf.zero) v with + (** Get the constant from the vector if it is a constant *) + let get_c v = match Vector.findi ((<>:) Mpqf.zero) v with | exception Not_found -> Some Mpqf.zero | i when Vector.compare_length_with v (i + 1) = 0 -> Some (Vector.nth v i) | _ -> None @@ -202,8 +210,8 @@ struct match get_coeff_vec t texpr with | Some v -> begin match get_c v with | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> - let int_val = Mpqf.get_num c - in Some int_val, Some int_val + let int_val = Mpqf.get_num c in + Some int_val, Some int_val | _ -> None, None end | _ -> None, None From 6d2e52df09b1d3fb51ad0521d4579ef48e4efa26 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:05:08 +0200 Subject: [PATCH 359/517] Add ctx as parameter to get --- src/analyses/base.ml | 34 +++++++++++++++++----------------- src/analyses/baseInvariant.ml | 6 +++--- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0f77fef495..f27ba9e5a6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -455,7 +455,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -464,7 +464,7 @@ struct let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) let var = get_var a gs st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +542,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +659,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) + reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +949,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1250,7 +1250,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1311,7 @@ struct else a in - let r = get ~full:true ask ctx.global ctx.local a None in + let r = get ~ctx ~full:true ask ctx.global ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1659,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get a gs st addrs exp = get a gs st addrs exp + let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1907,7 +1907,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2259,7 +2259,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx 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 ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) gs st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | 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 @@ -2336,7 +2336,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get (Analyses.ask_of_ctx ctx) gs st a None with + begin match get ~ctx (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 @@ -2571,7 +2571,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2667,7 +2667,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ask ctx.global fun_st address None in + let new_val = get ~ctx ask ctx.global fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2742,7 +2742,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None + then get ~ctx (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None else VD.top () in @@ -2862,7 +2862,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get a gs st addrs exp = get a gs st addrs exp + let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 71e0977813..5e82644caf 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -21,7 +21,7 @@ sig val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t - val get: Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get a gs state_with_excluded addr None in + let value = get ~ctx a gs state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) From 985e746e4da0a7592e09c91bf345d2f5cff27b67 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:07:57 +0200 Subject: [PATCH 360/517] Add ctx as parameter to get_var --- src/analyses/base.ml | 6 +++--- src/analyses/baseInvariant.ml | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f27ba9e5a6..214d5d7446 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,7 +443,7 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = + let get_var ~ctx (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then Priv.read_global a (priv_getg gs) st x else begin @@ -463,7 +463,7 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var a gs st x in + let var = get_var ~ctx a gs st x in let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with @@ -1172,7 +1172,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ask ctx.global ctx.local v + let find v = get_var ~ctx ask ctx.global ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 5e82644caf..8d91afbaae 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,7 +20,7 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var a gs st var in + let old_val = get_var ~ctx a gs st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From 8f8273c2801e781c93c88eeab9755ce1a2a1b0e3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:13:11 +0200 Subject: [PATCH 361/517] Remove gs from get and get_var signatures --- src/analyses/base.ml | 44 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 10 ++++---- 2 files changed, 26 insertions(+), 28 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 214d5d7446..b11ce2428e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,9 +443,9 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var ~ctx (a: Q.ask) (gs: glob_fun) (st: store) (x: varinfo): value = + let get_var ~ctx (a: Q.ask) (st: store) (x: varinfo): value = if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then - Priv.read_global a (priv_getg gs) st x + Priv.read_global a (priv_getg ctx.global) st x else begin if M.tracing then M.tracec "get" "Singlethreaded mode.\n"; CPA.find x st.cpa @@ -455,7 +455,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (gs: glob_fun) (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -463,8 +463,8 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var ~ctx a gs st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let var = get_var ~ctx a st x in + let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +542,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +659,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local adr None) + reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +904,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx a gs st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx a st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +949,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~ctx ~top:(VD.top_value t) a gs st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) a st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a gs st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1172,7 +1172,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ~ctx ask ctx.global ctx.local v + let find v = get_var ~ctx ask ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in @@ -1250,7 +1250,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~ctx ~top:(VD.bot ()) ask ctx.global ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ask ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1311,7 @@ struct else a in - let r = get ~ctx ~full:true ask ctx.global ctx.local a None in + let r = get ~ctx ~full:true ask ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1659,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp + let get ~ctx a st addrs exp = get ~ctx a st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1903,11 +1903,10 @@ struct 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 gs = ctx.global in let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ~ctx ask gs st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx ask st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2169,7 +2168,6 @@ struct if M.tracing then if not (List.is_empty forks) then M.tracel "spawn" "Base.special %s: spawning functions %a\n" f.vname (d_list "," CilType.Varinfo.pretty) (List.map BatTuple.Tuple3.second forks); List.iter (BatTuple.Tuple3.uncurry (ctx.spawn ~multiple)) forks; let st: store = ctx.local in - let gs = ctx.global in let desc = LF.find f in let memory_copying dst src n = let dest_size = get_size_of_ptr_target ctx dst in @@ -2259,7 +2257,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match (get ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) gs st s2_a None with + begin match (get ~ctx (Analyses.ask_of_ctx ctx) st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | 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 @@ -2336,7 +2334,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get ~ctx (Analyses.ask_of_ctx ctx) gs st a None with + begin match get ~ctx (Analyses.ask_of_ctx ctx) st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in @@ -2571,7 +2569,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ~ctx ask gs st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx ask st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2667,7 +2665,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ~ctx ask ctx.global fun_st address None in + let new_val = get ~ctx ask fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2742,7 +2740,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get ~ctx (Analyses.ask_of_ctx ctx) ctx.global fun_st return_var None + then get ~ctx (Analyses.ask_of_ctx ctx) fun_st return_var None else VD.top () in @@ -2862,7 +2860,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get ~ctx a gs st addrs exp = get ~ctx a gs st addrs exp + let get ~ctx a st addrs exp = get ~ctx a st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 8d91afbaae..abdb701510 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,8 +20,8 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> varinfo -> VD.t - val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> (V.t -> G.t) -> D.t -> AD.t -> exp option -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> varinfo -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get ~ctx a gs st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx a st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get ~ctx a gs state_with_excluded addr None in + let value = get ~ctx a state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var ~ctx a gs st var in + let old_val = get_var ~ctx a st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From b9be6a5add38c1eae9326f10974f87d44e0e893d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:18:30 +0200 Subject: [PATCH 362/517] Remove ask from get and get_var signatures --- src/analyses/base.ml | 47 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 10 ++++---- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index b11ce2428e..6923b01430 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -443,9 +443,10 @@ struct let publish_all ctx reason = ignore (sync' reason ctx) - let get_var ~ctx (a: Q.ask) (st: store) (x: varinfo): value = - if (!earlyglobs || ThreadFlag.has_ever_been_multi a) && is_global a x then - Priv.read_global a (priv_getg ctx.global) st x + let get_var ~ctx (st: store) (x: varinfo): value = + let ask = Analyses.ask_of_ctx ctx in + if (!earlyglobs || ThreadFlag.has_ever_been_multi ask) && is_global ask x then + Priv.read_global ask (priv_getg ctx.global) st x else begin if M.tracing then M.tracec "get" "Singlethreaded mode.\n"; CPA.find x st.cpa @@ -455,7 +456,7 @@ struct * adding proper dependencies. * For the exp argument it is always ok to put None. This means not using precise information about * which part of an array is involved. *) - let rec get ~ctx ?(top=VD.top ()) ?(full=false) a (st: store) (addrs:address) (exp:exp option): value = + let rec get ~ctx ?(top=VD.top ()) ?(full=false) (st: store) (addrs:address) (exp:exp option): value = let at = AD.type_of addrs in let firstvar = if M.tracing then match AD.to_var_may addrs with [] -> "" | x :: _ -> x.vname else "" in if M.tracing then M.traceli "get" ~var:firstvar "Address: %a\nState: %a\n" AD.pretty addrs CPA.pretty st.cpa; @@ -463,8 +464,8 @@ struct let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - let var = get_var ~ctx a st x in - let v = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in + let var = get_var ~ctx st x in + let v = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x exp) var offs exp (Some (Var x, Offs.to_cil_offset offs)) x.vtype in if M.tracing then M.tracec "get" "var = %a, %a = %a\n" VD.pretty var AD.pretty (AD.of_mval (x, offs)) VD.pretty v; if full then var else match v with | Blob (c,s,_) -> c @@ -542,7 +543,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value ~ctx (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -659,7 +660,7 @@ struct | JmpBuf _ -> (empty, TS.bot (), false) (* TODO: is this right? *) | Mutex -> (empty, TS.bot (), false) (* TODO: is this right? *) in - reachable_from_value (get ~ctx (Analyses.ask_of_ctx ctx) ctx.local adr None) + reachable_from_value (get ~ctx ctx.local adr None) in let visited = ref empty in let work = ref ps in @@ -904,7 +905,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx a st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -949,13 +950,13 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~ctx ~top:(VD.top_value t) a st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~ctx ~top:(VD.top_value t) st (AD.singleton addr) (Some exp) (* downcasts are safe *) else VD.top () (* upcasts not! *) in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx a st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -1172,7 +1173,7 @@ struct struct let context = context let scope = Node.find_fundec ctx.node - let find v = get_var ~ctx ask ctx.local v + let find v = get_var ~ctx ctx.local v end in let module I = ValueDomain.ValueInvariant (Arg) in @@ -1250,7 +1251,7 @@ struct | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; - begin match get ~ctx ~top:(VD.bot ()) ask ctx.local jmp_buf None with + begin match get ~ctx ~top:(VD.bot ()) ctx.local jmp_buf None with | JmpBuf (x, copied) -> if copied then M.warn ~category:(Behavior (Undefined Other)) "The jump buffer %a contains values that were copied here instead of being set by setjmp. This is Undefined Behavior." d_exp e; @@ -1311,7 +1312,7 @@ struct else a in - let r = get ~ctx ~full:true ask ctx.local a None in + let r = get ~ctx ~full:true ctx.local a None in (* ignore @@ printf "BlobSize %a = %a\n" d_plainexp e VD.pretty r; *) (match r with | Array a -> @@ -1659,7 +1660,7 @@ struct let convert_offset = convert_offset let get_var = get_var - let get ~ctx a st addrs exp = get ~ctx a st addrs exp + let get ~ctx st addrs exp = get ~ctx st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true @@ -1906,7 +1907,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in - let v = get ~ctx ask st a None in (* None here is ok, just causes us to be a bit less precise *) + let v = get ~ctx st a None in (* None here is ok, just causes us to be a bit less precise *) let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in (a, t, nv) in @@ -2257,7 +2258,7 @@ struct let lv_a, lv_typ = match lv with | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in - begin match (get ~ctx (Analyses.ask_of_ctx ctx) st s1_a None), get ~ctx (Analyses.ask_of_ctx ctx) st s2_a None with + begin match (get ~ctx st s1_a None), get ~ctx st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) | 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 @@ -2334,7 +2335,7 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get ~ctx (Analyses.ask_of_ctx ctx) st a None with + begin match get ~ctx st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in @@ -2558,7 +2559,6 @@ struct check_invalid_mem_dealloc ctx f p; begin match lv with | Some lv -> - let ask = Analyses.ask_of_ctx ctx in let p_rv = eval_rv ~ctx p in let p_addr = match p_rv with @@ -2569,7 +2569,7 @@ struct | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) - let p_addr_get = get ~ctx ask st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let p_addr_get = get ~ctx st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) let size_int = eval_int ~ctx size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in @@ -2649,7 +2649,6 @@ struct if get_bool "sem.noreturn.dead_code" && Cil.hasAttribute "noreturn" f.vattr then raise Deadcode else st let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = - let ask = Analyses.ask_of_ctx ctx in AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) -> @@ -2665,7 +2664,7 @@ struct (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} | _, _ -> begin - let new_val = get ~ctx ask fun_st address None in + let new_val = get ~ctx fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in let partDep = Dep.find_opt v fun_st.deps in @@ -2740,7 +2739,7 @@ struct let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get ~ctx (Analyses.ask_of_ctx ctx) fun_st return_var None + then get ~ctx fun_st return_var None else VD.top () in @@ -2860,7 +2859,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var - let get ~ctx a st addrs exp = get ~ctx a st addrs exp + let get ~ctx st addrs exp = get ~ctx st addrs exp let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index abdb701510..51e71333f4 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -20,8 +20,8 @@ sig val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t - val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> varinfo -> VD.t - val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> Queries.ask -> D.t -> AD.t -> exp option -> VD.t + val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t + val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool @@ -67,7 +67,7 @@ struct let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st else - let old_val = get ~ctx a st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) + let old_val = get ~ctx st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) let t_lval = Cilfacade.typeOfLval lval in let old_val = map_oldval old_val t_lval in let old_val = @@ -79,7 +79,7 @@ struct old_val in let state_with_excluded = set a gs st addr t_lval value ~ctx in - let value = get ~ctx a state_with_excluded addr None in + let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) @@ -96,7 +96,7 @@ struct match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) - let old_val = get_var ~ctx a st var in + let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in From e40215085352b054f7e753e03cc7cfc7c25d9932 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 23 Nov 2023 12:11:29 +0200 Subject: [PATCH 363/517] Unbox some types --- src/cdomains/floatDomain.ml | 10 +++++----- src/cdomains/intDomain.ml | 26 +++++++++++++------------- src/domains/queries.ml | 4 ++-- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/cdomains/floatDomain.ml b/src/cdomains/floatDomain.ml index 39d3744401..e3787541bd 100644 --- a/src/cdomains/floatDomain.ml +++ b/src/cdomains/floatDomain.ml @@ -1036,11 +1036,11 @@ module FloatDomTupleImpl = struct type 'a m = (module FloatDomain with type t = 'a) (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments (Same trick as used in intDomain) *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } - type 'b poly2_pr = { f2p : 'a. 'a m -> 'a -> 'a -> 'b } - type poly1 = { f1 : 'a. 'a m -> 'a -> 'a } - type poly2 = { f2 : 'a. 'a m -> 'a -> 'a -> 'a } + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] + type 'b poly2_pr = { f2p : 'a. 'a m -> 'a -> 'a -> 'b } [@@unboxed] + type poly1 = { f1 : 'a. 'a m -> 'a -> 'a } [@@unboxed] + type poly2 = { f2 : 'a. 'a m -> 'a -> 'a -> 'a } [@@unboxed] let create r x (f1 : float_precision) = let f b g = if b then Some (g x) else None in diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 376dab71c2..103f54413e 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -1895,7 +1895,7 @@ struct module I = BI (* We use these types for the functions in this module to make the intended meaning more explicit *) type t = Exc of BISet.t * Interval32.t - type inc = Inc of BISet.t + type inc = Inc of BISet.t [@@unboxed] let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) let cardinality_of_range r = BI.add BI.one (BI.add (BI.neg (min_of_range r)) (max_of_range r)) @@ -3403,18 +3403,18 @@ module IntDomTupleImpl = struct type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } (* inject *) - type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } (* inject for functions that depend on int_t *) - type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} (* inject for functions that depend on int_t *) - - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } (* project *) - type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } (* project for functions that depend on int_t *) - type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} - type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} (* needed b/c above 'b must be different from 'a *) - type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } (* needed b/c above 'b must be different from 'a *) - type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} - type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } - type 'b poly3 = { f3: 'a. 'a m -> 'a option } (* used for projection to given precision *) + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) + type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) + type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) + + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) + type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) + type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] + type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] + type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] + type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) let create r x ((p1, p2, p3, p4, p5): int_precision) = let f b g = if b then Some (g x) else None in f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5) diff --git a/src/domains/queries.ml b/src/domains/queries.ml index 24e5d45593..f5fc832a9e 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -134,7 +134,7 @@ type 'a result = 'a Use [Analyses.ask_of_ctx] to convert [ctx] to [ask]. *) (* Must be in a singleton record due to second-order polymorphism. See https://ocaml.org/manual/polymorphism.html#s%3Ahigher-rank-poly. *) -type ask = { f: 'a. 'a t -> 'a result } +type ask = { f: 'a. 'a t -> 'a result } [@@unboxed] (* Result cannot implement Lattice.S because the function types are different due to GADT. *) module Result = @@ -267,7 +267,7 @@ end (* The type any_query can't be directly defined in Any as t, because it also refers to the t from the outer scope. *) -type any_query = Any: 'a t -> any_query +type any_query = Any: 'a t -> any_query [@@unboxed] module Any = struct From 33875aa4aa121073f2bbb20726fd5bf1ba3d7134 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:27:45 +0200 Subject: [PATCH 364/517] Simplify `ask.f` -> `ctx.ask` --- src/analyses/base.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6923b01430..5c7c540b52 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -697,14 +697,13 @@ struct This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) and eval_rv_ask_evalint ~ctx exp = - let ask = Analyses.ask_of_ctx ctx in let eval_next () = eval_rv_no_ask_evalint ~ctx exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with | typ when Cil.isIntegralType typ && not (Cil.isConstant exp) -> (* don't EvalInt integer constants, base can do them precisely itself *) if M.tracing then M.traceli "evalint" "base ask EvalInt %a\n" d_exp exp; - let a = ask.f (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) + let a = ctx.ask (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) if M.tracing then M.traceu "evalint" "base ask EvalInt %a -> %a\n" d_exp exp Queries.ID.pretty a; begin match a with | `Bot -> eval_next () (* Base EvalInt returns bot on incorrect type (e.g. pthread_t); ignore and continue. *) @@ -1455,7 +1454,7 @@ struct let t = match t_override with | Some t -> t | None -> - if ask.f (Q.IsAllocVar x) then + if ctx.ask (Q.IsAllocVar x) then (* the vtype of heap vars will be TVoid, so we need to trust the pointer we got to this to be of the right type *) (* i.e. use the static type of the pointer here *) lval_type @@ -1501,7 +1500,7 @@ struct (* Optimization to avoid evaluating integer values when setting them. The case when invariant = true requires the old_value to be sound for the meet. Allocated blocks are representend by Blobs with additional information, so they need to be looked-up. *) - let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ask.f (IsAllocVar x)) && offs = `NoOffset then begin + let old_value = if not invariant && Cil.isIntegralType x.vtype && not (ctx.ask (IsAllocVar x)) && offs = `NoOffset then begin VD.bot_value ~varAttr:x.vattr lval_type end else Priv.read_global ask priv_getg st x From 6c16cdcf4f1d577fb0814626640ef58ba8b93189 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:29:41 +0200 Subject: [PATCH 365/517] Remove gs from eval_rv_base_lval signature --- src/analyses/base.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 5c7c540b52..721f67c244 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -739,7 +739,6 @@ struct Subexpressions delegate to [eval_rv], which may use queries on them. *) and eval_rv_base ~ctx (exp:exp): value = let a = Analyses.ask_of_ctx ctx in - let gs = ctx.global in let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; @@ -778,7 +777,7 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv ~ctx a gs st exp lv + eval_rv_base_lval ~eval_lv ~ctx a st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> @@ -902,7 +901,7 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (gs:glob_fun) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) @@ -2866,7 +2865,7 @@ struct if VD.is_bot oldval then VD.top_value t_lval else oldval let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) ctx.global st exp lv + eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c From 05feaddb4009b4eeb5b97cbb5f44eb522cdb12f8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:32:02 +0200 Subject: [PATCH 366/517] Remove ask from eval_rv_base_lval signature --- src/analyses/base.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 721f67c244..8098814c37 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -777,7 +777,7 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv ~ctx a st exp lv + eval_rv_base_lval ~eval_lv ~ctx st exp lv (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> @@ -901,7 +901,7 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a\n" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv ~ctx (a: Q.ask) (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) @@ -954,7 +954,7 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask a) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) @@ -2865,7 +2865,7 @@ struct if VD.is_bot oldval then VD.top_value t_lval else oldval let eval_rv_lval_refine ~ctx st exp lv = (* new, use different ctx for eval_lv (for Mem): *) - eval_rv_base_lval ~eval_lv ~ctx (Analyses.ask_of_ctx ctx) st exp lv + eval_rv_base_lval ~eval_lv ~ctx st exp lv (* don't meet with current octx values when propagating inverse operands down *) let id_meet_down ~old ~c = c From 8dd333287f6434a5717575927a2c9c4ddeec34e9 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:37:55 +0200 Subject: [PATCH 367/517] Inline ask variables with only one usage --- src/analyses/base.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 8098814c37..6448494305 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -738,7 +738,6 @@ struct This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) and eval_rv_base ~ctx (exp:exp): value = - let a = Analyses.ask_of_ctx ctx in let st = ctx.local in let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; @@ -784,7 +783,7 @@ struct let a1 = eval_rv ~ctx e1 in let a2 = eval_rv ~ctx e2 in let extra_is_safe = - match evalbinop_base a op t1 a1 t2 a2 typ with + match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -1240,7 +1239,6 @@ struct Invariant.none let query ctx (type a) (q: a Q.t): a Q.result = - let ask = Analyses.ask_of_ctx ctx in match q with | Q.EvalFunvar e -> eval_funvar ctx e @@ -1315,7 +1313,7 @@ struct (match r with | Array a -> (* unroll into array for Calloc calls *) - (match ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -1902,11 +1900,10 @@ struct 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 ask = Analyses.ask_of_ctx ctx in let invalidate_address st a = let t = AD.type_of a in let v = get ~ctx st a None in (* None here is ok, just causes us to be a bit less precise *) - let nv = VD.invalidate_value (Queries.to_value_domain_ask ask) t v in + let nv = VD.invalidate_value (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) t v in (a, t, nv) in (* We define the function that invalidates all the values that an address From b073b7189359a803d69a1f27b685ab5c4d5b8665 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:42:28 +0200 Subject: [PATCH 368/517] Remove gs from invariant, invariant_fallback and refine_lv signatures --- src/analyses/base.ml | 8 ++++---- src/analyses/baseInvariant.ml | 14 +++++++------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 6448494305..3e22f2bfef 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1780,14 +1780,14 @@ struct let valu = eval_rv ~ctx exp in let refine () = let ask = Analyses.ask_of_ctx ctx in - let res = invariant ctx ask ctx.global ctx.local exp tv in + let res = invariant ctx ask ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx ask ctx.global res e tv + invariant ctx ask res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -2034,7 +2034,7 @@ struct let assert_fn ctx e refine = (* make the state meet the assertion in the rest of the code *) if not refine then ctx.local else begin - let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in + let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true in (* if check_assert e newst <> `Lifted true then M.warn ~category:Assert ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst @@ -2873,7 +2873,7 @@ struct in let module Unassume = BaseInvariant.Make (UnassumeEval) in try - Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true + Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true with Deadcode -> (* contradiction in unassume *) D.bot () in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 51e71333f4..bd5bd7c6ed 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -91,8 +91,8 @@ struct then set a gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) - let refine_lv ctx a gs st c x c' pretty exp = - let set' lval v st = set a gs st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let refine_lv ctx a st c x c' pretty exp = + let set' lval v st = set a ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) @@ -120,7 +120,7 @@ struct set' x v st ) - let invariant_fallback ctx a (gs:V.t -> G.t) st exp tv = + let invariant_fallback ctx a st exp tv = (* We use a recursive helper function so that x != 0 is false can be handled * as x == 0 is true etc *) let rec helper (op: binop) (lval: lval) (value: VD.t) (tv: bool): (lval * VD.t) option = @@ -240,16 +240,16 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx a gs st lval value tv + refine_lv_fallback ctx a ctx.global 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_exp exp; st - let invariant ctx a gs st exp tv: D.t = + let invariant ctx a st exp tv: D.t = let fallback reason st = 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 + invariant_fallback ctx a st exp tv in (* inverse values for binary operation a `op` b == c *) (* ikind is the type of a for limiting ranges of the operands a, b. The only binops which can have different types for a, b are Shiftlt, Shiftrt (not handled below; don't use ikind to limit b there). *) @@ -696,7 +696,7 @@ struct | Float c -> invert_binary_op c FD.pretty (fun ik -> FD.to_int ik c) (fun fk -> FD.cast_to fk c) | _ -> failwith "unreachable") | Lval x, (Int _ | Float _ | Address _) -> (* meet x with c *) - let update_lval c x c' pretty = refine_lv ctx a gs st c x c' pretty exp in + let update_lval c x c' pretty = refine_lv ctx a st c x c' pretty exp in let t = Cil.unrollType (Cilfacade.typeOfLval x) in (* unroll type to deal with TNamed *) if M.tracing then M.trace "invSpecial" "invariant with Lval %a, c_typed %a, type %a\n" d_lval x VD.pretty c_typed d_type t; begin match c_typed with From cc0285b18bfb0110426d4d777ff9d2bbeba32368 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:48:43 +0200 Subject: [PATCH 369/517] Remove ask from invariant, invariant_fallback, refine_lv and refine_lv_fallbask signatures --- src/analyses/base.ml | 9 ++++----- src/analyses/baseInvariant.ml | 25 +++++++++++++------------ 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3e22f2bfef..72dfc4af68 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1779,15 +1779,14 @@ struct let branch ctx (exp:exp) (tv:bool) : store = let valu = eval_rv ~ctx exp in let refine () = - let ask = Analyses.ask_of_ctx ctx in - let res = invariant ctx ask ctx.local exp tv in + let res = invariant ctx ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!\n"; match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx ask res e tv + invariant ctx res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a\n" d_exp exp VD.pretty valu; @@ -2034,7 +2033,7 @@ struct let assert_fn ctx e refine = (* make the state meet the assertion in the rest of the code *) if not refine then ctx.local else begin - let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true in + let newst = invariant ctx ctx.local e true in (* if check_assert e newst <> `Lifted true then M.warn ~category:Assert ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst @@ -2873,7 +2872,7 @@ struct in let module Unassume = BaseInvariant.Make (UnassumeEval) in try - Unassume.invariant ctx (Analyses.ask_of_ctx ctx) ctx.local e true + Unassume.invariant ctx ctx.local e true with Deadcode -> (* contradiction in unassume *) D.bot () in diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index bd5bd7c6ed..e4074af59e 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -62,7 +62,7 @@ struct VD.meet old_val new_val with Lattice.Uncomparable -> old_val - let refine_lv_fallback ctx a gs st lval value tv = + let refine_lv_fallback ctx gs st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st @@ -78,7 +78,8 @@ struct else old_val in - let state_with_excluded = set a gs st addr t_lval value ~ctx in + let ask = Analyses.ask_of_ctx ctx in + let state_with_excluded = set ask gs st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -88,18 +89,18 @@ struct contra st ) else if VD.is_bot new_val - then set a gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set a gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set ask gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set ask gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) - let refine_lv ctx a st c x c' pretty exp = - let set' lval v st = set a ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let refine_lv ctx st c x c' pretty exp = + let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in let offs = convert_offset ~ctx o in - let new_val = VD.update_offset (Queries.to_value_domain_ask a) old_val offs c' (Some exp) x (var.vtype) in + let new_val = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st else ( @@ -120,7 +121,7 @@ struct set' x v st ) - let invariant_fallback ctx a st exp tv = + let invariant_fallback ctx st exp tv = (* We use a recursive helper function so that x != 0 is false can be handled * as x == 0 is true etc *) let rec helper (op: binop) (lval: lval) (value: VD.t) (tv: bool): (lval * VD.t) option = @@ -240,16 +241,16 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx a ctx.global st lval value tv + refine_lv_fallback ctx ctx.global 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_exp exp; st - let invariant ctx a st exp tv: D.t = + let invariant ctx st exp tv: D.t = let fallback reason st = if M.tracing then M.tracel "inv" "Can't handle %a.\n%t\n" d_plainexp exp reason; - invariant_fallback ctx a st exp tv + invariant_fallback ctx st exp tv in (* inverse values for binary operation a `op` b == c *) (* ikind is the type of a for limiting ranges of the operands a, b. The only binops which can have different types for a, b are Shiftlt, Shiftrt (not handled below; don't use ikind to limit b there). *) @@ -696,7 +697,7 @@ struct | Float c -> invert_binary_op c FD.pretty (fun ik -> FD.to_int ik c) (fun fk -> FD.cast_to fk c) | _ -> failwith "unreachable") | Lval x, (Int _ | Float _ | Address _) -> (* meet x with c *) - let update_lval c x c' pretty = refine_lv ctx a st c x c' pretty exp in + let update_lval c x c' pretty = refine_lv ctx st c x c' pretty exp in let t = Cil.unrollType (Cilfacade.typeOfLval x) in (* unroll type to deal with TNamed *) if M.tracing then M.trace "invSpecial" "invariant with Lval %a, c_typed %a, type %a\n" d_lval x VD.pretty c_typed d_type t; begin match c_typed with From 3d2dc96e535061c11c1b5b81c62bf566298bd40f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 11:50:55 +0200 Subject: [PATCH 370/517] Remove gs from refine_lv_fallback signature --- src/analyses/baseInvariant.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index e4074af59e..6a37c06279 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -62,7 +62,7 @@ struct VD.meet old_val new_val with Lattice.Uncomparable -> old_val - let refine_lv_fallback ctx gs st lval value tv = + let refine_lv_fallback ctx st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; let addr = eval_lv ~ctx lval in if (AD.is_top addr) then st @@ -79,7 +79,7 @@ struct old_val in let ask = Analyses.ask_of_ctx ctx in - let state_with_excluded = set ask gs st addr t_lval value ~ctx in + let state_with_excluded = set ask ctx.global st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -89,8 +89,8 @@ struct contra st ) else if VD.is_bot new_val - then set ask gs st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set ask gs st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set ask ctx.global st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set ask ctx.global st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in @@ -241,7 +241,7 @@ struct in match derived_invariant exp tv with | Some (lval, value) -> - refine_lv_fallback ctx ctx.global st lval value tv + refine_lv_fallback ctx 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_exp exp; From 059db8d83696c5883a09dae12026a1f4595bbbbb Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 12:24:59 +0100 Subject: [PATCH 371/517] Inline Binop --- .../apron/affineEqualityDomain.apron.ml | 116 +++++++++--------- 1 file changed, 61 insertions(+), 55 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ecd4bdc1d5..fff6437882 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -59,8 +59,8 @@ struct let dim_add ch m = timing_wrap "dim add" (dim_add ch) m let dim_remove (ch: Apron.Dim.change) m del = - if Array.length ch.dim = 0 || Matrix.is_empty m then - m + if Array.length ch.dim = 0 || Matrix.is_empty m then + m else ( Array.modifyi (fun i x -> x + i) ch.dim; let m' = if not del then let m = Matrix.copy m in Array.fold_left (fun y x -> Matrix.reduce_col_with y x; y) m ch.dim else m in @@ -69,16 +69,16 @@ struct let dim_remove ch m del = timing_wrap "dim remove" (dim_remove ch m) del let change_d t new_env add del = - if Environment.equal t.env new_env then + if Environment.equal t.env new_env then t else match t.d with | None -> bot_env - | Some m -> - let dim_change = - if add then + | Some m -> + let dim_change = + if add then Environment.dimchange t.env new_env - else + else Environment.dimchange new_env t.env in {d = Some (if add then dim_add dim_change m else dim_remove dim_change m del); env = new_env} @@ -158,19 +158,19 @@ struct in let rec convert_texpr = function (*If x is a constant, replace it with its const. val. immediately*) - | Cst x -> + | Cst x -> let of_union = function | Coeff.Interval _ -> failwith "Not a constant" | Scalar Float x -> Mpqf.of_float x | Scalar Mpqf x -> x | Scalar Mpfrf x -> Mpfr.to_mpq x - in + in Vector.set_val zero_vec ((Vector.length zero_vec) - 1) (of_union x) | Var x -> let zero_vec_cp = Vector.copy zero_vec in let entry_only v = Vector.set_val_with v (Environment.dim_of_var t.env x) Mpqf.one; v in begin match t.d with - | Some m -> + | Some m -> let row = Matrix.find_opt (fun r -> Vector.nth r (Environment.dim_of_var t.env x) =: Mpqf.one) m in begin match row with | Some v when is_const_vec v -> @@ -181,18 +181,24 @@ struct | Unop (Neg, e, _, _) -> neg @@ convert_texpr e | Unop (Cast, e, _, _) -> convert_texpr e (*Ignore since casts in apron are used for floating point nums and rounding in contrast to CIL casts*) | Unop (Sqrt, e, _, _) -> raise NotLinear - | Binop (b, e1, e2, _, _) -> - begin match b with - | Add -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (convert_texpr e2); v1 - | Sub -> let v1 = convert_texpr e1 in Vector.map2_with (+:) v1 (neg @@ convert_texpr e2); v1 - | Mul -> - let x1, x2 = convert_texpr e1, convert_texpr e2 in - begin match get_c x1, get_c x2 with - | _, Some c -> Vector.apply_with_c_with ( *:) c x1; x1 - | Some c, _ -> Vector.apply_with_c_with ( *:) c x2; x2 - | _, _ -> raise NotLinear end - | _ -> raise NotLinear end - in + | Binop (Add, e1, e2, _, _) -> + let v1 = convert_texpr e1 in + let v2 = convert_texpr e2 in + Vector.map2_with (+:) v1 v2; v1 + | Binop (Sub, e1, e2, _, _) -> + let v1 = convert_texpr e1 in + let v2 = convert_texpr e2 in + Vector.map2_with (+:) v1 (neg @@ v2); v1 + | Binop (Mul, e1, e2, _, _) -> + let v1 = convert_texpr e1 in + let v2 = convert_texpr e2 in + begin match get_c v1, get_c v2 with + | _, Some c -> Vector.apply_with_c_with ( *:) c v1; v1 + | Some c, _ -> Vector.apply_with_c_with ( *:) c v2; v2 + | _, _ -> raise NotLinear + end + | Binop _ -> raise NotLinear + in try Some (convert_texpr texp) with NotLinear -> None @@ -210,7 +216,7 @@ struct match get_coeff_vec t texpr with | Some v -> begin match get_c v with | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> - let int_val = Mpqf.get_num c in + let int_val = Mpqf.get_num c in Some int_val, Some int_val | _ -> None, None end | _ -> None, None @@ -249,15 +255,15 @@ struct int_arr in let vec_to_constraint arr env = - let vars, _ = Environment.vars env in + let vars, _ = Environment.vars env in let dim_to_str var = - let vl = arr.(Environment.dim_of_var env var) in - let var_str = Var.to_string var in - if Z.equal vl Z.zero then + let vl = arr.(Environment.dim_of_var env var) in + let var_str = Var.to_string var in + if Z.equal vl Z.zero then "" - else if Z.equal vl Z.one then + else if Z.equal vl Z.one then "+" ^ var_str - else if Z.equal vl Z.minus_one then + else if Z.equal vl Z.minus_one then "-" ^ var_str else if Z.lt vl Z.minus_one then Z.to_string vl ^ var_str @@ -265,7 +271,7 @@ struct Format.asprintf "+%s" (Z.to_string vl) ^ var_str in let const_to_str vl = - if Z.equal vl Z.zero then + if Z.equal vl Z.zero then "" else let negated = Z.mul vl Z.minus_one in @@ -273,8 +279,8 @@ struct else Z.to_string negated in let res = (String.concat "" @@ Array.to_list @@ Array.map dim_to_str vars) - ^ (const_to_str arr.(Array.length arr - 1)) ^ "=0" in - if String.starts_with res "+" then + ^ (const_to_str arr.(Array.length arr - 1)) ^ "=0" in + if String.starts_with res "+" then String.sub res 1 (String.length res - 1) else res @@ -309,18 +315,18 @@ struct let meet t1 t2 = let sup_env = Environment.lce t1.env t2.env in let t1, t2 = change_d t1 sup_env true false, change_d t2 sup_env true false in - if is_bot t1 || is_bot t2 then + if is_bot t1 || is_bot t2 then bot () else (* TODO: Why can I be sure that m1 && m2 are all Some here? *) let m1, m2 = Option.get t1.d, Option.get t2.d in - if is_top_env t1 then - {d = Some (dim_add (Environment.dimchange t2.env sup_env) m2); env = sup_env} - else if is_top_env t2 then + if is_top_env t1 then + {d = Some (dim_add (Environment.dimchange t2.env sup_env) m2); env = sup_env} + else if is_top_env t2 then {d = Some (dim_add (Environment.dimchange t1.env sup_env) m1); env = sup_env} else let rref_matr = Matrix.rref_matrix_with (Matrix.copy m1) (Matrix.copy m2) in - if Option.is_none rref_matr then + if Option.is_none rref_matr then bot () else {d = rref_matr; env = sup_env} @@ -339,12 +345,12 @@ struct (* -2: environments are not compatible (a variable has different types in the 2 environements *) (* -1: if env1 is a subset of env2, (OK) *) (* 0: if equality, (OK) *) - (* +1: if env1 is a superset of env2, and +2 otherwise (the lce exists and is a strict superset of both) *) + (* +1: if env1 is a superset of env2, and +2 otherwise (the lce exists and is a strict superset of both) *) false - else if is_bot t1 || is_top_env t2 then + else if is_bot t1 || is_top_env t2 then true - else if is_bot t2 || is_top_env t1 then - false + else if is_bot t2 || is_top_env t1 then + false else let m1, m2 = Option.get t1.d, Option.get t2.d in let m1' = if env_comp = 0 then m1 else dim_add (Environment.dimchange t1.env t2.env) m1 in @@ -402,9 +408,9 @@ struct lin_disjunc new_r (s + 1) new_a new_b | _ -> failwith "Matrix not in rref form" end in - if is_bot a then + if is_bot a then b - else if is_bot b then + else if is_bot b then a else match Option.get a.d, Option.get b.d with @@ -437,15 +443,15 @@ struct let remove_rels_with_var x var env inplace = let j0 = Environment.dim_of_var env var in - if inplace then - (Matrix.reduce_col_with x j0; x) - else + if inplace then + (Matrix.reduce_col_with x j0; x) + else Matrix.reduce_col x j0 let remove_rels_with_var x var env inplace = timing_wrap "remove_rels_with_var" (remove_rels_with_var x var env) inplace let forget_vars t vars = - if is_bot t || is_top_env t || List.is_empty vars then + if is_bot t || is_top_env t || List.is_empty vars then t else let m = Option.get t.d in @@ -526,8 +532,8 @@ struct let t_primed = add_vars t primed_vars in let multi_t = List.fold_left2 (fun t' v_prime (_,v') -> assign_var t' v_prime v') t_primed primed_vars vv's in match multi_t.d with - | Some m when not @@ is_top_env multi_t -> - let replace_col m x y = + | Some m when not @@ is_top_env multi_t -> + let replace_col m x y = let dim_x, dim_y = Environment.dim_of_var multi_t.env x, Environment.dim_of_var multi_t.env y in let col_x = Matrix.get_col m dim_x in Matrix.set_col_with m col_x dim_y @@ -536,9 +542,9 @@ struct let switched_m = List.fold_left2 replace_col m_cp primed_vars assigned_vars in let res = drop_vars {d = Some switched_m; env = multi_t.env} primed_vars true in let x = Option.get res.d in - if Matrix.normalize_with x then - {d = Some x; env = res.env} - else + if Matrix.normalize_with x then + {d = Some x; env = res.env} + else bot () | _ -> t @@ -609,10 +615,10 @@ struct (*Flip the sign of the const. val in coeff vec*) Vector.mapi_with (fun i x -> if Vector.compare_length_with e (i + 1) = 0 then Mpqf.mone *: x else x) e; let res = - if is_bot t then - bot () + if is_bot t then + bot () else - let opt_m = Matrix.rref_vec_with (Matrix.copy @@ Option.get t.d) e in + let opt_m = Matrix.rref_vec_with (Matrix.copy @@ Option.get t.d) e in if Option.is_none opt_m then bot () else {d = opt_m; env = t.env} in meet_tcons_one_var_eq res expr From 54860e74b4fc96b4d6301621df7c3ac139efe20b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 12:27:54 +0100 Subject: [PATCH 372/517] Rename `get_c` to more obvious name --- src/cdomains/apron/affineEqualityDomain.apron.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index fff6437882..82fe8fe6b6 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -141,7 +141,7 @@ struct include ConvenienceOps(Mpqf) (** Get the constant from the vector if it is a constant *) - let get_c v = match Vector.findi ((<>:) Mpqf.zero) v with + let to_constant_opt v = match Vector.findi ((<>:) Mpqf.zero) v with | exception Not_found -> Some Mpqf.zero | i when Vector.compare_length_with v (i + 1) = 0 -> Some (Vector.nth v i) | _ -> None @@ -192,7 +192,7 @@ struct | Binop (Mul, e1, e2, _, _) -> let v1 = convert_texpr e1 in let v2 = convert_texpr e2 in - begin match get_c v1, get_c v2 with + begin match to_constant_opt v1, to_constant_opt v2 with | _, Some c -> Vector.apply_with_c_with ( *:) c v1; v1 | Some c, _ -> Vector.apply_with_c_with ( *:) c v2; v2 | _, _ -> raise NotLinear @@ -214,7 +214,7 @@ struct let bound_texpr t texpr = let texpr = Texpr1.to_expr texpr in match get_coeff_vec t texpr with - | Some v -> begin match get_c v with + | Some v -> begin match to_constant_opt v with | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> let int_val = Mpqf.get_num c in Some int_val, Some int_val @@ -625,7 +625,7 @@ struct in match get_coeff_vec t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with | Some v -> - begin match get_c v, Tcons1.get_typ tcons with + begin match to_constant_opt v, Tcons1.get_typ tcons with | Some c, DISEQ -> check_const (=:) c | Some c, SUP -> check_const (<=:) c | Some c, EQ -> check_const (<>:) c From f0f47987a6eb8f3d7543900610c00ab36375635c Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 12:36:00 +0100 Subject: [PATCH 373/517] Simplify `bound_texpr` --- .../apron/affineEqualityDomain.apron.ml | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 82fe8fe6b6..9ccf2294a3 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -213,20 +213,22 @@ struct let bound_texpr t texpr = let texpr = Texpr1.to_expr texpr in - match get_coeff_vec t texpr with - | Some v -> begin match to_constant_opt v with - | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> - let int_val = Mpqf.get_num c in - Some int_val, Some int_val - | _ -> None, None end + match Option.bind (get_coeff_vec t texpr) to_constant_opt with + | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> + let int_val = Mpqf.get_num c in + Some int_val, Some int_val | _ -> None, None let bound_texpr d texpr1 = let res = bound_texpr d texpr1 in - match res with - | Some min, Some max -> if M.tracing then M.tracel "bounds" "min: %s max: %s" (IntOps.BigIntOps.to_string min) (IntOps.BigIntOps.to_string max); res - | _ -> res + (if M.tracing then + match res with + | Some min, Some max -> M.tracel "bounds" "min: %s max: %s" (IntOps.BigIntOps.to_string min) (IntOps.BigIntOps.to_string max) + | _ -> () + ); + res + let bound_texpr d texpr1 = timing_wrap "bounds calculation" (bound_texpr d) texpr1 end From f4da507d8d69c3d4b6f959aa6154e5695b3c2231 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:39:42 +0200 Subject: [PATCH 374/517] Fix get in comment --- 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 72dfc4af68..ca30a745d8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -903,7 +903,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) - (* | Lval (Mem e, ofs) -> get a gs st (eval_lv ~ctx (Mem e, ofs)) *) + (* | Lval (Mem e, ofs) -> get ~ctx st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) let rec contains_vla (t:typ) = match t with From 44596eb2c63cb4ddfd2f3e9c86110978a2d5c361 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 12:41:14 +0100 Subject: [PATCH 375/517] Shorten function --- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 9ccf2294a3..d2c74a82a2 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -528,7 +528,7 @@ struct res let assign_var_parallel t vv's = - let assigned_vars = List.map (function (v, _) -> v) vv's in + let assigned_vars = List.map fst vv's in let t = add_vars t assigned_vars in let primed_vars = List.init (List.length assigned_vars) (fun i -> Var.of_string (Int.to_string i ^"'")) in (* TODO: we use primed vars in analysis, conflict? *) let t_primed = add_vars t primed_vars in From 8ce2825757d79ef8799c9f438482dc2ba2b826ae Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:45:27 +0200 Subject: [PATCH 376/517] Remove ask and gs from set signature --- src/analyses/base.ml | 4 ++-- src/analyses/baseInvariant.ml | 11 +++++------ 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index ca30a745d8..d23d53b1b4 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1657,7 +1657,7 @@ struct let get_var = get_var let get ~ctx st addrs exp = get ~ctx st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value + let set ~ctx st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value let refine_entire_var = true let map_oldval oldval _ = oldval @@ -2854,7 +2854,7 @@ struct (* all updates happen in ctx with top values *) let get_var = get_var let get ~ctx st addrs exp = get ~ctx st addrs exp - let set a ~ctx gs st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) + let set ~ctx st lval lval_type ?lval_raw value = set ~ctx ~invariant:false st lval lval_type ?lval_raw value (* TODO: should have invariant false? doesn't work with empty cpa then, because meets *) let refine_entire_var = false let map_oldval oldval t_lval = diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 6a37c06279..df93be5896 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -22,7 +22,7 @@ sig val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t - val set: Queries.ask -> ctx:(D.t, G.t, _, V.t) Analyses.ctx -> (V.t -> G.t) -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t + val set: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t val refine_entire_var: bool val map_oldval: VD.t -> typ -> VD.t @@ -78,8 +78,7 @@ struct else old_val in - let ask = Analyses.ask_of_ctx ctx in - let state_with_excluded = set ask ctx.global st addr t_lval value ~ctx in + let state_with_excluded = set st addr t_lval value ~ctx in let value = get ~ctx state_with_excluded addr None in let new_val = apply_invariant ~old_val ~new_val:value in if M.tracing then M.traceu "invariant" "New value is %a\n" VD.pretty new_val; @@ -89,11 +88,11 @@ struct contra st ) else if VD.is_bot new_val - then set ask ctx.global st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) - else set ask ctx.global st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) + then set st addr t_lval value ~ctx (* no *_raw because this is not a real assignment *) + else set st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = - let set' lval v st = set (Analyses.ask_of_ctx ctx) ctx.global st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) From e6752d5d08e966286a804f356b7866398f49314f Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 13:51:13 +0200 Subject: [PATCH 377/517] Replace redundant eval_lv call with AD.singleton --- src/analyses/base.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d23d53b1b4..b77ee3d2fc 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2647,8 +2647,7 @@ struct match addr with | Addr.Addr (v,o) -> if CPA.mem v fun_st.cpa then - let lval = Addr.Mval.to_cil (v,o) in - let address = eval_lv ~ctx lval in + let address = AD.singleton addr in let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; match (CPA.find_opt v (fun_st.cpa)), lval_type with From b6b202ed759eb45d5ef02712a60d9685ab864509 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 12:53:42 +0100 Subject: [PATCH 378/517] Some more making things concise --- src/cdomains/apron/affineEqualityDomain.apron.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index d2c74a82a2..0bb0e856c3 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -152,7 +152,7 @@ struct let open Apron.Texpr1 in let exception NotLinear in let zero_vec = Vector.zero_vec @@ Environment.size t.env + 1 in - let neg v = Vector.map_with (fun x -> Mpqf.mone *: x) v; v in + let neg v = Vector.map_with (( *:) Mpqf.mone) v; v in let is_const_vec v = Vector.compare_length_with (Vector.filteri (fun i x -> (*Inefficient*) Vector.compare_length_with v (i + 1) > 0 && x <>: Mpqf.zero) v) 1 = 0 in @@ -250,8 +250,8 @@ struct let row = Array.copy @@ Vector.to_array row in let mpqf_of_z x = Mpqf.of_mpz @@ Z_mlgmpidl.mpzf_of_z x in let lcm = mpqf_of_z @@ Array.fold_left (fun x y -> Z.lcm x (Mpqf.get_den y)) Z.one row in - Array.modify (fun x -> x *: lcm) row; - let int_arr = Array.map (fun x -> Mpqf.get_num x) row in + Array.modify (( *:) lcm) row; + let int_arr = Array.map Mpqf.get_num row in let div = Array.fold_left Z.gcd int_arr.(0) int_arr in Array.modify (fun x -> Z.div x div) int_arr; int_arr @@ -379,12 +379,12 @@ struct let col_a, col_b = Vector.keep_vals col_a max, Vector.keep_vals col_b max in if Vector.equal col_a col_b then (a, b, max) else let a_rev, b_rev = (Vector.rev_with col_a; col_a), (Vector.rev_with col_b; col_b) in - let i = Vector.find2i (fun x y -> x <>: y) a_rev b_rev in + let i = Vector.find2i (<>:) a_rev b_rev in let (x, y) = Vector.nth a_rev i, Vector.nth b_rev i in let r, diff = Vector.length a_rev - (i + 1), x -: y in let a_r, b_r = Matrix.get_row a r, Matrix.get_row b r in let sub_col = - Vector.map2_with (fun x y -> x -: y) a_rev b_rev; + Vector.map2_with (-:) a_rev b_rev; Vector.rev_with a_rev; a_rev in @@ -581,8 +581,8 @@ struct forget_vars res [var] let substitute_exp t var exp ov = - let res = substitute_exp t var exp ov - in if M.tracing then M.tracel "ops" "Substitute_expr t: \n %s \n var: %s \n exp: %a \n -> \n %s\n" (show t) (Var.to_string var) d_exp exp (show res); + let res = substitute_exp t var exp ov in + if M.tracing then M.tracel "ops" "Substitute_expr t: \n %s \n var: %s \n exp: %a \n -> \n %s\n" (show t) (Var.to_string var) d_exp exp (show res); res let substitute_exp t var exp ov = timing_wrap "substitution" (substitute_exp t var exp) ov From f0870881960a97a7d3afdd0f1b2f253f1c416794 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:00:30 +0100 Subject: [PATCH 379/517] Rename var to `coeff` --- src/cdomains/apron/affineEqualityDomain.apron.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 0bb0e856c3..5630888b59 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -259,18 +259,18 @@ struct let vec_to_constraint arr env = let vars, _ = Environment.vars env in let dim_to_str var = - let vl = arr.(Environment.dim_of_var env var) in + let coeff = arr.(Environment.dim_of_var env var) in let var_str = Var.to_string var in - if Z.equal vl Z.zero then + if Z.equal coeff Z.zero then "" - else if Z.equal vl Z.one then + else if Z.equal coeff Z.one then "+" ^ var_str - else if Z.equal vl Z.minus_one then + else if Z.equal coeff Z.minus_one then "-" ^ var_str - else if Z.lt vl Z.minus_one then - Z.to_string vl ^ var_str + else if Z.lt coeff Z.minus_one then + Z.to_string coeff ^ var_str else - Format.asprintf "+%s" (Z.to_string vl) ^ var_str + Format.asprintf "+%s" (Z.to_string coeff) ^ var_str in let const_to_str vl = if Z.equal vl Z.zero then From 0dcf8ce52ca8bd4992378ba2072a156ef68a415f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:04:50 +0100 Subject: [PATCH 380/517] Make show more concise --- .../apron/affineEqualityDomain.apron.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 5630888b59..7d01130480 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -260,23 +260,22 @@ struct let vars, _ = Environment.vars env in let dim_to_str var = let coeff = arr.(Environment.dim_of_var env var) in - let var_str = Var.to_string var in if Z.equal coeff Z.zero then "" - else if Z.equal coeff Z.one then - "+" ^ var_str - else if Z.equal coeff Z.minus_one then - "-" ^ var_str - else if Z.lt coeff Z.minus_one then - Z.to_string coeff ^ var_str else - Format.asprintf "+%s" (Z.to_string coeff) ^ var_str + let coeff_str = + if Z.equal coeff Z.one then "+" + else if Z.equal coeff Z.minus_one then "-" + else if Z.lt coeff Z.minus_one then Z.to_string coeff + else Format.asprintf "+%s" (Z.to_string coeff) + in + coeff_str ^ Var.to_string var in let const_to_str vl = if Z.equal vl Z.zero then "" else - let negated = Z.mul vl Z.minus_one in + let negated = Z.neg vl in if Z.gt negated Z.zero then "+" ^ Z.to_string negated else Z.to_string negated in From 399fb8c4c8fc31d91869e4851056ce0be9010b8f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:11:27 +0100 Subject: [PATCH 381/517] Remove code obscuring imperative nature --- .../apron/affineEqualityDomain.apron.ml | 36 ++++++++++--------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 7d01130480..2ec5dabf61 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -376,23 +376,25 @@ struct let case_three a b col_a col_b max = let col_a, col_b = Vector.copy col_a, Vector.copy col_b in let col_a, col_b = Vector.keep_vals col_a max, Vector.keep_vals col_b max in - if Vector.equal col_a col_b then (a, b, max) else - let a_rev, b_rev = (Vector.rev_with col_a; col_a), (Vector.rev_with col_b; col_b) in - let i = Vector.find2i (<>:) a_rev b_rev in - let (x, y) = Vector.nth a_rev i, Vector.nth b_rev i in - let r, diff = Vector.length a_rev - (i + 1), x -: y in - let a_r, b_r = Matrix.get_row a r, Matrix.get_row b r in - let sub_col = - Vector.map2_with (-:) a_rev b_rev; - Vector.rev_with a_rev; - a_rev - in - let multiply_by_t m t = - Matrix.map2i_with (fun i' x c -> if i' <= max then (let beta = c /: diff in - Vector.map2_with (fun u j -> u -: (beta *: j)) x t); x) m sub_col; - m - in - Matrix.remove_row (multiply_by_t a a_r) r, Matrix.remove_row (multiply_by_t b b_r) r, (max - 1) + if Vector.equal col_a col_b then + (a, b, max) + else + ( + Vector.rev_with col_a; + Vector.rev_with col_b; + let i = Vector.find2i (<>:) col_a col_b in + let (x, y) = Vector.nth col_a i, Vector.nth col_b i in + let r, diff = Vector.length col_a - (i + 1), x -: y in + let a_r, b_r = Matrix.get_row a r, Matrix.get_row b r in + Vector.map2_with (-:) col_a col_b; + Vector.rev_with col_a; + let multiply_by_t m t = + Matrix.map2i_with (fun i' x c -> if i' <= max then (let beta = c /: diff in + Vector.map2_with (fun u j -> u -: (beta *: j)) x t); x) m col_a; + m + in + Matrix.remove_row (multiply_by_t a a_r) r, Matrix.remove_row (multiply_by_t b b_r) r, (max - 1) + ) in let col_a, col_b = Matrix.get_col a s, Matrix.get_col b s in let nth_zero v i = match Vector.nth v i with From 63094e0e1fcee316a2cd8b299dd2699e3e27a193 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:22:08 +0100 Subject: [PATCH 382/517] Make use of `uncurry` --- src/cdomains/vectorMatrix.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/cdomains/vectorMatrix.ml b/src/cdomains/vectorMatrix.ml index d652145032..1dd684a4c0 100644 --- a/src/cdomains/vectorMatrix.ml +++ b/src/cdomains/vectorMatrix.ml @@ -251,12 +251,14 @@ module ArrayVector: AbstractVector = let nth = Array.get - let map2i f v1 v2 = let f' i (v'1, v'2) = f i v'1 v'2 in Array.mapi f' (Array.combine v1 v2) (* TODO: iter2i? *) + let map2i f v1 v2 = + let f' i = uncurry (f i) in + Array.mapi f' (Array.combine v1 v2) (* TODO: iter2i? *) let map2i_with f v1 v2 = Array.iter2i (fun i x y -> v1.(i) <- f i x y) v1 v2 - let find2i f v1 v2 = let f' (v'1, v'2) = f v'1 v'2 in - Array.findi f' (Array.combine v1 v2) (* TODO: iter2i? *) + let find2i f v1 v2 = + Array.findi (uncurry f) (Array.combine v1 v2) (* TODO: iter2i? *) let to_array v = v From 79b79d841e17fdbd273a458a0c718c78fa11a1c3 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:26:30 +0100 Subject: [PATCH 383/517] Simplify `meet_tcons_one_var_eq` --- .../apron/affineEqualityDomain.apron.ml | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 2ec5dabf61..e05400e674 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -601,16 +601,21 @@ struct | None -> overflow_res res | Some v -> let ik = Cilfacade.get_ikind v.vtype in - match Bounds.bound_texpr res (Convert.texpr1_of_cil_exp res res.env (Lval (Cil.var v)) true) with - | Some _, Some _ when not (Cil.isSigned ik) -> raise NotRefinable (* TODO: unsigned w/o bounds handled differently? *) - | Some min, Some max -> - assert (Z.equal min max); (* other bounds impossible in affeq *) - let (min_ik, max_ik) = IntDomain.Size.range ik in - if Z.compare min min_ik < 0 || Z.compare max max_ik > 0 then - if IntDomain.should_ignore_overflow ik then bot () else raise NotRefinable - else res - | exception Convert.Unsupported_CilExp _ - | _, _ -> overflow_res res + if not (Cil.isSigned ik) then + raise NotRefinable (* TODO: unsigned w/o bounds handled differently? *) + else + match Bounds.bound_texpr res (Convert.texpr1_of_cil_exp res res.env (Lval (Cil.var v)) true) with + | Some min, Some max -> + assert (Z.equal min max); (* other bounds impossible in affeq *) + let (min_ik, max_ik) = IntDomain.Size.range ik in + if Z.compare min min_ik < 0 || Z.compare max max_ik > 0 then + if IntDomain.should_ignore_overflow ik then + bot () + else + raise NotRefinable + else res + | exception Convert.Unsupported_CilExp _ + | _ -> overflow_res res let meet_tcons t tcons expr = let check_const cmp c = if cmp c Mpqf.zero then bot_env else t in From 097156f2bac7560bd92c5d4aba6babbfb6c6c152 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:27:51 +0100 Subject: [PATCH 384/517] Replace Z.compare with bespoke functions --- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index e05400e674..87accda1b4 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -608,7 +608,7 @@ struct | Some min, Some max -> assert (Z.equal min max); (* other bounds impossible in affeq *) let (min_ik, max_ik) = IntDomain.Size.range ik in - if Z.compare min min_ik < 0 || Z.compare max max_ik > 0 then + if Z.lt min min_ik || Z.gt max max_ik then if IntDomain.should_ignore_overflow ik then bot () else From 0c0f3943c1d324e9e509e3edd4493592e17be8de Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 28 Dec 2023 13:40:00 +0100 Subject: [PATCH 385/517] Some reordering & make `get_coeff_vec` more efficient --- .../apron/affineEqualityDomain.apron.ml | 54 ++++++++++--------- 1 file changed, 29 insertions(+), 25 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 87accda1b4..6f6f7c1280 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -152,7 +152,7 @@ struct let open Apron.Texpr1 in let exception NotLinear in let zero_vec = Vector.zero_vec @@ Environment.size t.env + 1 in - let neg v = Vector.map_with (( *:) Mpqf.mone) v; v in + let neg v = Vector.map_with Mpqf.neg v; v in let is_const_vec v = Vector.compare_length_with (Vector.filteri (fun i x -> (*Inefficient*) Vector.compare_length_with v (i + 1) > 0 && x <>: Mpqf.zero) v) 1 = 0 in @@ -485,7 +485,7 @@ struct let assign_invertible_rels x var b env = timing_wrap "assign_invertible" (assign_invertible_rels x var b) env in let assign_uninvertible_rel x var b env = let b_length = Vector.length b in - Vector.mapi_with (fun i z -> if i < b_length - 1 then Mpqf.mone *: z else z) b; + Vector.mapi_with (fun i z -> if i < b_length - 1 then Mpqf.neg z else z) b; Vector.set_val_with b (Environment.dim_of_var env var) Mpqf.one; let opt_m = Matrix.rref_vec_with x b in if Option.is_none opt_m then bot () else @@ -620,8 +620,9 @@ struct let meet_tcons t tcons expr = let check_const cmp c = if cmp c Mpqf.zero then bot_env else t in let meet_vec e = - (*Flip the sign of the const. val in coeff vec*) - Vector.mapi_with (fun i x -> if Vector.compare_length_with e (i + 1) = 0 then Mpqf.mone *: x else x) e; + (* Flip the sign of the const. val in coeff vec *) + let coeff = Vector.nth e (Vector.length e - 1) in + Vector.set_val_with e (Vector.length e - 1) (Mpqf.neg coeff); let res = if is_bot t then bot () @@ -631,27 +632,30 @@ struct in meet_tcons_one_var_eq res expr in - match get_coeff_vec t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with - | Some v -> - begin match to_constant_opt v, Tcons1.get_typ tcons with - | Some c, DISEQ -> check_const (=:) c - | Some c, SUP -> check_const (<=:) c - | Some c, EQ -> check_const (<>:) c - | Some c, SUPEQ -> check_const (<:) c - | None, DISEQ - | None, SUP -> - begin match meet_vec v with - | exception NotRefinable -> t - | res -> if equal res t then bot_env else t - end - | None, EQ -> - begin match meet_vec v with - | exception NotRefinable -> t - | res -> if is_bot res then bot_env else res - end - | _, _ -> t - end - | None -> t + try + match get_coeff_vec t (Texpr1.to_expr @@ Tcons1.get_texpr1 tcons) with + | Some v -> + begin match to_constant_opt v, Tcons1.get_typ tcons with + | Some c, DISEQ -> check_const (=:) c + | Some c, SUP -> check_const (<=:) c + | Some c, EQ -> check_const (<>:) c + | Some c, SUPEQ -> check_const (<:) c + | None, DISEQ + | None, SUP -> + if equal (meet_vec v) t then + bot_env + else + t + | None, EQ -> + let res = meet_vec v in + if is_bot res then + bot_env + else + res + | _ -> t + end + | None -> t + with NotRefinable -> t let meet_tcons t tcons expr = timing_wrap "meet_tcons" (meet_tcons t tcons) expr From 06a2d5488c4e64d2890e6336b4085ece6cd32b93 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 28 Dec 2023 14:42:33 +0200 Subject: [PATCH 386/517] Simplify matches in combine_st --- src/analyses/base.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index b77ee3d2fc..430a1394db 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2645,23 +2645,23 @@ struct let combine_st ctx (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = AD.fold (fun addr (st: store) -> match addr with - | Addr.Addr (v,o) -> - if CPA.mem v fun_st.cpa then - let address = AD.singleton addr in + | Addr.Addr (v,o) when CPA.mem v fun_st.cpa -> + begin let lval_type = Addr.type_of addr in if M.tracing then M.trace "taintPC" "updating %a; type: %a\n" Addr.Mval.pretty (v,o) d_type lval_type; - match (CPA.find_opt v (fun_st.cpa)), lval_type with - | None, _ -> st + match CPA.find_opt v (fun_st.cpa) with + | None -> st (* partitioned arrays cannot be copied by individual lvalues, so if tainted just copy the whole callee value for the array variable *) - | Some (Array a), _ when (CArrays.domain_of_t a) = PartitionedDomain -> {st with cpa = CPA.add v (Array a) st.cpa} + | Some (Array a) when CArrays.domain_of_t a = PartitionedDomain -> {st with cpa = CPA.add v (Array a) st.cpa} (* "get" returned "unknown" when applied to a void type, so special case void types. This caused problems with some sv-comps (e.g. regtest 64 11) *) - | Some voidVal, TVoid _ -> {st with cpa = CPA.add v voidVal st.cpa} - | _, _ -> begin + | Some voidVal when Addr.type_of addr = voidType -> {st with cpa = CPA.add v voidVal st.cpa} + | _ -> + begin + let address = AD.singleton addr in let new_val = get ~ctx fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a\n\n" VD.pretty new_val; let st' = set_savetop ~ctx st address lval_type new_val in - let partDep = Dep.find_opt v fun_st.deps in - match partDep with + match Dep.find_opt v fun_st.deps with | None -> st' (* if a var partitions an array, all cpa-info for arrays it may partition are added from callee to caller *) | Some deps -> {st' with cpa = (Dep.VarSet.fold (fun v accCPA -> let val_opt = CPA.find_opt v fun_st.cpa in @@ -2669,7 +2669,7 @@ struct | None -> accCPA | Some new_val -> CPA.add v new_val accCPA ) deps st'.cpa)} end - else st + end | _ -> st ) tainted_lvs local_st From 8ac5fadb08ec258021c8a98b00faca549c69a95b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 28 Dec 2023 14:41:48 +0200 Subject: [PATCH 387/517] 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 388/517] 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 389/517] 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 390/517] 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 391/517] 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 392/517] 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 393/517] 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 394/517] 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 395/517] 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 396/517] 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 397/517] 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 398/517] 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)) From b23dea350b53733c6fc4d7b60f4c9f1cb9f6adc7 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 3 Jan 2024 20:16:08 +0200 Subject: [PATCH 399/517] Revert "Remove st from eval_rv signature" This reverts commit 77c6f208d5a7f9ba6e66b03e7ac4eb25db59678b. --- src/analyses/base.ml | 94 +++++++++++++++++------------------ src/analyses/baseInvariant.ml | 12 ++--- 2 files changed, 53 insertions(+), 53 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 430a1394db..86d45720e4 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1078,7 +1078,7 @@ struct (* run eval_rv from above, but change bot to top to be sound for programs with undefined behavior. *) (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) - let eval_rv ~ctx (exp:exp): value = + let eval_rv ~ctx (st: store) (exp:exp): value = try let r = eval_rv ~ctx exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; @@ -1128,7 +1128,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx exp with + match eval_rv ~ctx st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None @@ -1144,14 +1144,14 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ~ctx e = + let eval_rv_address ~ctx st e = (* no way to do eval_rv with expected type, so filter expression beforehand *) match Cilfacade.typeOf e with | t when Cil.isArithmeticType t -> (* definitely not address *) VD.top_value t | exception Cilfacade.TypeOfError _ (* something weird, might be address *) | _ -> - eval_rv ~ctx e + eval_rv ~ctx st e (* interpreter end *) @@ -1243,7 +1243,7 @@ struct | Q.EvalFunvar e -> eval_funvar ctx e | Q.EvalJumpBuf e -> - begin match eval_rv_address ~ctx e with + begin match eval_rv_address ~ctx ctx.local e with | Address jmp_buf -> if AD.mem Addr.UnknownPtr jmp_buf then M.warn ~category:Imprecise "Jump buffer %a may contain unknown pointers." d_exp e; @@ -1267,12 +1267,12 @@ struct query_evalint ~ctx e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in - match eval_rv ~ctx e with + match eval_rv ~ctx ctx.local e with | MutexAttr a -> a | v -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1287,9 +1287,9 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx e + eval_rv ~ctx ctx.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address ~ctx e in + let p = eval_rv_address ~ctx ctx.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> @@ -1323,14 +1323,14 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Address a -> a | Bot -> Queries.Result.bot q (* TODO: remove *) | Int i -> AD.of_int i | _ -> Queries.Result.top q end | Q.EvalThread e -> begin - let v = eval_rv ~ctx e in + let v = eval_rv ~ctx ctx.local e in (* ignore (Pretty.eprintf "evalthread %a (%a): %a" d_exp e d_plainexp e VD.pretty v); *) match v with | Thread a -> a @@ -1338,7 +1338,7 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> @@ -1358,7 +1358,7 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with | Top -> Queries.Result.top q | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a when AD.is_top a || AD.mem Addr.UnknownPtr a -> @@ -1368,7 +1368,7 @@ struct | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address ~ctx e with + match eval_rv_address ~ctx ctx.local e with (* exactly one string in the set (works for assignments of string constants) *) | Address a when List.compare_length_with (AD.to_string a) 1 = 0 -> (* exactly one string *) `Lifted (List.hd (AD.to_string a)) @@ -1661,7 +1661,7 @@ struct let refine_entire_var = true let map_oldval oldval _ = oldval - let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx (Lval lval) + let eval_rv_lval_refine ~ctx st exp lval = eval_rv ~ctx st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1721,7 +1721,7 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx rval in + let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in let lval_val = eval_lv ~ctx lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) @@ -1777,7 +1777,7 @@ struct let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx exp in + let valu = eval_rv ~ctx ctx.local exp in let refine () = let res = invariant ctx ctx.local exp tv in if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a\n" d_exp exp Queries.ES.pretty (ctx.ask (Queries.EqualSet exp)); @@ -1851,7 +1851,7 @@ struct | TVoid _ -> M.warn ~category:M.Category.Program "Returning a value from a void function"; assert false | ret -> ret in - let rv = eval_rv ~ctx exp in + let rv = eval_rv ~ctx ctx.local exp in let st' = set ~ctx ~t_override nst (return_var ()) t_override rv in match ThreadId.get_current ask with | `Lifted tid when ThreadReturn.is_current ask -> @@ -1867,8 +1867,8 @@ struct ctx.local else let lval = eval_lv ~ctx (Var v, NoOffset) in - let current_value = eval_rv ~ctx (Lval (Var v, NoOffset)) in - let new_value = VD.update_array_lengths (eval_rv ~ctx) current_value v.vtype in + let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value (************************************************************************** @@ -1876,18 +1876,18 @@ struct **************************************************************************) (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) - let collect_funargs ~ctx ?(warn=false) (exps: exp list) = + let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps - let collect_invalidate ~deep ~ctx ?(warn=false) (exps: exp list) = + let collect_invalidate ~deep ~ctx ?(warn=false) (st:store) (exps: exp list) = if deep then - collect_funargs ~ctx ~warn exps + collect_funargs ~ctx ~warn st exps else ( - let mpt e = match eval_rv_address ~ctx e with + let mpt e = match eval_rv_address ~ctx st e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in @@ -1908,7 +1908,7 @@ struct (* We define the function that invalidates all the values that an address * expression e may point to *) let invalidate_exp exps = - let args = collect_invalidate ~deep ~ctx ~warn:true exps in + let args = collect_invalidate ~deep ~ctx ~warn:true st exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -1928,7 +1928,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let st: store = ctx.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx) args in + let vals = List.map (eval_rv ~ctx st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2022,8 +2022,8 @@ struct Need this to not have memmove spawn in SV-COMP. *) let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Spawn; deep = true } args in - let shallow_flist = collect_invalidate ~deep:false ~ctx shallow_args in - let deep_flist = collect_invalidate ~deep:true ~ctx deep_args in + let shallow_flist = collect_invalidate ~deep:false ~ctx ctx.local shallow_args in + let deep_flist = collect_invalidate ~deep:true ~ctx ctx.local deep_args in let flist = shallow_flist @ deep_flist in let addrs = List.concat_map AD.to_var_may flist in if addrs <> [] then M.debug ~category:Analyzer "Spawning non-unique functions from unknown function: %a" (d_list ", " CilType.Varinfo.pretty) addrs; @@ -2072,7 +2072,7 @@ struct | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address ~ctx ptr with + match eval_rv_address ~ctx ctx.local ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; @@ -2187,7 +2187,7 @@ struct (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then let src_cast_lval = mkMem ~addr:(Cilfacade.mkCast ~e:src ~newt:(TPtr (dest_typ, []))) ~off:NoOffset in - eval_rv ~ctx (Lval src_cast_lval) + eval_rv ~ctx st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in @@ -2196,7 +2196,7 @@ struct let eval_n = function (* if only n characters of a given string are needed, evaluate expression n to an integer option *) | Some n -> - begin match eval_rv ~ctx n with + begin match eval_rv ~ctx st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2222,10 +2222,10 @@ struct | _ -> raise (Failure "String function: not an address") in let string_manipulation s1 s2 lv all op_addr op_array = - let s1_v = eval_rv ~ctx s1 in + let s1_v = eval_rv ~ctx 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 ~ctx s2 in + let s2_v = eval_rv ~ctx 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 *) @@ -2295,7 +2295,7 @@ struct let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> (* TODO: check count *) - let eval_ch = eval_rv ~ctx ch in + let eval_ch = eval_rv ~ctx st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2320,7 +2320,7 @@ struct | Some lv_val -> let dest_a = eval_lv ~ctx lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx s in + let v = eval_rv ~ctx st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2365,7 +2365,7 @@ struct begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with | `Lifted tid -> ( - let rv = eval_rv ~ctx exp in + let rv = eval_rv ~ctx ctx.local exp in ctx.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) @@ -2387,7 +2387,7 @@ struct let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in let dest_a = eval_lv ~ctx dst_lval in - match eval_rv ~ctx mtyp with + match eval_rv ~ctx st mtyp with | Int x -> begin match ID.to_int x with @@ -2406,22 +2406,22 @@ struct (**Floating point classification and trigonometric functions defined in c99*) | Math { fun_args; }, _ -> let apply_unary fk float_fun x = - let eval_x = eval_rv ~ctx x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Float float_x -> float_fun (FD.cast_to fk float_x) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_binary fk float_fun x y = - let eval_x = eval_rv ~ctx x in - let eval_y = eval_rv ~ctx y in + let eval_x = eval_rv ~ctx st x in + let eval_y = eval_rv ~ctx st y in begin match eval_x, eval_y with | Float float_x, Float float_y -> float_fun (FD.cast_to fk float_x) (FD.cast_to fk float_y) | _ -> failwith ("non-floating-point argument in call to function "^f.vname) end in let apply_abs ik x = - let eval_x = eval_rv ~ctx x in + let eval_x = eval_rv ~ctx st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2481,10 +2481,10 @@ struct | ThreadJoin { thread = id; ret_var }, _ -> let st' = (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) - match eval_rv ~ctx ret_var with + match eval_rv ~ctx st ret_var with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx id with + begin match eval_rv ~ctx st id with | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx 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 @@ -2553,7 +2553,7 @@ struct check_invalid_mem_dealloc ctx f p; begin match lv with | Some lv -> - let p_rv = eval_rv ~ctx p in + let p_rv = eval_rv ~ctx st p in let p_addr = match p_rv with | Address a -> a @@ -2587,7 +2587,7 @@ struct st | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine | Setjmp { env }, _ -> - let st' = match eval_rv ~ctx env with + let st' = match eval_rv ~ctx st env with | Address jmp_buf -> let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (ctx.prev_node, ctx.control_context ())), false) in let r = set ~ctx st jmp_buf (Cilfacade.typeOf env) value in @@ -2617,7 +2617,7 @@ struct M.warn ~category:Program "Arguments to longjmp are strange!"; rv in - let rv = ensure_not_zero @@ eval_rv ~ctx value in + let rv = ensure_not_zero @@ eval_rv ~ctx ctx.local value in let t = Cilfacade.typeOf value in set ~ctx ~t_override:t ctx.local (AD.of_var !longjmp_return) t rv (* Not raising Deadcode here, deadcode is raised at a higher level! *) | Rand, _ -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index df93be5896..4d51895683 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -15,8 +15,8 @@ sig module V: Analyses.SpecSysVar module G: Lattice.S - val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t - val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> exp -> VD.t + val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t + val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t @@ -147,7 +147,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x AD.pretty n; - match eval_rv_address ~ctx (Lval x) with + match eval_rv_address ~ctx st (Lval x) with | Address a when AD.is_definite n -> Some (x, Address (AD.diff a n)) | Top when AD.is_null n -> @@ -211,12 +211,12 @@ struct let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) match exp with (* Since we handle not only equalities, the order is important *) - | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx rval)) tv + | BinOp(op, Lval x, rval, typ) -> helper op x (VD.cast (Cilfacade.typeOfLval x) (eval_rv ~ctx st rval)) tv | BinOp(op, rval, Lval x, typ) -> derived_invariant (BinOp(switchedOp op, Lval x, rval, typ)) tv | BinOp(op, CastE (t1, c1), CastE (t2, c2), t) when (op = Eq || op = Ne) && typeSig t1 = typeSig t2 && VD.is_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_safe_cast t2 (Cilfacade.typeOf c2) -> derived_invariant (BinOp (op, c1, c2, t)) tv | BinOp(op, CastE (TInt (ik, _) as t1, Lval x), rval, typ) -> - (match eval_rv ~ctx (Lval x) with + (match eval_rv ~ctx st (Lval x) with | Int v -> (* This is tricky: It it is not sufficient to check that ID.cast_to_ik v = v * If there is one domain that knows this to be true and the other does not, we @@ -555,7 +555,7 @@ struct a, b with FloatDomain.ArithmeticOnFloatBot _ -> raise Analyses.Deadcode in - let eval e st = eval_rv ~ctx e in + let eval e st = eval_rv ~ctx st e in let eval_bool e st = match eval e st with Int i -> ID.to_bool i | _ -> None in let unroll_fk_of_exp e = match unrollType (Cilfacade.typeOf e) with From 7c50968b1487c8c72037eaf11b598388790cbf50 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 13:39:44 +0200 Subject: [PATCH 400/517] Add st back everywhere (as for now) --- src/analyses/base.ml | 181 +++++++++++++++++----------------- src/analyses/baseInvariant.ml | 10 +- 2 files changed, 96 insertions(+), 95 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 86d45720e4..63f516c82c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -680,14 +680,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv ~(ctx: _ ctx) (exp:exp): value = + let rec eval_rv ~(ctx: _ ctx) (st: store) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a\n" d_exp exp; let r = (* we have a special expression that should evaluate to top ... *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_ask_evalint ~ctx exp + eval_rv_ask_evalint ~ctx st exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a\n" d_exp exp VD.pretty r; r @@ -696,8 +696,8 @@ struct Base itself also answers EvalInt, so recursion goes indirectly through queries. This allows every subexpression to also meet more precise value from other analyses. Non-integer expression just delegate to next eval_rv function. *) - and eval_rv_ask_evalint ~ctx exp = - let eval_next () = eval_rv_no_ask_evalint ~ctx exp in + and eval_rv_ask_evalint ~ctx st exp = + let eval_next () = eval_rv_no_ask_evalint ~ctx st exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a\n" d_exp exp; let r:value = match Cilfacade.typeOf exp with @@ -720,25 +720,24 @@ struct (** Evaluate expression without EvalInt query on outermost expression. This is used by base responding to EvalInt to immediately directly avoid EvalInt query cycle, which would return top. Recursive [eval_rv] calls on subexpressions still go through [eval_rv_ask_evalint]. *) - and eval_rv_no_ask_evalint ~ctx exp = - eval_rv_base ~ctx exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) + and eval_rv_no_ask_evalint ~ctx st exp = + eval_rv_base ~ctx st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up ~ctx exp = + and eval_rv_back_up ~ctx st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv ~ctx exp + eval_rv ~ctx st exp else ( (* duplicate unknown_exp check from eval_rv since we're bypassing it now *) if exp = MyCFG.unknown_exp then VD.top () else - eval_rv_base ~ctx exp (* bypass all queries *) + eval_rv_base ~ctx st exp (* bypass all queries *) ) (** Evaluate expression structurally by base. This handles constants directly and variables using CPA. Subexpressions delegate to [eval_rv], which may use queries on them. *) - and eval_rv_base ~ctx (exp:exp): value = - let st = ctx.local in + and eval_rv_base ~ctx (st: store) (exp:exp): value = let eval_rv = eval_rv_back_up in if M.tracing then M.traceli "evalint" "base eval_rv_base %a\n" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -760,7 +759,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv ~ctx (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~ctx st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) | Const (CInt (num,ikind,str)) -> (match str with Some x -> M.tracel "casto" "CInt (%s, %a, %s)\n" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -780,8 +779,8 @@ struct (* Binary operators *) (* Eq/Ne when both values are equal and casted to the same type *) | BinOp ((Eq | Ne) as op, (CastE (t1, e1) as c1), (CastE (t2, e2) as c2), typ) when typeSig t1 = typeSig t2 -> - let a1 = eval_rv ~ctx e1 in - let a2 = eval_rv ~ctx e2 in + let a1 = eval_rv ~ctx st e1 in + let a2 = eval_rv ~ctx st e2 in let extra_is_safe = match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true @@ -790,7 +789,7 @@ struct in let (e1, e2) = binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 in (* re-evaluate e1 and e2 in evalbinop because might be with cast *) - evalbinop ~ctx op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~ctx st op ~e1 ~t1 ~e2 ~t2 typ | BinOp (LOr, e1, e2, typ) as exp -> let open GobOption.Syntax in (* split nested LOr Eqs to equality pairs, if possible *) @@ -823,8 +822,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - let v = eval_rv ~ctx e in (* value of common exp *) - let vs = List.map (eval_rv ~ctx) es in (* values of other sides *) + let v = eval_rv ~ctx st e in (* value of common exp *) + let vs = List.map (eval_rv ~ctx st) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -866,25 +865,25 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop ~ctx LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~ctx st LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop ~ctx op ~e1 ~e2 typ + evalbinop ~ctx st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv ~ctx arg1 in + let a1 = eval_rv ~ctx st arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv ~ctx lval) + | AddrOf lval -> Address (eval_lv ~ctx st lval) (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - Address (AD.map array_start (eval_lv ~ctx lval)) - | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx (Const (CStr (x,e))) (* TODO safe? *) + Address (AD.map array_start (eval_lv ~ctx st lval)) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv ~ctx exp in + let v = eval_rv ~ctx st exp in VD.cast ~torg:(Cilfacade.typeOf exp) t v | SizeOf _ | Real _ @@ -902,7 +901,7 @@ struct and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = match lv with - | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx (Var v, ofs)) (Some exp) + | (Var v, ofs) -> get ~ctx st (eval_lv ~ctx st (Var v, ofs)) (Some exp) (* | Lval (Mem e, ofs) -> get ~ctx st (eval_lv ~ctx (Mem e, ofs)) *) | (Mem e, ofs) -> (*M.tracel "cast" "Deref: lval: %a\n" d_plainlval lv;*) @@ -915,7 +914,7 @@ struct in let b = Mem e, NoOffset in (* base pointer *) let t = Cilfacade.typeOfLval b in (* static type of base *) - let p = eval_lv ~ctx b in (* abstract base addresses *) + let p = eval_lv ~ctx st b in (* abstract base addresses *) (* pre VLA: *) (* let cast_ok = function Addr a -> sizeOf t <= sizeOf (get_type_addr a) | _ -> false in *) let cast_ok a = @@ -953,20 +952,20 @@ struct in let v' = VD.cast t v in (* cast to the expected type (the abstract type might be something other than t since we don't change addresses upon casts!) *) if M.tracing then M.tracel "cast" "Ptr-Deref: cast %a to %a = %a!\n" VD.pretty v d_type t VD.pretty v'; - let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (fun x -> get ~ctx st x (Some exp)) v' (convert_offset ~ctx st ofs) (Some exp) None t in (* handle offset *) v' in AD.fold (fun a acc -> VD.join acc (lookup_with_offs a)) p (VD.bot ()) - and evalbinop ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = - evalbinop_mustbeequal ~ctx op ~e1 ?t1 ~e2 ?t2 t + and evalbinop ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~ctx st op ~e1 ?t1 ~e2 ?t2 t (** Evaluate BinOp using MustBeEqual query as fallback. *) - and evalbinop_mustbeequal ~ctx (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + and evalbinop_mustbeequal ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) let ask = Analyses.ask_of_ctx ctx in - let a1 = eval_rv ~ctx e1 in - let a2 = eval_rv ~ctx e2 in + let a1 = eval_rv ~ctx st e1 in + let a2 = eval_rv ~ctx st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in let r = evalbinop_base ask op t1 a1 t2 a2 t in @@ -1005,48 +1004,48 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv ~ctx (exp:exp): AD.t = + and eval_fv ~ctx st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv ~ctx lval - | _ -> eval_tv ~ctx exp + | Lval lval -> eval_lv ~ctx st lval + | _ -> eval_tv ~ctx st exp (* Used also for thread creation: *) - and eval_tv ~ctx (exp:exp): AD.t = - match eval_rv ~ctx exp with + and eval_tv ~ctx st (exp:exp): AD.t = + match eval_rv ~ctx st exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int ~ctx exp = - match eval_rv ~ctx exp with + and eval_int ~ctx st exp = + match eval_rv ~ctx st exp with | Int x -> x | _ -> ID.top_of (Cilfacade.get_ikind_exp exp) (* A function to convert the offset to our abstract representation of * offsets, i.e. evaluate the index expression to the integer domain. *) - and convert_offset ~ctx (ofs: offset) = + and convert_offset ~ctx (st: store) (ofs: offset) = let eval_rv = eval_rv_back_up in match ofs with | NoOffset -> `NoOffset - | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~ctx st ofs) | Index (exp, ofs) when CilType.Exp.equal exp Offset.Index.Exp.any -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset ~ctx ofs) + `Index (IdxDom.top (), convert_offset ~ctx st ofs) | Index (exp, ofs) -> - match eval_rv ~ctx exp with - | Int i -> `Index (iDtoIdx i, convert_offset ~ctx ofs) - | Address add -> `Index (AD.to_int add, convert_offset ~ctx ofs) - | Top -> `Index (IdxDom.top (), convert_offset ~ctx ofs) - | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx ofs) + match eval_rv ~ctx st exp with + | Int i -> `Index (iDtoIdx i, convert_offset ~ctx st ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~ctx st ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~ctx st ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~ctx st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv ~ctx (lval:lval): AD.t = + and eval_lv ~ctx st (lval:lval): AD.t = let eval_rv = eval_rv_back_up in match lval with (* The simpler case with an explicit variable, e.g. for [x.field] we just * create the address { (x,field) } *) | Var x, ofs -> - AD.singleton (Addr.of_mval (x, convert_offset ~ctx ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~ctx st ofs)) (* The more complicated case when [exp = & x.field] and we are asked to * evaluate [(\*exp).subfield]. We first evaluate [exp] to { (x,field) } * and then add the subfield to it: { (x,field.subfield) }. *) | Mem n, ofs -> begin - match eval_rv ~ctx n with + match eval_rv ~ctx st n with | Address adr -> ( if AD.is_null adr then ( @@ -1059,14 +1058,14 @@ 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 ctx.local.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) + | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global (Analyses.ask_of_ctx ctx) v) | _ -> false ) adr then ( AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn "lval %a points to a non-local variable. Invalid pointer dereference may occur" d_lval lval ) ); - AD.map (add_offset_varinfo (convert_offset ~ctx ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~ctx st ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr @@ -1080,15 +1079,15 @@ struct (* Previously we only gave sound results for programs without undefined behavior, so yielding bot for accessing an uninitialized array was considered ok. Now only [invariant] can yield bot/Deadcode if the condition is known to be false but evaluating an expression should not be bot. *) let eval_rv ~ctx (st: store) (exp:exp): value = try - let r = eval_rv ~ctx exp in + let r = eval_rv ~ctx st exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a\n" d_exp exp VD.pretty r; if VD.is_bot r then VD.top_value (Cilfacade.typeOf exp) else r with IntDomain.ArithmeticOnIntegerBot _ -> ValueDomain.Compound.top_value (Cilfacade.typeOf exp) - let query_evalint ~ctx e = + let query_evalint ~ctx st e = if M.tracing then M.traceli "evalint" "base query_evalint %a\n" d_exp e; - let r = match eval_rv_no_ask_evalint ~ctx e with + let r = match eval_rv_no_ask_evalint ~ctx st e with | Int i -> `Lifted i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | Bot -> Queries.ID.top () (* out-of-scope variables cause bot, but query result should then be unknown *) | Top -> Queries.ID.top () (* some float computations cause top (57-float/01-base), but query result should then be unknown *) @@ -1109,7 +1108,7 @@ struct Queries.Result.top q (* query cycle *) else ( match q with - | EvalInt e -> query_evalint ~ctx e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) @@ -1133,7 +1132,7 @@ struct | _ -> None let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv ~ctx fval in + let fp = eval_fv ~ctx ctx.local fval in if AD.is_top fp then ( if AD.cardinal fp = 1 then M.warn ~category:Imprecise ~tags:[Category Call] "Unknown call to function %a." d_exp fval @@ -1264,7 +1263,7 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx e + query_evalint ~ctx ctx.local e | Q.EvalMutexAttr e -> begin let e:exp = Lval (Cil.mkMem ~addr:e ~off:NoOffset) in match eval_rv ~ctx ctx.local e with @@ -1723,7 +1722,7 @@ struct char_array_hack (); let rval_val = eval_rv ~ctx ctx.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv ~ctx lval in + let lval_val = eval_lv ~ctx ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) (* M.debug ~category:Analyzer @@ sprint ~width:max_int @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = @@ -1755,7 +1754,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot ~ctx (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~ctx ctx.local (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1866,7 +1865,7 @@ struct if not (Cil.isArrayType v.vtype) then ctx.local else - let lval = eval_lv ~ctx (Var v, NoOffset) in + let lval = eval_lv ~ctx ctx.local (Var v, NoOffset) in let current_value = eval_rv ~ctx ctx.local (Lval (Var v, NoOffset)) in let new_value = VD.update_array_lengths (eval_rv ~ctx ctx.local) current_value v.vtype in set ~ctx ctx.local lval v.vtype new_value @@ -2005,7 +2004,7 @@ struct (* extra sync so that we do not analyze new threads with bottom global invariant *) publish_all ctx `Thread; (* Collect the threads. *) - let start_addr = eval_tv ~ctx start in + let start_addr = eval_tv ~ctx ctx.local start in let start_funvars = AD.to_var_may start_addr in let start_funvars_with_unknown = if AD.mem Addr.UnknownPtr start_addr then @@ -2156,7 +2155,7 @@ struct in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv ~ctx lval in + let addr = eval_lv ~ctx ctx.local lval in (addr, AD.type_of addr) in let forks, multiple = forkfun ctx lv f args in @@ -2182,7 +2181,7 @@ struct in 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 ~ctx src_lval + let src_typ = eval_lv ~ctx ctx.local src_lval |> AD.type_of in (* when src and destination type coincide, take value from the source, otherwise use top *) let value = if (typeSig dest_typ = typeSig src_typ) && dest_size_equal_n then @@ -2234,7 +2233,7 @@ struct 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 ~ctx lv_val in + let lv_a = eval_lv ~ctx 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 st lv_a lv_typ (f s1_a s2_a) @@ -2250,7 +2249,7 @@ struct (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv ~ctx lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~ctx st lv_val, Cilfacade.typeOfLval lv_val | None -> s1_a, s1_typ in begin match (get ~ctx st s1_a None), get ~ctx st s2_a None with | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true st lv_a lv_typ (op_array array_s1 array_s2) @@ -2318,7 +2317,7 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv ~ctx lv_val in + let dest_a = eval_lv ~ctx st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in let v = eval_rv ~ctx st s in let a = address_from_value v in @@ -2346,8 +2345,8 @@ struct 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 ~ctx (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~ctx st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2381,12 +2380,12 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv ~ctx lval in + let address = eval_lv ~ctx st lval in AD.type_of address in let dst_lval = mkMem ~addr:(Cil.stripCasts attr) ~off:NoOffset in let dest_typ = get_type dst_lval in - let dest_a = eval_lv ~ctx dst_lval in + let dest_a = eval_lv ~ctx st dst_lval in match eval_rv ~ctx st mtyp with | Int x -> begin @@ -2471,7 +2470,7 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv ~ctx lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~ctx st (eval_lv ~ctx st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) @@ -2504,8 +2503,8 @@ struct | Some lv -> let heap_var = AD.of_var (heap_var true ctx) in (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx st size, true)); + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2517,8 +2516,8 @@ struct else AD.of_var (heap_var false ctx) in (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ~ctx size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx size, true)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address heap_var)] + set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx st size, true)); + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> @@ -2530,12 +2529,12 @@ struct then AD.join addr AD.null_ptr (* calloc can fail and return NULL *) else addr in let ik = Cilfacade.ptrdiff_ikind () in - let sizeval = eval_int ~ctx size in - let countval = eval_int ~ctx n in + let sizeval = eval_int ~ctx st size in + let countval = eval_int ~ctx st n in if ID.to_int countval = Some Z.one then ( set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, false)); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) else ( @@ -2543,7 +2542,7 @@ struct (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv ~ctx lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) ] ) | _ -> st @@ -2564,7 +2563,7 @@ struct in let p_addr' = AD.remove NullPtr p_addr in (* realloc with NULL is same as malloc, remove to avoid unknown value from NullPtr access *) let p_addr_get = get ~ctx st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ~ctx size in + let size_int = eval_int ~ctx st size in let heap_val:value = Blob (p_addr_get, size_int, true) in (* copy old contents with new size *) let heap_addr = AD.of_var (heap_var false ctx) in let heap_addr' = @@ -2573,7 +2572,7 @@ struct else heap_addr in - let lv_addr = eval_lv ~ctx lv in + let lv_addr = eval_lv ~ctx st lv in set_many ~ctx st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); @@ -2597,7 +2596,7 @@ struct in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ~ctx lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx st' (eval_lv ~ctx st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2624,7 +2623,7 @@ struct begin match lv with | Some x -> let result:value = (Int (ID.starting IInt Z.zero)) in - set ~ctx st (eval_lv ~ctx x) (Cilfacade.typeOfLval x) result + set ~ctx st (eval_lv ~ctx st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> @@ -2746,7 +2745,7 @@ struct match lval with | None -> st - | Some lval -> set_savetop ~ctx st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~ctx st (eval_lv ~ctx st lval) (Cilfacade.typeOfLval lval) return_val in combine_one ctx.local after @@ -2844,11 +2843,13 @@ struct module V = V module G = G + let ost = octx.local + (* all evals happen in octx with non-top values *) - let eval_rv ~ctx e = eval_rv ~ctx:octx e - let eval_rv_address ~ctx e = eval_rv_address ~ctx:octx e - let eval_lv ~ctx lv = eval_lv ~ctx:octx lv - let convert_offset ~ctx o = convert_offset ~ctx:octx o + let eval_rv ~ctx st e = eval_rv ~ctx:octx ost e + let eval_rv_address ~ctx st e = eval_rv_address ~ctx:octx ost e + let eval_lv ~ctx st lv = eval_lv ~ctx:octx ost lv + let convert_offset ~ctx st o = convert_offset ~ctx:octx ost o (* all updates happen in ctx with top values *) let get_var = get_var @@ -2922,7 +2923,7 @@ struct Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> assert_fn ctx exp true | Events.Unassume {exp; uuids} -> diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 4d51895683..e66a431ccf 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -17,8 +17,8 @@ sig val eval_rv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t val eval_rv_address: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> VD.t - val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> lval -> AD.t - val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> offset -> ID.t Offset.t + val eval_lv: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> lval -> AD.t + val convert_offset: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> offset -> ID.t Offset.t val get_var: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> varinfo -> VD.t val get: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> exp option -> VD.t @@ -64,7 +64,7 @@ struct let refine_lv_fallback ctx st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a\n" d_lval lval VD.pretty value; - let addr = eval_lv ~ctx lval in + let addr = eval_lv ~ctx st lval in if (AD.is_top addr) then st else let old_val = get ~ctx st addr None in (* None is ok here, we could try to get more precise, but this is ok (reading at unknown position in array) *) @@ -92,13 +92,13 @@ struct else set st addr t_lval new_val ~ctx (* no *_raw because this is not a real assignment *) let refine_lv ctx st c x c' pretty exp = - let set' lval v st = set st (eval_lv ~ctx lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let set' lval v st = set st (eval_lv ~ctx st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in match x with | Var var, o when refine_entire_var -> (* For variables, this is done at to the level of entire variables to benefit e.g. from disjunctive struct domains *) let old_val = get_var ~ctx st var in let old_val = map_oldval old_val var.vtype in - let offs = convert_offset ~ctx o in + let offs = convert_offset ~ctx st o in let new_val = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) old_val offs c' (Some exp) x (var.vtype) in let v = apply_invariant ~old_val ~new_val in if is_some_bot v then contra st From 2d4f7f2f450ad1e6d1823ed1aeef1829c23789f3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:08:54 +0200 Subject: [PATCH 401/517] Replace ask in evalbinop_base with ctx for consistency --- 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 63f516c82c..0081459930 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -249,7 +249,7 @@ struct | _ -> false (* Evaluate binop for two abstract values: *) - let evalbinop_base (a: Q.ask) (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = + let evalbinop_base ~ctx (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = if M.tracing then M.tracel "eval" "evalbinop %a %a %a\n" d_binop op VD.pretty a1 VD.pretty a2; (* We define a conversion function for the easy cases when we can just use * the integer domain operations. *) @@ -346,7 +346,7 @@ struct let ax = AD.choose x in let ay = AD.choose y in let handle_address_is_multiple addr = begin match Addr.to_var addr with - | Some v when a.f (Q.IsMultiple v) -> + | Some v when ctx.ask (Q.IsMultiple v) -> if M.tracing then M.tracel "addr" "IsMultiple %a\n" CilType.Varinfo.pretty v; None | _ -> @@ -782,7 +782,7 @@ struct let a1 = eval_rv ~ctx st e1 in let a2 = eval_rv ~ctx st e2 in let extra_is_safe = - match evalbinop_base (Analyses.ask_of_ctx ctx) op t1 a1 t2 a2 typ with + match evalbinop_base ~ctx op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false @@ -963,19 +963,18 @@ struct (** Evaluate BinOp using MustBeEqual query as fallback. *) and evalbinop_mustbeequal ~ctx (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = (* Evaluate structurally using base at first. *) - let ask = Analyses.ask_of_ctx ctx in let a1 = eval_rv ~ctx st e1 in let a2 = eval_rv ~ctx st e2 in let t1 = Option.default_delayed (fun () -> Cilfacade.typeOf e1) t1 in let t2 = Option.default_delayed (fun () -> Cilfacade.typeOf e2) t2 in - let r = evalbinop_base ask op t1 a1 t2 a2 t in + let r = evalbinop_base ~ctx op t1 a1 t2 a2 t in if Cil.isIntegralType t then ( match r with | Int i when ID.to_int i <> None -> r (* Avoid fallback, cannot become any more precise. *) | _ -> (* Fallback to MustBeEqual query, could get extra precision from exprelation/var_eq. *) let must_be_equal () = - let r = Q.must_be_equal ask e1 e2 in + let r = Q.must_be_equal (Analyses.ask_of_ctx ctx) e1 e2 in if M.tracing then M.tracel "query" "MustBeEqual (%a, %a) = %b\n" d_exp e1 d_exp e2 r; r in From cd871fca53343e7f9af82a5a96a82cf92e911e38 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:43:42 +0200 Subject: [PATCH 402/517] Replace ctx with ask in reachable_from_value --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0081459930..7a4db866a5 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -513,7 +513,7 @@ struct in List.fold_right f vals [] - let rec reachable_from_value ~ctx (value: value) (t: typ) (description: string) = + let rec reachable_from_value ask (value: value) (t: typ) (description: string) = let empty = AD.empty () in if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with @@ -525,12 +525,12 @@ struct (* The main thing is to track where pointers go: *) | Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) - | Union (f,e) -> reachable_from_value ~ctx e t description + | Union (f,e) -> reachable_from_value ask e t description (* For arrays, we ask to read from an unknown index, this will cause it * join all its values. *) - | Array a -> reachable_from_value ~ctx (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, ValueDomain.ArrIdxDomain.top ())) t description - | Blob (e,_,_) -> reachable_from_value ~ctx e t description - | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ~ctx v t description) acc) s empty + | Array a -> reachable_from_value ask (ValueDomain.CArrays.get (Queries.to_value_domain_ask ask) a (None, ValueDomain.ArrIdxDomain.top ())) t description + | Blob (e,_,_) -> reachable_from_value ask e t description + | Struct s -> ValueDomain.Structs.fold (fun k v acc -> AD.join (reachable_from_value ask v t description) acc) s empty | Int _ -> empty | Float _ -> empty | MutexAttr _ -> empty @@ -543,7 +543,7 @@ struct * pointers. We return a flattend representation, thus simply an address (set). *) let reachable_from_address ~ctx (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value ~ctx (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -1876,7 +1876,7 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = - let immediately_reachable = reachable_from_value ~ctx (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx [immediately_reachable] in List.concat_map do_exp exps From 7af5e41b4c081d7940d42a05084ef3d81c636524 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:51:59 +0200 Subject: [PATCH 403/517] Add st back to reachable_vars and reachable_from_address --- src/analyses/base.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7a4db866a5..3794558a45 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -541,9 +541,9 @@ struct (* 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 * pointers. We return a flattend representation, thus simply an address (set). *) - let reachable_from_address ~ctx (adr: address): address = + let reachable_from_address ~ctx st (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a\n" AD.pretty adr; - let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx ctx.local adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx st adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a\n" AD.pretty res; res @@ -551,7 +551,7 @@ struct * This section is very confusing, because I use the same construct, a set of * addresses, as both AD elements abstracting individual (ambiguous) addresses * and the workset of visited addresses. *) - let reachable_vars ~ctx (args: address list): address list = + let reachable_vars ~ctx (st: store) (args: address list): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!\n" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -564,7 +564,7 @@ struct (* ok, let's visit all the variables in the workset and collect the new variables *) let visit_and_collect var (acc: address): address = let var = AD.singleton var in (* Very bad hack! Pathetic really! *) - AD.union (reachable_from_address ~ctx var) acc in + AD.union (reachable_from_address ~ctx st var) acc in let collected = AD.fold visit_and_collect !workset empty in (* And here we remove the already visited variables *) workset := AD.diff collected !visited @@ -1341,7 +1341,7 @@ struct | Bot -> Queries.Result.bot q (* TODO: remove *) | Address a -> let a' = AD.remove Addr.UnknownPtr a in (* run reachable_vars without unknown just to be safe: TODO why? *) - let addrs = reachable_vars ~ctx [a'] in + let addrs = reachable_vars ~ctx ctx.local [a'] in let addrs' = List.fold_left (AD.join) (AD.empty ()) addrs in if AD.may_be_unknown a then AD.add UnknownPtr addrs' (* add unknown back *) @@ -1877,7 +1877,7 @@ struct let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = let do_exp e = let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in - reachable_vars ~ctx [immediately_reachable] + reachable_vars ~ctx st [immediately_reachable] in List.concat_map do_exp exps @@ -1951,7 +1951,7 @@ struct add_to_array_map fundec pa; let new_cpa = CPA.add_list pa st'.cpa in (* List of reachable variables *) - let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx (get_ptrs vals)) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~ctx st (get_ptrs vals)) in let reachable = List.filter (fun v -> CPA.mem v st.cpa) reachable in let new_cpa = CPA.add_list_fun reachable (fun v -> CPA.find v st.cpa) new_cpa in From c9ccbb6833a31ebe54020e5f0be2ed0f7f625e7b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 5 Jan 2024 14:56:55 +0200 Subject: [PATCH 404/517] Fix reachable_vars timing --- 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 3794558a45..f7c6b436cb 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -573,7 +573,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a\n" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ~ctx args = Timing.wrap "reachability" (reachable_vars ~ctx) args + let reachable_vars ~ctx st args = Timing.wrap "reachability" (reachable_vars ~ctx st) args let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else From be69a349aabf14a87980aa5415b36a81f36bd193 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 9 Jan 2024 12:00:25 +0200 Subject: [PATCH 405/517] Eta-reduce ask_of_ctx to avoid function allocation --- src/framework/analyses.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 405df5b6a6..adb9b30d40 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -370,7 +370,7 @@ exception Ctx_failure of string let ctx_failwith s = raise (Ctx_failure s) (* TODO: use everywhere in ctx *) (** Convert [ctx] to [Queries.ask]. *) -let ask_of_ctx ctx: Queries.ask = { Queries.f = fun (type a) (q: a Queries.t) -> ctx.ask q } +let ask_of_ctx ctx: Queries.ask = { Queries.f = ctx.ask } module type Spec = From bd5d65d96aa18c66f0cb14df999335b47c60b32e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 9 Jan 2024 13:45:55 +0200 Subject: [PATCH 406/517] Detect query cycles in eval_exp --- src/analyses/base.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f7c6b436cb..81e4591123 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1107,12 +1107,12 @@ struct Queries.Result.top q (* query cycle *) else ( match q with - | EvalInt e -> query_evalint ~ctx st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~ctx:(ctx' (Queries.Set.add anyq asked)) st e (* mimic EvalInt query since eval_rv needs it *) | _ -> Queries.Result.top q ) and gs = function `Left _ -> `Lifted1 (Priv.G.top ()) | `Right _ -> `Lifted2 (VD.top ()) (* the expression is guaranteed to not contain globals *) - and ctx = - { ask = (fun (type a) (q: a Queries.t) -> query Queries.Set.empty q) + and ctx' asked = + { ask = (fun (type a) (q: a Queries.t) -> query asked q) ; emit = (fun _ -> failwith "Cannot \"emit\" in base eval_exp context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node @@ -1126,7 +1126,7 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx st exp with + match eval_rv ~ctx:(ctx' Queries.Set.empty) st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None From 76e5d3829c4ba784e5d2459894d8c7c6ce8fcce0 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 9 Jan 2024 13:53:00 +0200 Subject: [PATCH 407/517] Avoid doing Analyses.ask_of_ctx ctx for each exp in a list --- src/analyses/base.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 81e4591123..e77e3ac95c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1875,8 +1875,9 @@ struct (** From a list of expressions, collect a list of addresses that they might point to, or contain pointers to. *) let collect_funargs ~ctx ?(warn=false) (st:store) (exps: exp list) = + let ask = Analyses.ask_of_ctx ctx in let do_exp e = - let immediately_reachable = reachable_from_value (Analyses.ask_of_ctx ctx) (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + let immediately_reachable = reachable_from_value ask (eval_rv ~ctx st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in reachable_vars ~ctx st [immediately_reachable] in List.concat_map do_exp exps From 3422110111c6621a85caac18db9d4412a5a01cd0 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Tue, 9 Jan 2024 18:38:02 +0100 Subject: [PATCH 408/517] Rm outdated comment --- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 6f6f7c1280..ab24515c28 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -602,7 +602,7 @@ struct | Some v -> let ik = Cilfacade.get_ikind v.vtype in if not (Cil.isSigned ik) then - raise NotRefinable (* TODO: unsigned w/o bounds handled differently? *) + raise NotRefinable else match Bounds.bound_texpr res (Convert.texpr1_of_cil_exp res res.env (Lval (Cil.var v)) true) with | Some min, Some max -> From 9452d0881aad4d95e8c6b5eda63d3053c34a91af Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 11:45:57 +0200 Subject: [PATCH 409/517] Add unsound minimal conf with no analyses --- conf/min-unsound.json | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 conf/min-unsound.json diff --git a/conf/min-unsound.json b/conf/min-unsound.json new file mode 100644 index 0000000000..5195909ffb --- /dev/null +++ b/conf/min-unsound.json @@ -0,0 +1,6 @@ +{ + "ana": { + "activated": [ + ] + } +} \ No newline at end of file From 3b0e0c598e47f9e011d1b9a56904708e78ac079a Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 10 Jan 2024 11:48:50 +0200 Subject: [PATCH 410/517] Add Karoliine as a maintainer to relevant files #1315 --- dune-project | 2 +- goblint.opam | 1 + goblint.opam.locked | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/dune-project b/dune-project index 37e81f4199..de6e955e60 100644 --- a/dune-project +++ b/dune-project @@ -16,7 +16,7 @@ (homepage "https://goblint.in.tum.de") (documentation "https://goblint.readthedocs.io/en/latest/") (authors "Simmo Saan" "Michael Schwarz" "Julian Erhard" "Sarah Tilscher" "Ralf Vogler" "Kalmer Apinis" "Vesal Vojdani" ) ; same authors as in .zenodo.json and CITATION.cff -(maintainers "Simmo Saan " "Michael Schwarz ") +(maintainers "Simmo Saan " "Michael Schwarz " "Karoliine Holter") (license MIT) (package diff --git a/goblint.opam b/goblint.opam index b5f1f360dc..7a75a1fb45 100644 --- a/goblint.opam +++ b/goblint.opam @@ -4,6 +4,7 @@ synopsis: "Static analysis framework for C" maintainer: [ "Simmo Saan " "Michael Schwarz " + "Karoliine Holter" ] authors: [ "Simmo Saan" diff --git a/goblint.opam.locked b/goblint.opam.locked index 02eac0bb75..b0a1c9ef20 100644 --- a/goblint.opam.locked +++ b/goblint.opam.locked @@ -5,6 +5,7 @@ synopsis: "Static analysis framework for C" maintainer: [ "Simmo Saan " "Michael Schwarz " + "Karoliine Holter" ] authors: [ "Simmo Saan" From 2d1b4204574733c7f081a1c5f2b859b22da04eeb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 12:06:51 +0200 Subject: [PATCH 411/517] Use only tops for arrays in ValueDomain.top_value --- src/cdomains/valueDomain.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 003a65a49e..8fb639deb9 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -199,9 +199,8 @@ struct | TComp ({cstruct=false; _},_) -> Union (Unions.top ()) | TArray (ai, length, _) -> let typAttr = typeAttrs ai in - let can_recover_from_top = ArrayDomain.can_recover_from_top (ArrayDomain.get_domain ~varAttr ~typAttr) in let len = array_length_idx (IndexDomain.top ()) length in - Array (CArrays.make ~varAttr ~typAttr len (if can_recover_from_top then (top_value ai) else Bot)) + Array (CArrays.make ~varAttr ~typAttr len (top_value ai)) | TNamed ({ttype=t; _}, _) -> top_value ~varAttr t | _ -> Top From 11e89489ee3ffe7b9587d64a6e0d9994cb55cc9f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 12:09:13 +0200 Subject: [PATCH 412/517] Mark fixed TODOs in 03-practical/31-zstd-cctxpool-blobs --- tests/regression/03-practical/31-zstd-cctxpool-blobs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/regression/03-practical/31-zstd-cctxpool-blobs.c b/tests/regression/03-practical/31-zstd-cctxpool-blobs.c index 40e448eb22..c91c141446 100644 --- a/tests/regression/03-practical/31-zstd-cctxpool-blobs.c +++ b/tests/regression/03-practical/31-zstd-cctxpool-blobs.c @@ -22,8 +22,8 @@ int main() { ZSTDMT_CCtxPool* const cctxPool = calloc(1, sizeof(ZSTDMT_CCtxPool)); cctxPool->cctx[0] = malloc(sizeof(ZSTD_CCtx)); if (!cctxPool->cctx[0]) // TODO NOWARN - __goblint_check(1); // TODO reachable + __goblint_check(1); // reachable else - __goblint_check(1); // TODO reachable + __goblint_check(1); // reachable return 0; } From 910b152226b7f28d20eabdda2c5578c526ceba49 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 10 Jan 2024 13:45:40 +0200 Subject: [PATCH 413/517] Update extension in debugging documentation --- docs/developer-guide/debugging.md | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/docs/developer-guide/debugging.md b/docs/developer-guide/debugging.md index 5c1db12227..d218e1a8b8 100644 --- a/docs/developer-guide/debugging.md +++ b/docs/developer-guide/debugging.md @@ -60,14 +60,14 @@ This will create a file called `goblint.byte`. ### Debugging Goblint with VS Code To debug OCaml programs, you can use the command line interface of `ocamldebug` or make use of the Visual Studio Code -integration provided by `hackwaly.ocamlearlybird`. +integration provided by `ocamllabs.ocaml-platform`. In the following, we describe the steps necessary to set up this VS Code extension to debug Goblint. ### Setting-up Earlybird -Install the [`hackwaly.ocamlearlybird` extension](https://marketplace.visualstudio.com/items?itemName=hackwaly.ocamlearlybird) in your installation of Visual Studio Code. -To be able to use this extension, you additionally need to install `ocamlearlybird` on the opam switch you use for Goblint. +Install the [`ocamllabs.ocaml-platform` extension](https://marketplace.visualstudio.com/items?itemName=ocamllabs.ocaml-platform) in your installation of Visual Studio Code. +To be able to use this extension, you additionally need to install `earlybird` on the opam switch you use for Goblint. To do so, run the following command in the `analyzer` directory: ```console @@ -76,7 +76,7 @@ opam install earlybird ### Providing a Launch Configuration -To let the `hackwaly.ocamlearlybird` extension know which executable it should debug, and which arguments it should pass, we have to provide a configuration file. +To let the `ocamllabs.ocaml-platform` extension know which executable it should debug, and which arguments it should pass, we have to provide a configuration file. The configuration file has to be named `launch.json` and must reside in the `./.vscode` directory. Here is an example `launch.json`: ```JSON @@ -92,6 +92,9 @@ The configuration file has to be named `launch.json` and must reside in the `./. "tests/regression/00-sanity/01-assert.c", "--enable", "ana.int.interval", ], + "env": { + "LD_LIBRARY_PATH": "$LD_LIBRARY_PATH:_build/default/src/common" + }, "stopOnEntry": false, } ] From 0af26b4f34007736996b7e5913942d769cc801a7 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 11 Jan 2024 12:05:07 +0200 Subject: [PATCH 414/517] Add group location to messaging docs --- docs/developer-guide/messaging.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/docs/developer-guide/messaging.md b/docs/developer-guide/messaging.md index 0028d51f87..91fba82b51 100644 --- a/docs/developer-guide/messaging.md +++ b/docs/developer-guide/messaging.md @@ -18,7 +18,8 @@ A message consists of the following: 3. **Context.** Optional. Currently completely abstract, so not very useful. * **Group.** For messages related to numerous locations with different texts. Contains the following: 1. **Group text.** An overall description of the group message. - 2. **Pieces.** A list of single messages as described above. + 2. **Group location.** Optional. An overall location of the group message. + 3. **Pieces.** A list of single messages as described above. ## Creating From abd1cb6c9834db675e5c5ecbdfa752088f1ad181 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Wed, 10 Jan 2024 17:41:22 +0200 Subject: [PATCH 415/517] Add test for local var escaping when assigned to global through identity function --- .../45-escape/09-id-local-in-global.c | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 tests/regression/45-escape/09-id-local-in-global.c diff --git a/tests/regression/45-escape/09-id-local-in-global.c b/tests/regression/45-escape/09-id-local-in-global.c new file mode 100644 index 0000000000..aa5a12c012 --- /dev/null +++ b/tests/regression/45-escape/09-id-local-in-global.c @@ -0,0 +1,25 @@ +#include +#include + +int* gptr; + +void *foo(void* p){ + *gptr = 17; + return NULL; +} + +int* id(int* x) { + return x; +} + +int main(){ + int x = 0; + gptr = id(&x); + __goblint_check(x==0); + pthread_t thread; + pthread_create(&thread, NULL, foo, NULL); + sleep(3); + __goblint_check(x == 0); // UNKNOWN! + pthread_join(thread, NULL); + return 0; +} From 063812189dbe12731aacb551230b65fc27908cd8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:34:46 +0200 Subject: [PATCH 416/517] Move return functions from base to returnUtil --- src/analyses/base.ml | 10 +--------- src/analyses/region.ml | 8 +++----- src/util/returnUtil.ml | 9 +++++++++ 3 files changed, 13 insertions(+), 14 deletions(-) create mode 100644 src/util/returnUtil.ml diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c470bca026..fb2b5af517 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -6,6 +6,7 @@ open Pretty open Analyses open GobConfig open BaseUtil +open ReturnUtil module A = Analyses module H = Hashtbl module Q = Queries @@ -143,13 +144,6 @@ struct * Initializing my variables **************************************************************************) - let return_varstore = ref dummyFunDec.svar - let return_varinfo () = !return_varstore - let return_var () = AD.of_var (return_varinfo ()) - let return_lval (): lval = (Var (return_varinfo ()), NoOffset) - - let longjmp_return = ref dummyFunDec.svar - let heap_var on_stack ctx = let info = match (ctx.ask (Q.AllocVar {on_stack})) with | `Lifted vinfo -> vinfo @@ -2930,8 +2924,6 @@ end module type MainSpec = sig include MCPSpec include BaseDomain.ExpEvaluator - val return_lval: unit -> Cil.lval - val return_varinfo: unit -> Cil.varinfo end let main_module: (module MainSpec) Lazy.t = diff --git a/src/analyses/region.ml b/src/analyses/region.ml index 5b10586aba..a6ffa54ed6 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -109,8 +109,7 @@ struct let old_regpart = ctx.global () in let regpart, reg = match exp with | Some exp -> - let module BS = (val Base.get_main ()) in - Reg.assign (BS.return_lval ()) exp (old_regpart, reg) + Reg.assign (ReturnUtil.return_lval ()) exp (old_regpart, reg) | None -> (old_regpart, reg) in let regpart, reg = Reg.kill_vars locals (Reg.remove_vars locals (regpart, reg)) in @@ -143,12 +142,11 @@ struct match au with | `Lifted reg -> begin let old_regpart = ctx.global () in - let module BS = (val Base.get_main ()) in let regpart, reg = match lval with | None -> (old_regpart, reg) - | Some lval -> Reg.assign lval (AddrOf (BS.return_lval ())) (old_regpart, reg) + | Some lval -> Reg.assign lval (AddrOf (ReturnUtil.return_lval ())) (old_regpart, reg) in - let regpart, reg = Reg.remove_vars [BS.return_varinfo ()] (regpart, reg) in + let regpart, reg = Reg.remove_vars [ReturnUtil.return_varinfo ()] (regpart, reg) in if not (RegPart.leq regpart old_regpart) then ctx.sideg () regpart; `Lifted reg diff --git a/src/util/returnUtil.ml b/src/util/returnUtil.ml new file mode 100644 index 0000000000..a97f538970 --- /dev/null +++ b/src/util/returnUtil.ml @@ -0,0 +1,9 @@ +open GoblintCil +module AD = ValueDomain.AD + +let return_varstore = ref dummyFunDec.svar +let return_varinfo () = !return_varstore +let return_var () = AD.of_var (return_varinfo ()) +let return_lval (): lval = (Var (return_varinfo ()), NoOffset) + +let longjmp_return = ref dummyFunDec.svar \ No newline at end of file From 094a52b57a0ddcbd374eab0f0b5f9a27a4cfbd3c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:35:46 +0200 Subject: [PATCH 417/517] Add ask as parameter for excape_rval --- src/analyses/threadEscape.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 21a8b69c93..2be4055bbc 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -117,8 +117,7 @@ struct end | _ -> Queries.Result.top q - let escape_rval ctx (rval:exp) = - let ask = Analyses.ask_of_ctx ctx in + let escape_rval ctx ask (rval:exp) = let escaped = reachable ask rval in let escaped = D.filter (fun v -> not v.vglob) escaped in @@ -133,7 +132,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let vs = mpt ask (AddrOf lval) in if D.exists (fun v -> v.vglob || has_escaped ask v) vs then ( - let escaped = escape_rval ctx rval in + let escaped = escape_rval ctx (Analyses.ask_of_ctx ctx) rval in D.join ctx.local escaped ) else begin ctx.local @@ -143,7 +142,7 @@ struct let desc = LibraryFunctions.find f in match desc.special args, f.vname, args with | _, "pthread_setspecific" , [key; pt_value] -> - let escaped = escape_rval ctx pt_value in + let escaped = escape_rval ctx (Analyses.ask_of_ctx ctx) pt_value in D.join ctx.local escaped | _ -> ctx.local From d39e600a0229f1bda2acf946ed451a98bab55147 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:36:40 +0200 Subject: [PATCH 418/517] Implement combine_assign in threadEscape --- src/analyses/threadEscape.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 2be4055bbc..3aad5ea5cf 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -138,6 +138,15 @@ struct ctx.local end + let combine_assign ctx (lval:lval option) (fexp:exp) f args fc au f_ask : D.t = + let ask = Analyses.ask_of_ctx ctx in + match lval with + | Some lval when D.exists (fun v -> v.vglob || has_escaped ask v) (mpt ask (AddrOf lval)) -> + let rval = Lval (ReturnUtil.return_lval ()) in + let escaped = escape_rval ctx f_ask rval in + D.join ctx.local escaped + | _ -> ctx.local + let special ctx (lval: lval option) (f:varinfo) (args:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special args, f.vname, args with From 8c859840b8a6f077cceb8137cd7483f1ed195736 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:43:00 +0200 Subject: [PATCH 419/517] Add test for fresh alloca --- tests/regression/45-escape/49-fresh-alloca.c | 27 ++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/regression/45-escape/49-fresh-alloca.c diff --git a/tests/regression/45-escape/49-fresh-alloca.c b/tests/regression/45-escape/49-fresh-alloca.c new file mode 100644 index 0000000000..f28c324193 --- /dev/null +++ b/tests/regression/45-escape/49-fresh-alloca.c @@ -0,0 +1,27 @@ +// PARAM: --set ana.activated[+] mallocFresh --set ana.activated[-] mhp --set ana.thread.domain plain +#include +#include + +pthread_mutex_t A = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun2(void *arg) { + int *i = arg; + pthread_mutex_lock(&A); + *i = 10; // NORACE + pthread_mutex_unlock(&A); + return NULL; +} + +void *t_fun(void *arg) { + return NULL; +} + +int main() { + pthread_t id, id2; + pthread_create(&id, NULL, t_fun, NULL); // enter multithreaded + + int *i = alloca(sizeof(int)); + *i = 5; // NORACE (fresh) + pthread_create(&id2, NULL, t_fun2, i); + return 0; +} \ No newline at end of file From d719842cea889874eb5fc18cf1a31da719a63736 Mon Sep 17 00:00:00 2001 From: Karoliine Holter <44437975+karoliineh@users.noreply.github.com> Date: Thu, 11 Jan 2024 12:44:25 +0200 Subject: [PATCH 420/517] Use ask variable instead of Analyses.ask_of_ctx ctx Co-authored-by: Simmo Saan --- src/analyses/threadEscape.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 3aad5ea5cf..376666c611 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -132,7 +132,7 @@ struct let ask = Analyses.ask_of_ctx ctx in let vs = mpt ask (AddrOf lval) in if D.exists (fun v -> v.vglob || has_escaped ask v) vs then ( - let escaped = escape_rval ctx (Analyses.ask_of_ctx ctx) rval in + let escaped = escape_rval ctx ask rval in D.join ctx.local escaped ) else begin ctx.local From 7685f55a73180b76a800d4e8027735b41a42d6fb Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:45:12 +0200 Subject: [PATCH 421/517] Consider alloca in special in mallocFresh --- src/analyses/mallocFresh.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/analyses/mallocFresh.ml b/src/analyses/mallocFresh.ml index d1314d5009..138a208558 100644 --- a/src/analyses/mallocFresh.ml +++ b/src/analyses/mallocFresh.ml @@ -42,7 +42,8 @@ struct match desc.special args with | Malloc _ | Calloc _ - | Realloc _ -> + | Realloc _ + | Alloca _ -> begin match ctx.ask (AllocVar {on_stack = false}) with | `Lifted var -> D.add var ctx.local | _ -> ctx.local From 1ec35c454e47024431a9dd06cd8b35e416ccd5cd Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:46:02 +0200 Subject: [PATCH 422/517] Consider alloca in special in memLeak --- src/analyses/memLeak.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 456d434be7..87a1e26433 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -204,7 +204,8 @@ struct match desc.special arglist with | Malloc _ | Calloc _ - | Realloc _ -> + | Realloc _ + | Alloca _ -> ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> From a18137a7e62b273de85fb5eae19e3832f5015d7c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:55:49 +0200 Subject: [PATCH 423/517] Consider alloca in special in region --- src/analyses/region.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/region.ml b/src/analyses/region.ml index 5b10586aba..2a38bdf20b 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -158,7 +158,7 @@ struct let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist with - | Malloc _ | Calloc _ | Realloc _ -> begin + | Malloc _ | Calloc _ | Realloc _ | Alloca _ -> begin match ctx.local, lval with | `Lifted reg, Some lv -> let old_regpart = ctx.global () in From c76a0a29834cee033e90ea02563624105100b928 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 12:56:33 +0200 Subject: [PATCH 424/517] Consider alloca for loopUnrolling --- src/util/loopUnrolling.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/util/loopUnrolling.ml b/src/util/loopUnrolling.ml index e1a8ad542b..26f306a267 100644 --- a/src/util/loopUnrolling.ml +++ b/src/util/loopUnrolling.ml @@ -316,6 +316,7 @@ class loopUnrollingCallVisitor = object | Malloc _ | Calloc _ | Realloc _ + | Alloca _ | Lock _ | Unlock _ | ThreadCreate _ From 34d30fe73cd3c50993cc07aec006e724e3d0f6e7 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Thu, 11 Jan 2024 13:51:39 +0200 Subject: [PATCH 425/517] Add comment about f_ask in combine_assign --- src/analyses/threadEscape.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 376666c611..f5ff3dc50a 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -143,7 +143,7 @@ struct match lval with | Some lval when D.exists (fun v -> v.vglob || has_escaped ask v) (mpt ask (AddrOf lval)) -> let rval = Lval (ReturnUtil.return_lval ()) in - let escaped = escape_rval ctx f_ask rval in + let escaped = escape_rval ctx f_ask rval in (* Using f_ask because the return value is only accessible in the context of that function at this point *) D.join ctx.local escaped | _ -> ctx.local From e847c8f39e2fce8de7f4826fae8b783397cea081 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 11 Jan 2024 15:46:00 +0200 Subject: [PATCH 426/517] Document ReturnUtil --- src/goblint_lib.ml | 1 + src/util/returnUtil.ml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 1bc70f3f52..06c51b0c15 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -402,6 +402,7 @@ module LibraryFunctions = LibraryFunctions module BaseUtil = BaseUtil module PrecisionUtil = PrecisionUtil module ContextUtil = ContextUtil +module ReturnUtil = ReturnUtil module BaseInvariant = BaseInvariant module CommonPriv = CommonPriv module WideningThresholds = WideningThresholds diff --git a/src/util/returnUtil.ml b/src/util/returnUtil.ml index a97f538970..d80ab48ee4 100644 --- a/src/util/returnUtil.ml +++ b/src/util/returnUtil.ml @@ -1,3 +1,5 @@ +(** Special variable for return value. *) + open GoblintCil module AD = ValueDomain.AD From 69f28b2682b4f070db90918da550a6dbb237ad25 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Thu, 11 Jan 2024 15:46:50 +0200 Subject: [PATCH 427/517] Fix goblint-lib-modules.py output --- scripts/goblint-lib-modules.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 8ae3b4b3eb..fc6d33b421 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -65,5 +65,5 @@ missing_modules = src_modules - goblint_lib_modules if len(missing_modules) > 0: - print(f"Modules missing from {goblint_lib_path}: {missing_modules}") + print(f"Modules missing from {goblint_lib_paths[0]}: {missing_modules}") sys.exit(1) From 28d5ea251c297f29244fcb567068c35135bae9ee Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Thu, 11 Jan 2024 19:19:20 +0000 Subject: [PATCH 428/517] Bump jinja2 from 3.0.3 to 3.1.3 in /docs Bumps [jinja2](https://github.com/pallets/jinja) from 3.0.3 to 3.1.3. - [Release notes](https://github.com/pallets/jinja/releases) - [Changelog](https://github.com/pallets/jinja/blob/main/CHANGES.rst) - [Commits](https://github.com/pallets/jinja/compare/3.0.3...3.1.3) --- updated-dependencies: - dependency-name: jinja2 dependency-type: direct:production ... Signed-off-by: dependabot[bot] --- docs/requirements.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/requirements.txt b/docs/requirements.txt index 3904834c2e..f4542df711 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -3,4 +3,4 @@ mkdocs==1.2.3 # TODO: temporary workaround for deprecated usage (https://github.com/mkdocs/mkdocs/issues/2794#issuecomment-1077705509) -jinja2==3.0.3 +jinja2==3.1.3 From de8ee5e039d064a73c7ed4faa197de6e079d231b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Fri, 12 Jan 2024 11:16:54 +0200 Subject: [PATCH 429/517] Update mkdocs version --- docs/requirements.txt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/docs/requirements.txt b/docs/requirements.txt index f4542df711..c86e84d8e8 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,6 +1,5 @@ # Python requirements for MkDocs and Read the Docs -mkdocs==1.2.3 +mkdocs==1.2.4 -# TODO: temporary workaround for deprecated usage (https://github.com/mkdocs/mkdocs/issues/2794#issuecomment-1077705509) jinja2==3.1.3 From 022a9bcaadc762c2f5d46db7d564c55dec58ba72 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 10:38:40 +0100 Subject: [PATCH 430/517] `affeq`: Fix array OOB in `invariant` --- .../apron/affineEqualityDomain.apron.ml | 2 +- tests/regression/63-affeq/19-witness.c | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) create mode 100644 tests/regression/63-affeq/19-witness.c diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ab24515c28..ce3f2592f4 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -681,7 +681,7 @@ struct let invariant t = let invariant m = let earray = Lincons1.array_make t.env (Matrix.num_rows m) in - for i = 0 to Lincons1.array_length earray do + for i = 0 to (Lincons1.array_length earray -1) do let row = Matrix.get_row m i in let coeff_vars = List.map (fun x -> Coeff.s_of_mpqf @@ Vector.nth row (Environment.dim_of_var t.env x), x) (vars t) in let cst = Coeff.s_of_mpqf @@ Vector.nth row (Vector.length row - 1) in diff --git a/tests/regression/63-affeq/19-witness.c b/tests/regression/63-affeq/19-witness.c new file mode 100644 index 0000000000..1659e01cb6 --- /dev/null +++ b/tests/regression/63-affeq/19-witness.c @@ -0,0 +1,18 @@ +//SKIP PARAM: --set ana.activated[+] affeq --set sem.int.signed_overflow assume_none --set ana.relation.privatization top --enable witness.yaml.enabled +// Identical to Example 63/01; additionally checking that writing out witnesses does not crash the analyzer +#include + +void main(void) { + int i; + int j; + int k; + i = 2; + j = k + 5; + + while (i < 100) { + __goblint_check(3 * i - j + k == 1); + i = i + 1; + j = j + 3; + } + __goblint_check(3 * i - j + k == 1); +} From f99f320118a84ec0c243ca3aeda40737e450e376 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 12:53:45 +0100 Subject: [PATCH 431/517] Simplify --- src/cdomains/apron/affineEqualityDomain.apron.ml | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index ce3f2592f4..bc1cfe41cf 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -680,19 +680,15 @@ struct let invariant t = let invariant m = - let earray = Lincons1.array_make t.env (Matrix.num_rows m) in - for i = 0 to (Lincons1.array_length earray -1) do + let one_constraint i = let row = Matrix.get_row m i in let coeff_vars = List.map (fun x -> Coeff.s_of_mpqf @@ Vector.nth row (Environment.dim_of_var t.env x), x) (vars t) in let cst = Coeff.s_of_mpqf @@ Vector.nth row (Vector.length row - 1) in - Lincons1.set_list (Lincons1.array_get earray i) coeff_vars (Some cst) - done; - let {lincons0_array; array_env}: Lincons1.earray = earray in - Array.enum lincons0_array - |> Enum.map (fun (lincons0: Lincons0.t) -> - Lincons1.{lincons0; env = array_env} - ) - |> List.of_enum + let e1 = Linexpr1.make t.env in + Linexpr1.set_list e1 coeff_vars (Some cst); + Lincons1.make e1 EQ + in + List.init (Matrix.num_rows m) (one_constraint) in BatOption.map_default invariant [] t.d From ca18e353f4beba13867628c96daf78fe3ae059bd Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 14:14:28 +0100 Subject: [PATCH 432/517] Remark on issue with fractional coefficients --- tests/regression/63-affeq/19-witness.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/regression/63-affeq/19-witness.c b/tests/regression/63-affeq/19-witness.c index 1659e01cb6..541aceab29 100644 --- a/tests/regression/63-affeq/19-witness.c +++ b/tests/regression/63-affeq/19-witness.c @@ -15,4 +15,20 @@ void main(void) { j = j + 3; } __goblint_check(3 * i - j + k == 1); + + // Represented with fractional coefficients and thus not put into witness yet + + int a = 0; + int b = 0; + int z = 0; + + while(z < 100) { + a++; + b += 2; + z++; + + __goblint_check(2*z - b == 0); + // b == 2*z is put into the witness + } + } From 2c580b186e69706b54e03c28f0f6253566b9bea3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 12 Jan 2024 16:37:03 +0200 Subject: [PATCH 433/517] Revert "Consider alloca in special in memLeak" This reverts commit 1ec35c454e47024431a9dd06cd8b35e416ccd5cd. --- src/analyses/memLeak.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 87a1e26433..456d434be7 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -204,8 +204,7 @@ struct match desc.special arglist with | Malloc _ | Calloc _ - | Realloc _ - | Alloca _ -> + | Realloc _ -> ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> From a521bdf24abf6a24c3086fd25be30722f99b8d7b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 12 Jan 2024 17:02:24 +0100 Subject: [PATCH 434/517] Rm spurious parens Co-authored-by: Julian Erhard --- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index bc1cfe41cf..55937a323d 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -688,7 +688,7 @@ struct Linexpr1.set_list e1 coeff_vars (Some cst); Lincons1.make e1 EQ in - List.init (Matrix.num_rows m) (one_constraint) + List.init (Matrix.num_rows m) one_constraint in BatOption.map_default invariant [] t.d From 1cbbd2549b367ecc9a223bfc02d9f576554d16c8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 13:53:40 +0200 Subject: [PATCH 435/517] Use Z module instead of IntOps.BigIntOps in base --- src/analyses/base.ml | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index fb2b5af517..440a1fcd96 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -19,7 +19,6 @@ module Addr = ValueDomain.Addr module Offs = ValueDomain.Offs module LF = LibraryFunctions module CArrays = ValueDomain.CArrays -module BI = IntOps.BigIntOps module PU = PrecisionUtil module VD = BaseDomain.VD @@ -247,7 +246,7 @@ struct if M.tracing then M.tracel "eval" "evalbinop %a %a %a\n" d_binop op VD.pretty a1 VD.pretty a2; (* We define a conversion function for the easy cases when we can just use * the integer domain operations. *) - let bool_top ik = ID.(join (of_int ik BI.zero) (of_int ik BI.one)) in + let bool_top ik = ID.(join (of_int ik Z.zero) (of_int ik Z.one)) in (* An auxiliary function for ptr arithmetic on array values. *) let addToAddr n (addr:Addr.t) = let typeOffsetOpt o t = @@ -270,7 +269,7 @@ struct begin match t with | Some t -> let (f_offset_bits, _) = bitsOffset t (Field (f, NoOffset)) in - let f_offset = IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) (BI.of_int (f_offset_bits / 8)) in + let f_offset = IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) (Z.of_int (f_offset_bits / 8)) in begin match IdxDom.(to_bool (eq f_offset (neg n_offset))) with | Some true -> `NoOffset | _ -> `Field (f, `Index (n_offset, `NoOffset)) @@ -286,7 +285,7 @@ struct | `NoOffset -> `Index(iDtoIdx n, `NoOffset) in let default = function - | Addr.NullPtr when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> Addr.NullPtr + | Addr.NullPtr when GobOption.exists (Z.equal Z.zero) (ID.to_int n) -> Addr.NullPtr | _ -> Addr.UnknownPtr in match Addr.to_mval addr with @@ -388,9 +387,9 @@ struct Int (ID.top_of ik) end | Eq -> - Int (if AD.is_bot (AD.meet p1 p2) then ID.of_int ik BI.zero else match eq p1 p2 with Some x when x -> ID.of_int ik BI.one | _ -> bool_top ik) + Int (if AD.is_bot (AD.meet p1 p2) then ID.of_int ik Z.zero else match eq p1 p2 with Some x when x -> ID.of_int ik Z.one | _ -> bool_top ik) | Ne -> - Int (if AD.is_bot (AD.meet p1 p2) then ID.of_int ik BI.one else match eq p1 p2 with Some x when x -> ID.of_int ik BI.zero | _ -> bool_top ik) + Int (if AD.is_bot (AD.meet p1 p2) then ID.of_int ik Z.one else match eq p1 p2 with Some x when x -> ID.of_int ik Z.zero | _ -> bool_top ik) | IndexPI when AD.to_string p2 = ["all_index"] -> addToAddrOp p1 (ID.top_of (Cilfacade.ptrdiff_ikind ())) | IndexPI | PlusPI -> @@ -871,7 +870,7 @@ struct (* CIL's very nice implicit conversion of an array name [a] to a pointer * to its first element [&a[0]]. *) | StartOf lval -> - let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset) in + let array_ofs = `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in Address (AD.map array_start (eval_lv a gs st lval)) | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv a gs st (Const (CStr (x,e))) (* TODO safe? *) @@ -974,11 +973,11 @@ struct match op with | MinusA when must_be_equal () -> let ik = Cilfacade.get_ikind t in - Int (ID.of_int ik BI.zero) + Int (ID.of_int ik Z.zero) | MinusPI (* TODO: untested *) | MinusPP when must_be_equal () -> let ik = Cilfacade.ptrdiff_ikind () in - Int (ID.of_int ik BI.zero) + Int (ID.of_int ik Z.zero) (* Eq case is unnecessary: Q.must_be_equal reconstructs BinOp (Eq, _, _, _) and repeats EvalInt query for that, yielding a top from query cycle and never being must equal *) | Le | Ge when must_be_equal () -> @@ -1258,7 +1257,7 @@ struct | _ -> None in let alen = Seq.filter_map (fun v -> lenOf v.vtype) (List.to_seq (AD.to_var_may a)) in - let d = Seq.fold_left ID.join (ID.bot_of (Cilfacade.ptrdiff_ikind ())) (Seq.map (ID.of_int (Cilfacade.ptrdiff_ikind ()) %BI.of_int) (Seq.append slen alen)) in + let d = Seq.fold_left ID.join (ID.bot_of (Cilfacade.ptrdiff_ikind ())) (Seq.map (ID.of_int (Cilfacade.ptrdiff_ikind ()) %Z.of_int) (Seq.append slen alen)) in (* ignore @@ printf "EvalLength %a = %a\n" d_exp e ID.pretty d; *) `Lifted d | Bot -> Queries.Result.bot q (* TODO: remove *) @@ -1291,7 +1290,7 @@ struct (match r with | Array a -> (* unroll into array for Calloc calls *) - (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -2457,7 +2456,7 @@ struct 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 + | Int n when GobOption.exists (Z.equal Z.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] @@ -2517,8 +2516,8 @@ struct let blobsize = ID.mul (ID.cast_to ik @@ sizeval) (ID.cast_to ik @@ countval) in (* the memory that was allocated by calloc is set to bottom, but we keep track that it originated from calloc, so when bottom is read from memory allocated by calloc it is turned to zero *) set_many ~ctx (Analyses.ask_of_ctx ctx) gs st [ - (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.one) (Blob (VD.bot (), blobsize, false)))); - (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))))) + (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.one) (Blob (VD.bot (), blobsize, false)))); + (eval_lv (Analyses.ask_of_ctx ctx) gs st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero, `NoOffset))))) ] ) | _ -> st @@ -2534,7 +2533,7 @@ struct match p_rv with | Address a -> a (* TODO: don't we already have logic for this? *) - | Int i when ID.to_int i = Some BI.zero -> AD.null_ptr + | Int i when ID.to_int i = Some Z.zero -> AD.null_ptr | Int i -> AD.top_ptr | _ -> AD.top_ptr (* TODO: why does this ever happen? *) in @@ -2574,7 +2573,7 @@ struct in begin match lv with | Some lv -> - set ~ctx ask gs st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt BI.zero)) + set ~ctx ask gs st' (eval_lv ask ctx.global st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt Z.zero)) | None -> st' end | Longjmp {env; value}, _ -> From 5946b03aa50f60fe2a38ed5622e4db37e5c78143 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 13:59:30 +0200 Subject: [PATCH 436/517] Use Z module instead of IntOps.BigIntOps in baseInvariant --- src/analyses/baseInvariant.ml | 47 +++++++++++++++++------------------ 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f18eeed24f..7176ea5695 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -7,7 +7,6 @@ module VD = BaseDomain.VD module ID = ValueDomain.ID module FD = ValueDomain.FD module AD = ValueDomain.AD -module BI = IntOps.BigIntOps module type Eval = sig @@ -140,7 +139,7 @@ struct match ID.to_int n with | Some n -> (* When x != n, we can return a singleton exclusion set *) - if M.tracing then M.tracec "invariant" "Yes, %a is not %s\n" d_lval x (BI.to_string n); + if M.tracing then M.tracec "invariant" "Yes, %a is not %s\n" d_lval x (Z.to_string n); let ikind = Cilfacade.get_ikind_exp (Lval lval) in Some (x, Int (ID.of_excl_list ikind [n])) | None -> None @@ -169,11 +168,11 @@ struct | Int n -> begin let ikind = Cilfacade.get_ikind_exp (Lval lval) in let n = ID.cast_to ikind n in - let range_from x = if tv then ID.ending ikind (BI.sub x BI.one) else ID.starting ikind x in + let range_from x = if tv then ID.ending ikind (Z.sub x Z.one) else ID.starting ikind x in let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> - if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (BI.to_string n); + if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (Z.to_string n); Some (x, Int (range_from n)) | None -> None end @@ -184,11 +183,11 @@ struct | Int n -> begin let ikind = Cilfacade.get_ikind_exp (Lval lval) in let n = ID.cast_to ikind n in - let range_from x = if tv then ID.ending ikind x else ID.starting ikind (BI.add x BI.one) in + let range_from x = if tv then ID.ending ikind x else ID.starting ikind (Z.add x Z.one) in let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> - if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (BI.to_string n); + if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (Z.to_string n); Some (x, Int (range_from n)) | None -> None end @@ -205,7 +204,7 @@ struct match Cil.unrollType typ with | TPtr _ -> Address AD.null_ptr | TEnum({ekind=_;_},_) - | _ -> Int (ID.of_int (Cilfacade.get_ikind typ) BI.zero) + | _ -> Int (ID.of_int (Cilfacade.get_ikind typ) Z.zero) in let rec derived_invariant exp tv = let switchedOp = function Lt -> Gt | Gt -> Lt | Le -> Ge | Ge -> Le | x -> x in (* a op b <=> b (switchedOp op) b *) @@ -255,7 +254,7 @@ struct (* ikind is the type of a for limiting ranges of the operands a, b. The only binops which can have different types for a, b are Shiftlt, Shiftrt (not handled below; don't use ikind to limit b there). *) let inv_bin_int (a, b) ikind c op = let warn_and_top_on_zero x = - if GobOption.exists (BI.equal BI.zero) (ID.to_int x) then + if GobOption.exists (Z.equal Z.zero) (ID.to_int x) then (M.error ~category:M.Category.Integer.div_by_zero ~tags:[CWE 369] "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; ID.top_of ikind) else @@ -278,7 +277,7 @@ struct (* refine x by information about y, using x * y == c *) let refine_by x y = (match ID.to_int y with | None -> x - | Some v when BI.equal (BI.rem v (BI.of_int 2)) BI.zero (* v % 2 = 0 *) -> x (* A refinement would still be possible here, but has to take non-injectivity into account. *) + | Some v when Z.equal (Z.rem v (Z.of_int 2)) Z.zero (* v % 2 = 0 *) -> x (* A refinement would still be possible here, but has to take non-injectivity into account. *) | Some v (* when Int64.rem v 2L = 1L *) -> id_meet_down ~old:x ~c:(ID.div c y)) (* Div is ok here, c must be divisible by a and b *) in (refine_by a b, refine_by b a) @@ -290,11 +289,11 @@ struct * However, a%b will give [-b+1, b-1] for a=top, but we only want the positive/negative side depending on the sign of c*b. * If c*b = 0 or it can be positive or negative, we need the full range for the remainder. *) let rem = - let is_pos = ID.to_bool @@ ID.gt (ID.mul b c) (ID.of_int ikind BI.zero) = Some true in - let is_neg = ID.to_bool @@ ID.lt (ID.mul b c) (ID.of_int ikind BI.zero) = Some true in + let is_pos = ID.to_bool @@ ID.gt (ID.mul b c) (ID.of_int ikind Z.zero) = Some true in + let is_neg = ID.to_bool @@ ID.lt (ID.mul b c) (ID.of_int ikind Z.zero) = Some true in let full = ID.rem a b in - if is_pos then ID.meet (ID.starting ikind BI.zero) full - else if is_neg then ID.meet (ID.ending ikind BI.zero) full + if is_pos then ID.meet (ID.starting ikind Z.zero) full + else if is_neg then ID.meet (ID.ending ikind Z.zero) full else full in meet_bin (ID.add (ID.mul b c) rem) (ID.div (ID.sub a rem) c) @@ -310,11 +309,11 @@ struct * If b is negative we have to look at the lower bound. *) let is_divisible bound = match bound a with - | Some ba -> ID.rem (ID.of_int ikind ba) b |> ID.to_int = Some BI.zero + | Some ba -> ID.rem (ID.of_int ikind ba) b |> ID.to_int = Some Z.zero | None -> false in - let max_pos = match ID.maximal b with None -> true | Some x -> BI.compare x BI.zero >= 0 in - let min_neg = match ID.minimal b with None -> true | Some x -> BI.compare x BI.zero < 0 in + let max_pos = match ID.maximal b with None -> true | Some x -> Z.compare x Z.zero >= 0 in + let min_neg = match ID.minimal b with None -> true | Some x -> Z.compare x Z.zero < 0 in let implies a b = not a || b in let a'' = if implies max_pos (is_divisible ID.maximal) && implies min_neg (is_divisible ID.minimal) then @@ -333,10 +332,10 @@ struct let a,b = meet_bin a''' b' in (* Special handling for case a % 2 != c *) let a = if PrecisionUtil.(is_congruence_active (int_precision_from_node_or_config ())) then - let two = BI.of_int 2 in + let two = Z.of_int 2 in match ID.to_int b, ID.to_excl_list c with - | Some b, Some ([v], _) when BI.equal b two -> - let k = if BI.equal (BI.abs (BI.rem v two)) (BI.zero) then BI.one else BI.zero in + | Some b, Some ([v], _) when Z.equal b two -> + let k = if Z.equal (Z.abs (Z.rem v two)) Z.zero then Z.one else Z.zero in ID.meet (ID.of_congruence ikind (k, b)) a | _, _ -> a else a @@ -381,8 +380,8 @@ struct | _, _ -> a, b end | Lt | Le | Ge | Gt as op -> - let pred x = BI.sub x BI.one in - let succ x = BI.add x BI.one in + let pred x = Z.sub x Z.one in + let succ x = Z.add x Z.one in (match ID.minimal a, ID.maximal a, ID.minimal b, ID.maximal b with | Some l1, Some u1, Some l2, Some u2 -> (* if M.tracing then M.tracel "inv" "Op: %s, l1: %Ld, u1: %Ld, l2: %Ld, u2: %Ld\n" (show_binop op) l1 u1 l2 u2; *) @@ -414,7 +413,7 @@ struct (* we only attempt to refine a here *) let a = match ID.to_int b with - | Some x when BI.equal x BI.one -> + | Some x when Z.equal x Z.one -> (match ID.to_bool c with | Some true -> ID.meet a (ID.of_congruence ikind (Z.one, Z.of_int 2)) | Some false -> ID.meet a (ID.of_congruence ikind (Z.zero, Z.of_int 2)) @@ -574,7 +573,7 @@ struct | Some true -> (* i.e. e should evaluate to [1,1] *) (* LNot x is 0 for any x != 0 *) - ID.of_excl_list ikind [BI.zero] + ID.of_excl_list ikind [Z.zero] | Some false -> ID.of_bool ikind false | _ -> ID.top_of ikind in @@ -810,7 +809,7 @@ struct let itv = if not tv || is_cmp exp then (* false is 0, but true can be anything that is not 0, except for comparisons which yield 1 *) ID.of_bool ik tv (* this will give 1 for true which is only ok for comparisons *) else - ID.of_excl_list ik [BI.zero] (* Lvals, Casts, arithmetic operations etc. should work with true = non_zero *) + ID.of_excl_list ik [Z.zero] (* Lvals, Casts, arithmetic operations etc. should work with true = non_zero *) in inv_exp (Int itv) exp st | exception Invalid_argument _ -> From 2df6d669375a00babbb760a641ab3c39d4154814 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:06:31 +0200 Subject: [PATCH 437/517] Use Z module instead of IntOps.BigIntOps in arrayDomain --- src/cdomain/value/cdomains/arrayDomain.ml | 43 +++++++++++------------ 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/src/cdomain/value/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml index d4d5a46e98..162d782951 100644 --- a/src/cdomain/value/cdomains/arrayDomain.ml +++ b/src/cdomain/value/cdomains/arrayDomain.ml @@ -5,7 +5,6 @@ open FlagHelper module M = Messages module A = Array -module BI = IntOps.BigIntOps module VDQ = ValueDomainQueries type domain = TrivialDomain | PartitionedDomain | UnrolledDomain @@ -53,9 +52,9 @@ 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 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 + val smart_join: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> t + val smart_widen: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> t + val smart_leq: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> bool val update_length: idx -> t -> t val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t @@ -102,9 +101,9 @@ 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 + val smart_join: (Cil.exp -> Z.t option) -> (Cil.exp -> Z.t option) -> t -> t -> t + val smart_widen: (Cil.exp -> Z.t option) -> (Cil.exp -> Z.t option) -> t -> t -> t + val smart_leq: (Cil.exp -> Z.t option) -> (Cil.exp -> Z.t option) -> t -> t -> bool end module type Null = @@ -305,9 +304,9 @@ module type SPartitioned = sig include S val set_with_length: idx option -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t - val smart_join_with_length: idx option -> (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t - val smart_widen_with_length: idx option -> (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t-> t - val smart_leq_with_length: idx option -> (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool + val smart_join_with_length: idx option -> (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> t + val smart_widen_with_length: idx option -> (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t-> t + val smart_leq_with_length: idx option -> (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> bool val move_if_affected_with_length: ?replace_with_const:bool -> idx option -> VDQ.t -> t -> Cil.varinfo -> (Cil.exp -> int option) -> t end @@ -549,15 +548,15 @@ struct let use_last = get_string "ana.base.partition-arrays.keep-expr" = "last" in let exp_value e = let n = ask.eval_int e in - Option.map BI.of_bigint (VDQ.ID.to_int n) + VDQ.ID.to_int n in - let equals_zero e = BatOption.map_default (BI.equal BI.zero) false (exp_value e) in + let equals_zero e = BatOption.map_default (Z.equal Z.zero) false (exp_value e) in let equals_maxIndex e = match length with | Some l -> begin match Idx.to_int l with - | Some i -> BatOption.map_default (BI.equal (BI.sub i BI.one)) false (exp_value e) + | Some i -> BatOption.map_default (Z.equal (Z.sub i Z.one)) false (exp_value e) | None -> false end | _ -> false @@ -597,10 +596,10 @@ struct else if Cil.isConstant e && Cil.isConstant i' then match Cil.getInteger e, Cil.getInteger i' with | Some (e'': Cilint.cilint), Some i'' -> - if BI.equal i'' (BI.add e'' BI.one) then + if Z.equal i'' (Z.add e'' Z.one) then (* If both are integer constants and they are directly adjacent, we change partitioning to maintain information *) Partitioned (i', (Val.join xl xm, a, xr)) - else if BI.equal e'' (BI.add i'' BI.one) then + else if Z.equal e'' (Z.add i'' Z.one) then Partitioned (i', (xl, a, Val.join xm xr)) else default @@ -658,7 +657,7 @@ struct let make ?(varAttr=[]) ?(typAttr=[]) i v:t = - if Idx.to_int i = Some BI.one then + if Idx.to_int i = Some Z.one then Partitioned ((Cil.integer 0), (v, v, v)) else if Val.is_bot v then Joint (Val.bot ()) @@ -674,12 +673,12 @@ struct begin match Idx.to_int l with | Some i -> - v = Some (BI.sub i BI.one) + v = Some (Z.sub i Z.one) | None -> false end | None -> false in - let must_be_zero v = v = Some BI.zero in + let must_be_zero v = v = Some Z.zero in let op_over_all = op (join_of_all_parts x1) (join_of_all_parts x2) in match x1, x2 with | Partitioned (e1, (xl1, xm1, xr1)), Partitioned (e2, (xl2, xm2, xr2)) when Basetype.CilExp.equal e1 e2 -> @@ -743,13 +742,13 @@ struct let smart_leq_with_length length x1_eval_int x2_eval_int x1 x2 = let leq' = Val.smart_leq x1_eval_int x2_eval_int in - let must_be_zero v = (v = Some BI.zero) in + let must_be_zero v = (v = Some Z.zero) in let must_be_length_minus_one v = match length with | Some l -> begin match Idx.to_int l with | Some i -> - v = Some (BI.sub i BI.one) + v = Some (Z.sub i Z.one) | None -> false end | None -> false @@ -835,7 +834,7 @@ end 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 *) let idx_before_end = Idx.to_bool (Idx.lt v l) (* check whether index is before the end of the array *) - and idx_after_start = Idx.to_bool (Idx.ge v (Idx.of_int Cil.ILong BI.zero)) in (* check whether the index is non-negative *) + and idx_after_start = Idx.to_bool (Idx.ge v (Idx.of_int Cil.ILong Z.zero)) in (* check whether the index is non-negative *) (* For an explanation of the warning types check the Pull Request #255 *) match(idx_after_start, idx_before_end) with | Some true, Some true -> (* Certainly in bounds on both sides.*) @@ -1739,7 +1738,7 @@ struct | UnrolledDomain -> (None, None, Some (U.make i v)) (* convert to another domain *) - let index_as_expression i = (Some (Cil.integer i), Idx.of_int IInt (BI.of_int i)) + let index_as_expression i = (Some (Cil.integer i), Idx.of_int IInt (Z.of_int i)) let partitioned_of_trivial ask t = P.make (Option.value (T.length t) ~default:(Idx.top ())) (T.get ~checkBounds:false ask t (index_as_expression 0)) From 643bd414d135b47993de585da94e0e8f0591d53d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:08:31 +0200 Subject: [PATCH 438/517] Use Z module instead of IntOps.BigIntOps in valueDomain --- src/cdomain/value/cdomains/valueDomain.ml | 31 +++++++++++------------ 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/cdomain/value/cdomains/valueDomain.ml b/src/cdomain/value/cdomains/valueDomain.ml index d1b81dcb08..0fd8fa79fb 100644 --- a/src/cdomain/value/cdomains/valueDomain.ml +++ b/src/cdomain/value/cdomains/valueDomain.ml @@ -7,7 +7,6 @@ open PrecisionUtil include PreValueDomain module Offs = Offset.MakeLattice (IndexDomain) module M = Messages -module BI = IntOps.BigIntOps module MutexAttr = MutexAttrDomain module VDQ = ValueDomainQueries module AD = VDQ.AD @@ -27,9 +26,9 @@ sig 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 - 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 smart_join: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> t + val smart_widen: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> t + val smart_leq: (exp -> Z.t option) -> (exp -> Z.t option) -> t -> t -> bool val is_immediate_type: typ -> bool val is_mutex_type: typ -> bool val bot_value: ?varAttr:attributes -> typ -> t @@ -231,7 +230,7 @@ struct | _ when is_mutex_type t -> Mutex | t when is_jmp_buf_type t -> JmpBuf (JmpBufs.top ()) | t when is_mutexattr_type t -> MutexAttr (MutexAttrDomain.top ()) - | TInt (ikind, _) -> Int (ID.of_int ikind BI.zero) + | TInt (ikind, _) -> Int (ID.of_int ikind Z.zero) | TFloat (fkind, _) when not (Cilfacade.isComplexFKind fkind) -> Float (FD.of_const fkind 0.0) | TPtr _ -> Address AD.null_ptr | TComp ({cstruct=true; _} as ci,_) -> Struct (Structs.create (fun fd -> zero_init_value ~varAttr:fd.fattr fd.ftype) ci) @@ -398,7 +397,7 @@ struct (* array to its first element *) | TArray _, _ -> M.tracel "casta" "cast array to its first element\n"; - adjust_offs v (Addr.Offs.add_offset o (`Index (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero, `NoOffset))) (Some false) + adjust_offs v (Addr.Offs.add_offset o (`Index (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero, `NoOffset))) (Some false) | _ -> err @@ Format.sprintf "Cast to neither array index nor struct field. is_zero_offset: %b" (Addr.Offs.cmp_zero_offset o = `MustZero) end in @@ -473,7 +472,7 @@ struct (* cast to voidPtr are ignored TODO what happens if our value does not fit? *) | TPtr (t,_) -> Address (match v with - | Int x when ID.to_int x = Some BI.zero -> AD.null_ptr + | Int x when ID.to_int x = Some Z.zero -> AD.null_ptr | Int x -> AD.top_ptr (* we ignore casts to void*! TODO report UB! *) | Address x -> (match t with TVoid _ -> x | _ -> cast_addr t x) @@ -532,7 +531,7 @@ struct | (_, Bot) -> false | (Int x, Int y) -> ID.leq x y | (Float x, Float y) -> FD.leq x y - | (Int x, Address y) when ID.to_int x = Some BI.zero && not (AD.is_not_null y) -> true + | (Int x, Address y) when ID.to_int x = Some Z.zero && not (AD.is_not_null y) -> true | (Int _, Address y) when AD.may_be_unknown y -> true | (Address _, Int y) when ID.is_top_of (Cilfacade.ptrdiff_ikind ()) y -> true | (Address x, Address y) -> AD.leq x y @@ -560,7 +559,7 @@ struct | (Float x, Float y) -> Float (FD.join x y) | (Int x, Address y) | (Address y, Int x) -> Address (match ID.to_int x with - | Some x when BI.equal x BI.zero -> AD.join AD.null_ptr y + | Some x when Z.equal x Z.zero -> AD.join AD.null_ptr y | Some x -> AD.(join y not_null) | None -> AD.join y AD.top_ptr) | (Address x, Address y) -> Address (AD.join x y) @@ -593,7 +592,7 @@ struct (* TODO: symmetric widen, wtf? *) | (Int x, Address y) | (Address y, Int x) -> Address (match ID.to_int x with - | Some x when BI.equal x BI.zero -> AD.widen AD.null_ptr (AD.join AD.null_ptr y) + | Some x when Z.equal x Z.zero -> AD.widen AD.null_ptr (AD.join AD.null_ptr y) | Some x -> AD.(widen y (join y not_null)) | None -> AD.widen y (AD.join y AD.top_ptr)) | (Address x, Address y) -> Address (AD.widen x y) @@ -916,7 +915,7 @@ struct begin do_eval_offset ask f x offs exp l' o' v t (* this used to be `blob `address -> we ignore the index *) end - | x when GobOption.exists (BI.equal (BI.zero)) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t + | x when GobOption.exists (Z.equal Z.zero) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t | Top -> M.info ~category:Imprecise "Trying to read an index, but the array is unknown"; top () | _ -> M.warn ~category:Imprecise ~tags:[Category Program] "Trying to read an index, but was not given an array (%a)" pretty x; top () end @@ -960,7 +959,7 @@ struct 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.bitsSizeOf (TComp (toptype, []))/8) + && Z.equal (Option.get blob_size_opt) (Z.of_int @@ Cil.bitsSizeOf (TComp (toptype, []))/8) | _ -> false in if do_strong_update then @@ -981,7 +980,7 @@ struct && Option.is_some blob_size_opt (* Size of blob is known *) && (( not @@ Cil.isVoidType t (* Size of value is known *) - && BI.equal (Option.get blob_size_opt) (BI.of_int @@ Cil.alignOf_int t) + && Z.equal (Option.get blob_size_opt) (Z.of_int @@ Cil.alignOf_int t) ) || blob_destructive) | _ -> false end @@ -1062,10 +1061,10 @@ struct | TArray(_, l, _) -> let len = try Cil.lenOfArray l with Cil.LenOfArray -> 42 (* will not happen, VLA not allowed in union and struct *) in - Array(CArrays.make (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) (BI.of_int len)) Top), offs + Array(CArrays.make (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) (Z.of_int len)) Top), offs | _ -> top (), offs (* will not happen*) end - | `Index (idx, _) when IndexDomain.equal idx (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero) -> + | `Index (idx, _) when IndexDomain.equal idx (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero) -> (* Why does cil index unions? We'll just pick the first field. *) top (), `Field (List.nth fld.fcomp.cfields 0,`NoOffset) | _ -> M.warn ~category:Analyzer ~tags:[Category Unsound] "Indexing on a union is unusual, and unsupported by the analyzer"; @@ -1102,7 +1101,7 @@ struct let new_array_value = CArrays.update_length newl new_array_value in Array new_array_value | Top -> M.warn ~category:Imprecise "Trying to update an index, but the array is unknown"; top () - | x when GobOption.exists (BI.equal BI.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t + | x when GobOption.exists (Z.equal Z.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t | _ -> M.warn ~category:Imprecise "Trying to update an index, but was not given an array(%a)" pretty x; top () end in mu result From f16cfca56d4ea287fcc3a457462db56ebb7bfa97 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:10:46 +0200 Subject: [PATCH 439/517] Remove BI module and use Z instead of IntOps.BigIntOps in baseDomain --- src/cdomains/baseDomain.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/cdomains/baseDomain.ml b/src/cdomains/baseDomain.ml index ce6cc171fa..ba4b5b073b 100644 --- a/src/cdomains/baseDomain.ml +++ b/src/cdomains/baseDomain.ml @@ -2,7 +2,6 @@ open GoblintCil module VD = ValueDomain.Compound -module BI = IntOps.BigIntOps module CPA = struct @@ -123,7 +122,7 @@ end module type ExpEvaluator = sig type t - val eval_exp: t -> Cil.exp -> IntOps.BigIntOps.t option + val eval_exp: t -> Cil.exp -> Z.t option end (* Takes a module for privatization component and a module specifying how expressions can be evaluated inside the domain and returns the domain *) From 27b267d91ce4dd498cbda2760efd26e774c0968b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:11:44 +0200 Subject: [PATCH 440/517] Use Z instead of IntOps.BigIntOps in function types in vectorMatrix --- src/cdomains/vectorMatrix.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/vectorMatrix.ml b/src/cdomains/vectorMatrix.ml index 1dd684a4c0..64d5c5e35d 100644 --- a/src/cdomains/vectorMatrix.ml +++ b/src/cdomains/vectorMatrix.ml @@ -24,8 +24,8 @@ sig val of_int: int -> t val zero: t val one: t - val get_den: t -> IntOps.BigIntOps.t - val get_num: t -> IntOps.BigIntOps.t + val get_den: t -> Z.t + val get_num: t -> Z.t end (** It provides more readable infix operators for the functions of RatOps. From ad093889192be3d6d48a06979e46d7c7d03a25df Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:14:44 +0200 Subject: [PATCH 441/517] Remove BI module and use Z instead of IntOps.BigIntOps in intDomainProperties --- src/domains/intDomainProperties.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index 9dcb867efc..fa41ba645e 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -1,20 +1,19 @@ (** QCheck properties for {!IntDomain}. *) open GoblintCil -module BI = IntOps.BigIntOps (* TODO: deduplicate with IntDomain *) module type OldS = sig include Lattice.S include IntDomain.Arith with type t := t - val of_int: BI.t -> t - val to_int: t -> BI.t option + val of_int: Z.t -> t + val to_int: t -> Z.t option val of_bool: bool -> t val to_bool: t -> bool option - val of_excl_list: Cil.ikind -> BI.t list -> t + val of_excl_list: Cil.ikind -> Z.t list -> t val is_excl_list: t -> bool - val to_excl_list: t -> (BI.t list * (int64 * int64)) option + val to_excl_list: t -> (Z.t list * (int64 * int64)) option end module type OldSWithIkind = @@ -23,7 +22,7 @@ sig module Ikind: IntDomain.Ikind end -module type S = IntDomain.S with type int_t = BI.t +module type S = IntDomain.S with type int_t = Z.t (* TODO: deduplicate with IntDomain, extension of IntDomWithDefaultIkind, inverse of OldDomainFacade? *) module WithIkind (I: S) (Ik: IntDomain.Ikind): OldSWithIkind = @@ -140,8 +139,8 @@ struct let valid_bitxor = make_valid2 ~name:"bitxor" ~cond:none_bot CD.bitxor AD.bitxor let defined_shift (a, b) = - let max_shift = BI.of_int @@ snd @@ IntDomain.Size.bits (AD.Ikind.ikind ()) in - CD.for_all (fun x -> BI.compare BI.zero x <= 0 && BI.compare x max_shift <= 0) b + let max_shift = Z.of_int @@ snd @@ IntDomain.Size.bits (AD.Ikind.ikind ()) in + CD.for_all (fun x -> Z.compare Z.zero x <= 0 && Z.compare x max_shift <= 0) b let shift_cond p = none_bot p && defined_shift p let valid_shift_left = make_valid2 ~name:"shift_left" ~cond:shift_cond CD.shift_left AD.shift_left let valid_shift_right = make_valid2 ~name:"shift_right" ~cond:shift_cond CD.shift_right AD.shift_right From 9cf5086b075212bcc4af4a8596f1503b572571b1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:15:39 +0200 Subject: [PATCH 442/517] Use Z instead of IntOps.BigIntOps in expressionEvaluation --- src/transform/expressionEvaluation.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/transform/expressionEvaluation.ml b/src/transform/expressionEvaluation.ml index 815e5742f6..8ebdbb9b58 100644 --- a/src/transform/expressionEvaluation.ml +++ b/src/transform/expressionEvaluation.ml @@ -136,7 +136,7 @@ struct | Some x -> begin match Queries.ID.to_int x with (* Evaluable: Definite *) - | Some i -> Some (Some (not(IntOps.BigIntOps.equal i IntOps.BigIntOps.zero))) + | Some i -> Some (Some (not (Z.equal i Z.zero))) (* Evaluable: Inconclusive *) | None -> Some None end From b6ed51531678f283a417587ebc666a39803492a1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:16:54 +0200 Subject: [PATCH 443/517] Use Z instead of IntOps.BigIntOps in transform --- src/transform/transform.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/transform/transform.ml b/src/transform/transform.ml index fe3abb6f08..337f3dfddb 100644 --- a/src/transform/transform.ml +++ b/src/transform/transform.ml @@ -55,7 +55,7 @@ module PartialEval = struct method! vexpr e = let eval e = match Queries.ID.to_int ((ask !loc).Queries.f (Queries.EvalInt e)) with | Some i -> - let e' = integer @@ IntOps.BigIntOps.to_int i in + let e' = integer (Z.to_int i) in ignore @@ Pretty.printf "Replacing non-constant expression %a with %a at %a\n" d_exp e d_exp e' CilType.Location.pretty !loc; e' | None -> From 0edd272e6d83f4506be8a9f067d504e357b088a9 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:19:47 +0200 Subject: [PATCH 444/517] Use Z instead of IntOps.BigIntOps in sharedFunctions.apron --- src/cdomains/apron/sharedFunctions.apron.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index e66be00ae4..ff1f14891e 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -3,10 +3,8 @@ open GoblintCil open Batteries open Apron -module M = Messages - -module BI = IntOps.BigIntOps +module M = Messages let int_of_scalar ?round (scalar: Scalar.t) = if Scalar.is_infty scalar <> 0 then (* infinity means unbounded *) @@ -19,10 +17,10 @@ let int_of_scalar ?round (scalar: Scalar.t) = let+ f = match round with | Some `Floor -> Some (Float.floor f) | Some `Ceil -> Some (Float.ceil f) - | None when Stdlib.Float.is_integer f-> Some f + | None when Stdlib.Float.is_integer f -> Some f | None -> None in - BI.of_bigint (Z.of_float f) + Z.of_float f | Mpqf scalar -> (* octMPQ, boxMPQ, polkaMPQ *) let n = Mpqf.get_num scalar in let d = Mpqf.get_den scalar in @@ -129,7 +127,7 @@ struct let (type_min, type_max) = IntDomain.Size.range ik in let texpr1 = Texpr1.of_expr env expr in match Bounds.bound_texpr d texpr1 with - | Some min, Some max when BI.compare type_min min <= 0 && BI.compare max type_max <= 0 -> () + | Some min, Some max when Z.compare type_min min <= 0 && Z.compare max type_max <= 0 -> () | min_opt, max_opt -> if M.tracing then M.trace "apron" "may overflow: %a (%a, %a)\n" CilType.Exp.pretty exp (Pretty.docOpt (IntDomain.BigInt.pretty ())) min_opt (Pretty.docOpt (IntDomain.BigInt.pretty ())) max_opt; raise (Unsupported_CilExp Overflow) From 7ad9d1a084eb94531c651e9470e28477e510130e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:22:35 +0200 Subject: [PATCH 445/517] Use Z instead of IntOps.BigIntOps in offset --- src/cdomain/value/cdomains/offset.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/offset.ml b/src/cdomain/value/cdomains/offset.ml index 62bab39eb7..bcca0cf1bc 100644 --- a/src/cdomain/value/cdomains/offset.ml +++ b/src/cdomain/value/cdomains/offset.ml @@ -58,7 +58,7 @@ struct let rec cmp_zero_offset : t -> [`MustZero | `MustNonzero | `MayZero] = function | `NoOffset -> `MustZero | `Index (x, o) -> - begin match cmp_zero_offset o, Idx.equal_to (IntOps.BigIntOps.zero) x with + begin match cmp_zero_offset o, Idx.equal_to Z.zero x with | `MustNonzero, _ | _, `Neq -> `MustNonzero | `MustZero, `Eq -> `MustZero From 028fe9c2dde42a8188276d7c0ba3dea985fa8de8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:24:54 +0200 Subject: [PATCH 446/517] Use Z instead of IntOps.BigIntOps in affineEqualityDomain.apron --- src/cdomains/apron/affineEqualityDomain.apron.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 55937a323d..5485dd3f02 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -214,7 +214,7 @@ struct let bound_texpr t texpr = let texpr = Texpr1.to_expr texpr in match Option.bind (get_coeff_vec t texpr) to_constant_opt with - | Some c when Mpqf.get_den c = IntOps.BigIntOps.one -> + | Some c when Mpqf.get_den c = Z.one -> let int_val = Mpqf.get_num c in Some int_val, Some int_val | _ -> None, None @@ -224,7 +224,7 @@ struct let res = bound_texpr d texpr1 in (if M.tracing then match res with - | Some min, Some max -> M.tracel "bounds" "min: %s max: %s" (IntOps.BigIntOps.to_string min) (IntOps.BigIntOps.to_string max) + | Some min, Some max -> M.tracel "bounds" "min: %s max: %s" (Z.to_string min) (Z.to_string max) | _ -> () ); res From 5da716a6172ca542448cb87179639dcce64493c1 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:25:44 +0200 Subject: [PATCH 447/517] Remove unused BI = IntOps.BigIntOps module from apronDomain.apron --- src/cdomains/apron/apronDomain.apron.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index 03b9558621..e78176fc41 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -8,9 +8,6 @@ open GobApron open RelationDomain open SharedFunctions - -module BI = IntOps.BigIntOps - module M = Messages (** Resources for working with Apron: From c6c7cdfd8eb164b27e010413de9b611e92c2ff3d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:39:44 +0200 Subject: [PATCH 448/517] Replace all BI. calls with Z. in intDomain --- src/cdomain/value/cdomains/intDomain.ml | 110 ++++++++++++------------ 1 file changed, 55 insertions(+), 55 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 8a69f7134b..40e2136781 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -280,7 +280,7 @@ sig val invariant: Cil.exp -> t -> Invariant.t end -module type Z = Y with type int_t = BI.t +module type Z = Y with type int_t = Z.t module IntDomLifter (I : S) = @@ -392,7 +392,7 @@ end module Size = struct (* size in bits as int, range as int64 *) open Cil - let sign x = if BI.compare x BI.zero < 0 then `Signed else `Unsigned + let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned let top_typ = TInt (ILongLong, []) let min_for x = intKindForValue x (sign x = `Unsigned) @@ -416,8 +416,8 @@ module Size = struct (* size in bits as int, range as int64 *) let is_cast_injective ~from_type ~to_type = let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%s, %s) -> %a (%s, %s)\n" CilType.Typ.pretty from_type (BI.to_string from_min) (BI.to_string from_max) CilType.Typ.pretty to_type (BI.to_string to_min) (BI.to_string to_max); - BI.compare to_min from_min <= 0 && BI.compare from_max to_max <= 0 + if M.tracing then M.trace "int" "is_cast_injective %a (%s, %s) -> %a (%s, %s)\n" CilType.Typ.pretty from_type (Z.to_string from_min) (Z.to_string from_max) CilType.Typ.pretty to_type (Z.to_string to_min) (Z.to_string to_max); + Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 let cast t x = (* TODO: overflow is implementation-dependent! *) if t = IBool then @@ -445,7 +445,7 @@ module Size = struct (* size in bits as int, range as int64 *) let a, b = size (min_for x) in if b <= 64L then let upper_bound_less = Int64.sub b 1L in - let max_one_less = BI.(pred @@ shift_left BI.one (Int64.to_int upper_bound_less)) in + let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in if x <= max_one_less then a, upper_bound_less else @@ -454,10 +454,10 @@ module Size = struct (* size in bits as int, range as int64 *) a, b (* From the number of bits used to represent a positive value, determines the maximal representable value *) - let max_from_bit_range pos_bits = BI.(pred @@ shift_left BI.one (to_int (BI.of_int64 pos_bits))) + let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) - let min_from_bit_range neg_bits = BI.(if neg_bits = 0L then BI.zero else neg @@ shift_left BI.one (to_int (neg (BI.of_int64 neg_bits)))) + let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) end @@ -1783,9 +1783,9 @@ module BigInt = struct let top_of ik = top () let bot_of ik = bot () let cast_to ik x = Size.cast ik x - let to_bool x = Some (not (BI.equal (BI.zero) x)) + let to_bool x = Some (not (Z.equal Z.zero x)) - let show x = BI.to_string x + let show x = Z.to_string x include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) let arbitrary () = QCheck.map ~rev:to_int64 of_int64 QCheck.int64 end @@ -1805,14 +1805,14 @@ struct type inc = Inc of BISet.t [@@unboxed] let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = BI.add BI.one (BI.add (BI.neg (min_of_range r)) (max_of_range r)) + let cardinality_of_range r = Z.add Z.one (Z.add (Z.neg (min_of_range r)) (max_of_range r)) let cardinality_BISet s = - BI.of_int (BISet.cardinal s) + Z.of_int (BISet.cardinal s) let leq_excl_incl (Exc (xs, r)) (Inc ys) = (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) - let lower_bound_cardinality_a = BI.sub (cardinality_of_range r) (cardinality_BISet xs) in + let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in let card_b = cardinality_BISet ys in if I.compare lower_bound_cardinality_a card_b > 0 then false @@ -1833,13 +1833,13 @@ struct let min_b, max_b = min_of_range s, max_of_range s in let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) if I.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, BI.sub min_b BI.one) + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.sub min_b Z.one) else true in let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) if I.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (BI.add max_b BI.one, max_a) + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.add max_b Z.one, max_a) else true in @@ -1900,12 +1900,12 @@ struct | `Bot -> None let in_range r i = - let lowerb = Exclusion.min_of_range r in - if BI.compare i BI.zero < 0 then BI.compare lowerb i <= 0 - else ( + if Z.compare i Z.zero < 0 then + let lowerb = Exclusion.min_of_range r in + Z.compare lowerb i <= 0 + else let upperb = Exclusion.max_of_range r in - BI.compare i upperb <= 0 - ) + Z.compare i upperb <= 0 let is_top x = x = top () @@ -1921,8 +1921,8 @@ struct if R.leq r r' then (* upcast -> no change *) `Excluded (s, r) else if ik = IBool then (* downcast to bool *) - if S.mem BI.zero s then - `Definite (BI.one) + if S.mem Z.zero s then + `Definite Z.one else `Excluded (S.empty(), r') else @@ -2020,7 +2020,7 @@ struct else let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in - `Excluded ((if BI.equal x BI.zero || BI.equal y BI.zero then S.empty () else S.singleton BI.zero), r) + `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) (* A known value and an exclusion set... the definite value should no * longer be excluded: *) | `Excluded (s,r), `Definite x @@ -2071,14 +2071,14 @@ struct | _ -> None let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) - let not_zero ikind = from_excl ikind (S.singleton BI.zero) + let not_zero ikind = from_excl ikind (S.singleton Z.zero) - let of_bool_cmp ik x = of_int ik (if x then BI.one else BI.zero) + let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) let of_bool = of_bool_cmp let to_bool x = match x with | `Definite x -> BigInt.to_bool x - | `Excluded (s,r) when S.mem BI.zero s -> Some true + | `Excluded (s,r) when S.mem Z.zero s -> Some true | _ -> None let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) @@ -2249,13 +2249,13 @@ struct let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = (* BigInt only accepts int as second argument for shifts; perform conversion here *) let shift_op_big_int a (b: int_t) = - let (b : int) = BI.to_int b in + let (b : int) = Z.to_int b in shift_op a b in (* If one of the parameters of the shift is negative, the result is undefined *) let x_min = minimal x in let y_min = minimal y in - if x_min = None || y_min = None || BI.compare (Option.get x_min) BI.zero < 0 || BI.compare (Option.get y_min) BI.zero < 0 then + if x_min = None || y_min = None || Z.compare (Option.get x_min) Z.zero < 0 || Z.compare (Option.get y_min) Z.zero < 0 then top_of ik else norm ik @@ lift2 shift_op_big_int ik x y @@ -2298,8 +2298,8 @@ struct (Exclusion.min_of_range ikr, Exclusion.max_of_range ikr) in let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in - let imin = if inexact_type_bounds || BI.compare ikmin rmin <> 0 then Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik rmin, e, intType)) else Invariant.none in - let imax = if inexact_type_bounds || BI.compare rmax ikmax <> 0 then Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik rmax, intType)) else Invariant.none in + let imin = if inexact_type_bounds || Z.compare ikmin rmin <> 0 then Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik rmin, e, intType)) else Invariant.none in + let imax = if inexact_type_bounds || Z.compare rmax ikmax <> 0 then Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik rmax, intType)) else Invariant.none in S.fold (fun x a -> let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in Invariant.(a && i) @@ -2410,7 +2410,7 @@ module Enums : S with type int_t = BigInt.t = struct type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) - type int_t = BI.t + type int_t = Z.t let name () = "enums" let bot () = failwith "bot () not implemented for Enums" let top_of ik = Exc (BISet.empty (), size ik) @@ -2486,8 +2486,8 @@ module Enums : S with type int_t = BigInt.t = struct if R.leq r r' then (* upcast -> no change *) Exc (s, r) else if ik = IBool then (* downcast to bool *) - if BISet.mem BI.zero s then - Inc (BISet.singleton BI.one) + if BISet.mem Z.zero s then + Inc (BISet.singleton Z.one) else Exc (BISet.empty(), r') else (* downcast: may overflow *) @@ -2571,22 +2571,22 @@ module Enums : S with type int_t = BigInt.t = struct let neg ?no_ov = lift1 I.neg let add ?no_ov ikind = curry @@ function - | Inc z,x when BISet.is_singleton z && BISet.choose z = BI.zero -> x - | x,Inc z when BISet.is_singleton z && BISet.choose z = BI.zero -> x + | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x | x,y -> lift2 I.add ikind x y let sub ?no_ov = lift2 I.sub let mul ?no_ov ikind a b = match a, b with - | Inc one,x when BISet.is_singleton one && BISet.choose one = BI.one -> x - | x,Inc one when BISet.is_singleton one && BISet.choose one = BI.one -> x - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = BI.zero -> a - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = BI.zero -> b + | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b | x,y -> lift2 I.mul ikind x y let div ?no_ov ikind a b = match a, b with - | x,Inc one when BISet.is_singleton one && BISet.choose one = BI.one -> x - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = BI.zero -> top_of ikind - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = BI.zero -> a + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a | x,y -> lift2 I.div ikind x y let rem = lift2 I.rem @@ -2600,13 +2600,13 @@ module Enums : S with type int_t = BigInt.t = struct handle_bot x y (fun () -> (* BigInt only accepts int as second argument for shifts; perform conversion here *) let shift_op_big_int a (b: int_t) = - let (b : int) = BI.to_int b in + let (b : int) = Z.to_int b in shift_op a b in (* If one of the parameters of the shift is negative, the result is undefined *) let x_min = minimal x in let y_min = minimal y in - if x_min = None || y_min = None || BI.compare (Option.get x_min) BI.zero < 0 || BI.compare (Option.get y_min) BI.zero < 0 then + if x_min = None || y_min = None || Z.compare (Option.get x_min) Z.zero < 0 || Z.compare (Option.get y_min) Z.zero < 0 then top_of ik else lift2 shift_op_big_int ik x y) @@ -2617,13 +2617,13 @@ module Enums : S with type int_t = BigInt.t = struct let shift_right = shift BigInt.shift_right - let of_bool ikind x = Inc (BISet.singleton (if x then BI.one else BI.zero)) + let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) let to_bool = function | Inc e when BISet.is_empty e -> None | Exc (e,_) when BISet.is_empty e -> None - | Inc zero when BISet.is_singleton zero && BISet.choose zero = BI.zero -> Some false - | Inc xs when BISet.for_all ((<>) BI.zero) xs -> Some true - | Exc (xs,_) when BISet.exists ((=) BI.zero) xs -> Some true + | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false + | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true + | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true | _ -> None let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None @@ -2653,7 +2653,7 @@ module Enums : S with type int_t = BigInt.t = struct | Exc (excl,r) -> let rec decrement_while_contained v = if BISet.mem v excl - then decrement_while_contained (BI.sub v (BI.one)) + then decrement_while_contained (Z.sub v Z.one) else v in let range_max = Exclusion.max_of_range r in @@ -2665,7 +2665,7 @@ module Enums : S with type int_t = BigInt.t = struct | Exc (excl,r) -> let rec increment_while_contained v = if BISet.mem v excl - then increment_while_contained (BI.add v (BI.one)) + then increment_while_contained (Z.add v Z.one) else v in let range_min = Exclusion.min_of_range r in @@ -2734,7 +2734,7 @@ module Enums : S with type int_t = BigInt.t = struct ] (* S TODO: decide frequencies *) let refine_with_congruence ik a b = - let contains c m x = if BI.equal m BI.zero then BI.equal c x else BI.equal (BI.rem (BI.sub x c) m) BI.zero in + let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in match a, b with | Inc e, None -> bot_of ik | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) @@ -2755,7 +2755,7 @@ module Enums : S with type int_t = BigInt.t = struct let project ik p t = t end -module Congruence : S with type int_t = BI.t and type t = (BI.t * BI.t) option = +module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = struct let name () = "congruences" module Ints_t = BI @@ -3290,7 +3290,7 @@ module IntDomTupleImpl = struct include Printable.Std (* for default invariant, tag, ... *) open Batteries - type int_t = BI.t + type int_t = Z.t module I1 = SOverflowLifter(DefExc) module I2 = Interval module I3 = SOverflowLifter(Enums) @@ -3601,10 +3601,10 @@ module IntDomTupleImpl = struct if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) None ) - let to_int = same BI.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } + let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } - let minimal = flat (List.max ~cmp:BI.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } - let maximal = flat (List.min ~cmp:BI.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } + let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } + let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } (* others *) let show = String.concat "; " % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } From e0cf71acbe5f6097b59fd27c2b5022e0a5aa8692 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:43:15 +0200 Subject: [PATCH 449/517] Remove I = BI module and replace I. calls with Z. --- src/cdomain/value/cdomains/intDomain.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 40e2136781..5090383c7d 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1799,7 +1799,6 @@ end module Exclusion = struct module R = Interval32 - module I = BI (* We use these types for the functions in this module to make the intended meaning more explicit *) type t = Exc of BISet.t * Interval32.t type inc = Inc of BISet.t [@@unboxed] @@ -1814,7 +1813,7 @@ struct (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in let card_b = cardinality_BISet ys in - if I.compare lower_bound_cardinality_a card_b > 0 then + if Z.compare lower_bound_cardinality_a card_b > 0 then false else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) let min_a = min_of_range r in @@ -1823,22 +1822,22 @@ struct let leq (Exc (xs, r)) (Exc (ys, s)) = let min_a, max_a = min_of_range r, max_of_range r in - let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || I.compare y min_a < 0 || I.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) + let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) if not excluded_check then false else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) if R.leq r s then true - else begin if I.compare (cardinality_BISet xs) (I.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) + else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) then let min_b, max_b = min_of_range s, max_of_range s in let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) - if I.compare min_a min_b < 0 then + if Z.compare min_a min_b < 0 then GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.sub min_b Z.one) else true in let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) - if I.compare max_b max_a < 0 then + if Z.compare max_b max_a < 0 then GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.add max_b Z.one, max_a) else true From e9afb07a970eef029010afbf768bb88889fb175c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:48:15 +0200 Subject: [PATCH 450/517] Remove BI module and inline IntOps.BigIntOps where needed --- src/cdomain/value/cdomains/intDomain.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5090383c7d..5b92e51fbc 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -4,7 +4,6 @@ open Pretty open PrecisionUtil module M = Messages -module BI = IntOps.BigIntOps let (%) = Batteries.(%) let (|?) = Batteries.(|?) @@ -1547,9 +1546,9 @@ module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type end module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (BI) +module Interval = IntervalFunctor (IntOps.BigIntOps) module Interval32 = IntDomWithDefaultIkind (IntDomLifter ( SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)) ) ) (IntIkind) -module IntervalSet = IntervalSetFunctor(BI) +module IntervalSet = IntervalSetFunctor(IntOps.BigIntOps) module Integers(Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) struct include Printable.Std @@ -1776,7 +1775,7 @@ struct end module BigInt = struct - include BI + include IntOps.BigIntOps let name () = "BigIntPrintable" let top () = raise Unknown let bot () = raise Error @@ -2757,7 +2756,7 @@ end module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = struct let name () = "congruences" - module Ints_t = BI + module Ints_t = IntOps.BigIntOps type int_t = Ints_t.t (* represents congruence class of c mod m, None is bot *) @@ -3294,7 +3293,7 @@ module IntDomTupleImpl = struct module I2 = Interval module I3 = SOverflowLifter(Enums) module I4 = SOverflowLifter(Congruence) - module I5 = IntervalSetFunctor (BI) + module I5 = IntervalSetFunctor(IntOps.BigIntOps) type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option [@@deriving to_yojson, eq, ord] From 02a1f080c0e8c9d8849e9c560853e28ae38e0b5e Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 14:52:59 +0200 Subject: [PATCH 451/517] Use Z instead IntOps.BigIntOps for Ints_t in Congurence --- src/cdomain/value/cdomains/intDomain.ml | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 5b92e51fbc..2371bc702f 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2756,7 +2756,7 @@ end module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = struct let name () = "congruences" - module Ints_t = IntOps.BigIntOps + module Ints_t = Z type int_t = Ints_t.t (* represents congruence class of c mod m, None is bot *) @@ -2793,7 +2793,7 @@ struct else Some (c' %: m', m') - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + let range ik = Size.range ik let top () = Some (Ints_t.zero, Ints_t.one) let top_of ik = Some (Ints_t.zero, Ints_t.one) @@ -2904,7 +2904,7 @@ struct match x with | None -> None | Some (c, m) when m =: Ints_t.zero -> - let c' = Ints_t.of_bigint @@ BigInt.cast_to t (Ints_t.to_bigint c) in + let c' = BigInt.cast_to t c in (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) (* We go with GCC behavior here: *) (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) @@ -2985,10 +2985,10 @@ struct | Some (c, m), Some (c', m') when (Cil.isSigned ik) || c <: Ints_t.zero || c' <: Ints_t.zero -> top_of ik | Some (c, m), Some (c', m') -> let (_, max_ik) = range ik in - if (m =: Ints_t.zero && m' =: Ints_t.zero) then - normalize ik @@ Some (Ints_t.bitand max_ik (Ints_t.shift_left c (Ints_t.to_int c')), Ints_t.zero) + if m =: Ints_t.zero && m' =: Ints_t.zero then + normalize ik @@ Some (Z.logand max_ik (Ints_t.shift_left c (Ints_t.to_int c')), Ints_t.zero) else - let x = (Ints_t.bitand max_ik (Ints_t.shift_left Ints_t.one (Ints_t.to_int c'))) in (* 2^c' *) + let x = Z.logand max_ik (Ints_t.shift_left Ints_t.one (Ints_t.to_int c')) in (* 2^c' *) (* TODO: commented out because fails test with _Bool *) (* if is_prime (m' +: Ints_t.one) then normalize ik @@ Some (x *: c, Ints_t.gcd (x *: m) ((c *: x) *: (m' +: Ints_t.one))) @@ -3100,7 +3100,7 @@ struct if (m =: Ints_t.zero && m' =: Ints_t.zero) then Some (f c c', Ints_t.zero) else top () - let bitor ik x y = bit2 Ints_t.bitor ik x y + let bitor ik x y = bit2 Z.logor ik x y let bitand ik x y = match x, y with | None, None -> None @@ -3108,15 +3108,15 @@ struct | Some (c, m), Some (c', m') -> if (m =: Ints_t.zero && m' =: Ints_t.zero) then (* both arguments constant *) - Some (Ints_t.bitand c c', Ints_t.zero) + Some (Z.logand c c', Ints_t.zero) else if m' =: Ints_t.zero && c' =: Ints_t.one && Ints_t.rem m (Ints_t.of_int 2) =: Ints_t.zero then (* x & 1 and x == c (mod 2*z) *) (* Value is equal to LSB of c *) - Some (Ints_t.bitand c c', Ints_t.zero) + Some (Z.logand c c', Ints_t.zero) else top () - let bitxor ik x y = bit2 Ints_t.bitxor ik x y + let bitxor ik x y = bit2 Z.logxor ik x y let rem ik x y = match x, y with @@ -3202,13 +3202,12 @@ struct | x when is_top x -> Invariant.top () | Some (c, m) when m =: Ints_t.zero -> if get_bool "witness.invariant.exact" then - let c = Ints_t.to_bigint c in Invariant.of_exp Cil.(BinOp (Eq, e, Cil.kintegerCilint ik c, intType)) else Invariant.top () | Some (c, m) -> let open Cil in - let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik @@ Ints_t.to_bigint a) (c, m) in + let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) | None -> Invariant.none From f6e991cfeb1fc8bc625a427f03360398e8a85afb Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 15:08:00 +0200 Subject: [PATCH 452/517] Remove Ints_t from Congurence and use Z directly --- src/cdomain/value/cdomains/intDomain.ml | 181 ++++++++++++------------ 1 file changed, 91 insertions(+), 90 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 2371bc702f..2d7dd1d024 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2756,56 +2756,55 @@ end module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = struct let name () = "congruences" - module Ints_t = Z - type int_t = Ints_t.t + type int_t = Z.t (* represents congruence class of c mod m, None is bot *) - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - - let ( *: ) = Ints_t.mul - let (+:) = Ints_t.add - let (-:) = Ints_t.sub - let (%:) = Ints_t.rem - let (/:) = Ints_t.div - let (=:) = Ints_t.equal - let (<:) x y = Ints_t.compare x y < 0 - let (>:) x y = Ints_t.compare x y > 0 - let (<=:) x y = Ints_t.compare x y <= 0 - let (>=:) x y = Ints_t.compare x y >= 0 + type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] + + let ( *: ) = Z.mul + let (+:) = Z.add + let (-:) = Z.sub + let (%:) = Z.rem + let (/:) = Z.div + let (=:) = Z.equal + let (<:) x y = Z.compare x y < 0 + let (>:) x y = Z.compare x y > 0 + let (<=:) x y = Z.compare x y <= 0 + let (>=:) x y = Z.compare x y >= 0 (* a divides b *) let ( |: ) a b = - if a =: Ints_t.zero then false else (b %: a) =: Ints_t.zero + if a =: Z.zero then false else (b %: a) =: Z.zero let normalize ik x = match x with | None -> None | Some (c, m) -> - if m =: Ints_t.zero then + if m =: Z.zero then if should_wrap ik then Some (BigInt.cast_to ik c, m) else Some (c, m) else - let m' = Ints_t.abs m in + let m' = Z.abs m in let c' = c %: m' in - if c' <: Ints_t.zero then + if c' <: Z.zero then Some (c' +: m', m') else Some (c' %: m', m') let range ik = Size.range ik - let top () = Some (Ints_t.zero, Ints_t.one) - let top_of ik = Some (Ints_t.zero, Ints_t.one) + let top () = Some (Z.zero, Z.one) + let top_of ik = Some (Z.zero, Z.one) let bot () = None let bot_of ik = bot () let show = function ik -> match ik with | None -> "⟂" - | Some (c, m) when (c, m) = (Ints_t.zero, Ints_t.zero) -> Ints_t.to_string c + | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c | Some (c, m) -> - let a = if c =: Ints_t.zero then "" else Ints_t.to_string c in - let b = if m =: Ints_t.zero then "" else if m = Ints_t.one then "ℤ" else Ints_t.to_string m^"ℤ" in + let a = if c =: Z.zero then "" else Z.to_string c in + let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in let c = if a = "" || b = "" then "" else "+" in a^c^b @@ -2815,29 +2814,29 @@ struct let equal_to i = function | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) when b =: Ints_t.zero -> if a =: i then `Eq else `Neq + | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq | Some (a, b) -> if i %: b =: a then `Top else `Neq let leq (x:t) (y:t) = match x, y with | None, _ -> true | Some _, None -> false - | Some (c1,m1), Some (c2,m2) when m2 =: Ints_t.zero && m1 =: Ints_t.zero -> c1 =: c2 - | Some (c1,m1), Some (c2,m2) when m2 =: Ints_t.zero -> c1 =: c2 && m1 =: Ints_t.zero - | Some (c1,m1), Some (c2,m2) -> m2 |: (Ints_t.gcd (c1 -: c2) m1) + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero + | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) let leq x y = let res = leq x y in - if M.tracing then M.trace "congruence" "leq %a %a -> %a \n" pretty x pretty y pretty (Some(Ints_t.of_int (Bool.to_int res), Ints_t.zero)) ; + if M.tracing then M.trace "congruence" "leq %a %a -> %a \n" pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; res let join ik (x:t) y = match x, y with | None, z | z, None -> z | Some (c1,m1), Some (c2,m2) -> - let m3 = Ints_t.gcd m1 (Ints_t.gcd m2 (c1 -: c2)) in + let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in normalize ik (Some (c1, m3)) let join ik (x:t) y = @@ -2852,17 +2851,17 @@ struct let rec next a1 c1 a2 c2 = if a2 |: a1 then (a2, c2) else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) - in next m Ints_t.zero a c + in next m Z.zero a c in let simple_case i c m = if m |: (i -: c) - then Some (i, Ints_t.zero) else None + then Some (i, Z.zero) else None in match x, y with - | Some (c1, m1), Some (c2, m2) when m1 =: Ints_t.zero && m2 =: Ints_t.zero -> if c1 =: c2 then Some (c1, Ints_t.zero) else None - | Some (c1, m1), Some (c2, m2) when m1 =: Ints_t.zero -> simple_case c1 c2 m2 - | Some (c1, m1), Some (c2, m2) when m2 =: Ints_t.zero -> simple_case c2 c1 m1 - | Some (c1, m1), Some (c2, m2) when (Ints_t.gcd m1 m2) |: (c1 -: c2) -> + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 + | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 + | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) | _ -> None @@ -2872,10 +2871,10 @@ struct if M.tracing then M.trace "congruence" "meet %a %a -> %a\n" pretty x pretty y pretty res; res - let to_int = function Some (c, m) when m =: Ints_t.zero -> Some c | _ -> None - let of_int ik (x: int_t) = normalize ik @@ Some (x, Ints_t.zero) - let zero = Some (Ints_t.zero, Ints_t.zero) - let one = Some (Ints_t.one, Ints_t.zero) + let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None + let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) + let zero = Some (Z.zero, Z.zero) + let one = Some (Z.one, Z.zero) let top_bool = top() let of_bool _ik = function true -> one | false -> zero @@ -2892,18 +2891,18 @@ struct let of_congruence ik (c,m) = normalize ik @@ Some(c,m) let maximal t = match t with - | Some (x, y) when y =: Ints_t.zero -> Some x + | Some (x, y) when y =: Z.zero -> Some x | _ -> None let minimal t = match t with - | Some (x,y) when y =: Ints_t.zero -> Some x + | Some (x,y) when y =: Z.zero -> Some x | _ -> None (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) let cast_to ?torg ?(no_ov=false) t x = match x with | None -> None - | Some (c, m) when m =: Ints_t.zero -> + | Some (c, m) when m =: Z.zero -> let c' = BigInt.cast_to t c in (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) (* We go with GCC behavior here: *) @@ -2972,28 +2971,28 @@ struct let shift_left ik x y = (* Naive primality test *) (* let is_prime n = - let n = Ints_t.abs n in + let n = Z.abs n in let rec is_prime' d = - (d *: d >: n) || ((not ((n %: d) =: Ints_t.zero)) && (is_prime' [@tailcall]) (d +: Ints_t.one)) + (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) in - not (n =: Ints_t.one) && is_prime' (Ints_t.of_int 2) + not (n =: Z.one) && is_prime' (Z.of_int 2) in *) match x, y with | None, None -> None | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') when (Cil.isSigned ik) || c <: Ints_t.zero || c' <: Ints_t.zero -> top_of ik + | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik | Some (c, m), Some (c', m') -> let (_, max_ik) = range ik in - if m =: Ints_t.zero && m' =: Ints_t.zero then - normalize ik @@ Some (Z.logand max_ik (Ints_t.shift_left c (Ints_t.to_int c')), Ints_t.zero) + if m =: Z.zero && m' =: Z.zero then + normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) else - let x = Z.logand max_ik (Ints_t.shift_left Ints_t.one (Ints_t.to_int c')) in (* 2^c' *) + let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) (* TODO: commented out because fails test with _Bool *) - (* if is_prime (m' +: Ints_t.one) then - normalize ik @@ Some (x *: c, Ints_t.gcd (x *: m) ((c *: x) *: (m' +: Ints_t.one))) + (* if is_prime (m' +: Z.one) then + normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) else *) - normalize ik @@ Some (x *: c, Ints_t.gcd (x *: m) (c *: x)) + normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) let shift_left ik x y = let res = shift_left ik x y in @@ -3004,24 +3003,24 @@ struct From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. The congruence modulo b may not persist on an overflow. *) let handle_overflow ik (c, m) = - if m =: Ints_t.zero then + if m =: Z.zero then normalize ik (Some (c, m)) else (* Find largest m'=2^k (for some k) such that m is divisible by m' *) - let tz = Ints_t.trailing_zeros m in - let m' = Ints_t.shift_left (Ints_t.of_int 1) tz in + let tz = Z.trailing_zeros m in + let m' = Z.shift_left (Z.of_int 1) tz in - let max = (snd (Size.range ik)) +: Ints_t.one in + let max = (snd (Size.range ik)) +: Z.one in if m' >=: max then (* if m' >= 2 ^ {bitlength}, there is only one value in range *) let c' = c %: max in - Some (c', Ints_t.zero) + Some (c', Z.zero) else normalize ik (Some (c, m')) let mul ?(no_ov=false) ik x y = let no_ov_case (c1, m1) (c2, m2) = - (c1 *: c2, Ints_t.gcd (c1 *: m2) (Ints_t.gcd (m1 *: c2) (m1 *: m2))) + c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) in match x, y with | None, None -> bot () @@ -3029,9 +3028,9 @@ struct raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some (c1, m1), Some (c2, m2) when no_ov -> Some (no_ov_case (c1, m1) (c2, m2)) - | Some (c1, m1), Some (c2, m2) when m1 =: Ints_t.zero && m2 =: Ints_t.zero && not (Cil.isSigned ik) -> + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> let (_, max_ik) = range ik in - Some((c1 *: c2) %: (max_ik +: Ints_t.one), Ints_t.zero) + Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) | Some a, Some b when not (Cil.isSigned ik) -> handle_overflow ik (no_ov_case a b ) | _ -> top () @@ -3044,11 +3043,11 @@ struct let neg ?(no_ov=false) ik x = match x with | None -> bot() - | Some _ -> mul ~no_ov ik (of_int ik (Ints_t.of_int (-1))) x + | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x let add ?(no_ov=false) ik x y = let no_ov_case (c1, m1) (c2, m2) = - c1 +: c2, Ints_t.gcd m1 m2 + c1 +: c2, Z.gcd m1 m2 in match (x, y) with | None, None -> bot () @@ -3056,9 +3055,9 @@ struct raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some a, Some b when no_ov -> normalize ik (Some (no_ov_case a b)) - | Some (c1, m1), Some (c2, m2) when m1 =: Ints_t.zero && m2 =: Ints_t.zero && not (Cil.isSigned ik) -> + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> let (_, max_ik) = range ik in - Some((c1 +: c2) %: (max_ik +: Ints_t.one), Ints_t.zero) + Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) | Some a, Some b when not (Cil.isSigned ik) -> handle_overflow ik (no_ov_case a b) | _ -> top () @@ -3088,7 +3087,7 @@ struct sub ik (neg ik x) one else let (_, max_ik) = range ik in - Some (Ints_t.sub max_ik c, m) + Some (Z.sub max_ik c, m) (** The implementation of the bit operations could be improved based on the master’s thesis 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. @@ -3097,7 +3096,7 @@ struct | None, None -> None | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some (c, m), Some (c', m') -> - if (m =: Ints_t.zero && m' =: Ints_t.zero) then Some (f c c', Ints_t.zero) + if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) else top () let bitor ik x y = bit2 Z.logor ik x y @@ -3106,13 +3105,13 @@ struct | None, None -> None | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some (c, m), Some (c', m') -> - if (m =: Ints_t.zero && m' =: Ints_t.zero) then + if m =: Z.zero && m' =: Z.zero then (* both arguments constant *) - Some (Z.logand c c', Ints_t.zero) - else if m' =: Ints_t.zero && c' =: Ints_t.one && Ints_t.rem m (Ints_t.of_int 2) =: Ints_t.zero then + Some (Z.logand c c', Z.zero) + else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then (* x & 1 and x == c (mod 2*z) *) (* Value is equal to LSB of c *) - Some (Z.logand c c', Ints_t.zero) + Some (Z.logand c c', Z.zero) else top () @@ -3123,13 +3122,13 @@ struct | None, None -> bot() | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some (c1, m1), Some(c2, m2) -> - if m2 =: Ints_t.zero then - if (c2 |: m1) && (c1 %: c2 =: Ints_t.zero || m1 =: Ints_t.zero || not (Cil.isSigned ik)) then - Some(c1 %: c2, Ints_t.zero) + if m2 =: Z.zero then + if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then + Some (c1 %: c2, Z.zero) else - normalize ik (Some(c1, (Ints_t.gcd m1 c2))) + normalize ik (Some (c1, (Z.gcd m1 c2))) else - normalize ik (Some(c1, Ints_t.gcd m1 (Ints_t.gcd c2 m2))) + normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) let rem ik x y = let res = rem ik x y in if M.tracing then M.trace "congruence" "rem : %a %a -> %a \n" pretty x pretty y pretty res; @@ -3140,9 +3139,9 @@ struct | None, None -> bot () | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | _, x when leq zero x -> top () - | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Ints_t.zero && c2 =: Ints_t.neg Ints_t.one -> top () - | Some(c1, m1), Some(c2, m2) when m1 =: Ints_t.zero && m2 =: Ints_t.zero -> Some(c1 /: c2, Ints_t.zero) - | Some(c1, m1), Some(c2, m2) when m2 =: Ints_t.zero -> if (c2 |: m1) && (c2 |: c1) then Some(c1 /: c2, m1 /: c2) else top () + | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () + | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) + | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) | _, _ -> top () @@ -3154,19 +3153,21 @@ struct res let ne ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Ints_t.zero) && (m2 =: Ints_t.zero) -> of_bool ik (not (c1 =: c2 )) + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) | x, y -> if meet ik x y = None then of_bool ik true else top_bool let eq ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Ints_t.zero) && (m2 =: Ints_t.zero) -> of_bool ik (c1 =: c2) + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) | x, y -> if meet ik x y <> None then top_bool else of_bool ik false let comparison ik op x y = match x, y with | None, None -> bot_of ik | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some(c2, m2) -> if (m1 =: Ints_t.zero) && (m2 =: Ints_t.zero) then + | Some (c1, m1), Some (c2, m2) -> + if m1 =: Z.zero && m2 =: Z.zero then if op c1 c2 then of_bool ik true else of_bool ik false - else top_bool + else + top_bool let ge ik x y = comparison ik (>=:) x y @@ -3200,7 +3201,7 @@ struct let invariant_ikind e ik x = match x with | x when is_top x -> Invariant.top () - | Some (c, m) when m =: Ints_t.zero -> + | Some (c, m) when m =: Z.zero -> if get_bool "witness.invariant.exact" then Invariant.of_exp Cil.(BinOp (Eq, e, Cil.kintegerCilint ik c, intType)) else @@ -3213,7 +3214,7 @@ struct let arbitrary ik = let open QCheck in - let int_arb = map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in let cong_arb = pair int_arb int_arb in let of_pair ik p = normalize ik (Some p) in let to_pair = Option.get in @@ -3222,19 +3223,19 @@ struct let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = match intv, cong with | Some (x, y), Some (c, m) -> - if m =: Ints_t.zero then - if (c <: x || c >: y) then None else Some (c, Ints_t.zero) + if m =: Z.zero then + if c <: x || c >: y then None else Some (c, Z.zero) else - let rcx = x +: ((c -: x) %: Ints_t.abs m) in - let lcy = y -: ((y -: c) %: Ints_t.abs m) in + let rcx = x +: ((c -: x) %: Z.abs m) in + let lcy = y -: ((y -: c) %: Z.abs m) in if rcx >: lcy then None - else if rcx =: lcy then Some (rcx, Ints_t.zero) + else if rcx =: lcy then Some (rcx, Z.zero) else cong | _ -> None let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = let pretty_intv _ i = (match i with - | Some(l, u) -> let s = "["^Ints_t.to_string l^","^Ints_t.to_string u^"]" in Pretty.text s + | Some(l, u) -> let s = "["^Z.to_string l^","^Z.to_string u^"]" in Pretty.text s | _ -> Pretty.text ("Display Error")) in let refn = refine_with_interval ik cong intv in if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a\n" pretty cong pretty_intv intv pretty refn; From d627cdc0346a747d33391b58978e177eff62c908 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 15:22:42 +0200 Subject: [PATCH 453/517] Address semgrep findings --- src/analyses/baseInvariant.ml | 8 ++++---- src/cdomain/value/cdomains/arrayDomain.ml | 10 +++++----- src/cdomain/value/cdomains/intDomain.ml | 12 ++++++------ 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 7176ea5695..366615a1b5 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -168,7 +168,7 @@ struct | Int n -> begin let ikind = Cilfacade.get_ikind_exp (Lval lval) in let n = ID.cast_to ikind n in - let range_from x = if tv then ID.ending ikind (Z.sub x Z.one) else ID.starting ikind x in + let range_from x = if tv then ID.ending ikind (Z.pred x) else ID.starting ikind x in let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> @@ -183,7 +183,7 @@ struct | Int n -> begin let ikind = Cilfacade.get_ikind_exp (Lval lval) in let n = ID.cast_to ikind n in - let range_from x = if tv then ID.ending ikind x else ID.starting ikind (Z.add x Z.one) in + let range_from x = if tv then ID.ending ikind x else ID.starting ikind (Z.succ x) in let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> @@ -380,8 +380,8 @@ struct | _, _ -> a, b end | Lt | Le | Ge | Gt as op -> - let pred x = Z.sub x Z.one in - let succ x = Z.add x Z.one in + let pred x = Z.pred x in + let succ x = Z.succ x in (match ID.minimal a, ID.maximal a, ID.minimal b, ID.maximal b with | Some l1, Some u1, Some l2, Some u2 -> (* if M.tracing then M.tracel "inv" "Op: %s, l1: %Ld, u1: %Ld, l2: %Ld, u2: %Ld\n" (show_binop op) l1 u1 l2 u2; *) diff --git a/src/cdomain/value/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml index 162d782951..ac9af3c5a4 100644 --- a/src/cdomain/value/cdomains/arrayDomain.ml +++ b/src/cdomain/value/cdomains/arrayDomain.ml @@ -556,7 +556,7 @@ struct | Some l -> begin match Idx.to_int l with - | Some i -> BatOption.map_default (Z.equal (Z.sub i Z.one)) false (exp_value e) + | Some i -> BatOption.map_default (Z.equal (Z.pred i)) false (exp_value e) | None -> false end | _ -> false @@ -596,10 +596,10 @@ struct else if Cil.isConstant e && Cil.isConstant i' then match Cil.getInteger e, Cil.getInteger i' with | Some (e'': Cilint.cilint), Some i'' -> - if Z.equal i'' (Z.add e'' Z.one) then + if Z.equal i'' (Z.succ e'') then (* If both are integer constants and they are directly adjacent, we change partitioning to maintain information *) Partitioned (i', (Val.join xl xm, a, xr)) - else if Z.equal e'' (Z.add i'' Z.one) then + else if Z.equal e'' (Z.succ i'') then Partitioned (i', (xl, a, Val.join xm xr)) else default @@ -673,7 +673,7 @@ struct begin match Idx.to_int l with | Some i -> - v = Some (Z.sub i Z.one) + v = Some (Z.pred i) | None -> false end | None -> false @@ -748,7 +748,7 @@ struct begin match Idx.to_int l with | Some i -> - v = Some (Z.sub i Z.one) + v = Some (Z.pred i) | None -> false end | None -> false diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 2d7dd1d024..7415444c2c 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1803,7 +1803,7 @@ struct type inc = Inc of BISet.t [@@unboxed] let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.add Z.one (Z.add (Z.neg (min_of_range r)) (max_of_range r)) + let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) let cardinality_BISet s = Z.of_int (BISet.cardinal s) @@ -1831,13 +1831,13 @@ struct let min_b, max_b = min_of_range s, max_of_range s in let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) if Z.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.sub min_b Z.one) + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) else true in let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) if Z.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.add max_b Z.one, max_a) + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) else true in @@ -2651,7 +2651,7 @@ module Enums : S with type int_t = BigInt.t = struct | Exc (excl,r) -> let rec decrement_while_contained v = if BISet.mem v excl - then decrement_while_contained (Z.sub v Z.one) + then decrement_while_contained (Z.pred v) else v in let range_max = Exclusion.max_of_range r in @@ -2663,7 +2663,7 @@ module Enums : S with type int_t = BigInt.t = struct | Exc (excl,r) -> let rec increment_while_contained v = if BISet.mem v excl - then increment_while_contained (Z.add v Z.one) + then increment_while_contained (Z.succ v) else v in let range_min = Exclusion.min_of_range r in @@ -3008,7 +3008,7 @@ struct else (* Find largest m'=2^k (for some k) such that m is divisible by m' *) let tz = Z.trailing_zeros m in - let m' = Z.shift_left (Z.of_int 1) tz in + let m' = Z.shift_left Z.one tz in let max = (snd (Size.range ik)) +: Z.one in if m' >=: max then From 4f8e9569286ef715329997a0864f4e8408bc5c01 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 18:03:14 +0200 Subject: [PATCH 454/517] Fix spacing in module definitions --- src/cdomain/value/cdomains/intDomain.ml | 36 ++++++++++++------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 7415444c2c..3ed8a86c59 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -505,7 +505,7 @@ module Std (B: sig end (* Textbook interval arithmetic, without any overflow handling etc. *) -module IntervalArith(Ints_t : IntOps.IntOps) = struct +module IntervalArith (Ints_t : IntOps.IntOps) = struct let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) @@ -545,12 +545,12 @@ module IntervalArith(Ints_t : IntOps.IntOps) = struct if Ints_t.equal x1 x2 then Some x1 else None end -module IntervalFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = +module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = struct let name () = "intervals" type int_t = Ints_t.t type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module IArith = IntervalArith(Ints_t) + module IArith = IntervalArith (Ints_t) let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) @@ -974,11 +974,11 @@ struct end (** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) -module IntervalSetFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = +module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = struct - module Interval = IntervalFunctor(Ints_t) - module IArith = IntervalArith(Ints_t) + module Interval = IntervalFunctor (Ints_t) + module IArith = IntervalArith (Ints_t) let name () = "interval_sets" @@ -1546,10 +1546,10 @@ module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type end module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (IntOps.BigIntOps) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter ( SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)) ) ) (IntIkind) -module IntervalSet = IntervalSetFunctor(IntOps.BigIntOps) -module Integers(Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) +module Interval = IntervalFunctor (IntOps.BigIntOps) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) +module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) +module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) struct include Printable.Std let name () = "integers" @@ -1764,9 +1764,9 @@ struct | `Top | `Bot -> Invariant.none end -module Flattened = Flat (Integers(IntOps.Int64Ops)) -module FlattenedBI = Flat (Integers(IntOps.BigIntOps)) -module Lifted = Lift (Integers(IntOps.Int64Ops)) +module Flattened = Flat (Integers (IntOps.Int64Ops)) +module FlattenedBI = Flat (Integers (IntOps.BigIntOps)) +module Lifted = Lift (Integers (IntOps.Int64Ops)) module Reverse (Base: IkindUnawareS) = struct @@ -1790,7 +1790,7 @@ module BigInt = struct end module BISet = struct - include SetDomain.Make(BigInt) + include SetDomain.Make (BigInt) let is_singleton s = cardinal s = 1 end @@ -3289,11 +3289,11 @@ module IntDomTupleImpl = struct open Batteries type int_t = Z.t - module I1 = SOverflowLifter(DefExc) + module I1 = SOverflowLifter (DefExc) module I2 = Interval - module I3 = SOverflowLifter(Enums) - module I4 = SOverflowLifter(Congruence) - module I5 = IntervalSetFunctor(IntOps.BigIntOps) + module I3 = SOverflowLifter (Enums) + module I4 = SOverflowLifter (Congruence) + module I5 = IntervalSetFunctor (IntOps.BigIntOps) type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option [@@deriving to_yojson, eq, ord] From 944b531737e89e78b5bfef781af2c2717469a690 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 18:18:48 +0200 Subject: [PATCH 455/517] Include Z instead of IntOps.BigIntOps in BigInt --- src/cdomain/value/cdomains/intDomain.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 3ed8a86c59..c55a13a975 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1775,7 +1775,7 @@ struct end module BigInt = struct - include IntOps.BigIntOps + include Z let name () = "BigIntPrintable" let top () = raise Unknown let bot () = raise Error @@ -2218,7 +2218,7 @@ struct let ge ik x y = le ik y x - let bitnot = lift1 BigInt.bitnot + let bitnot = lift1 Z.lognot let bitand ik x y = norm ik (match x,y with (* We don't bother with exclusion sets: *) @@ -2234,15 +2234,15 @@ struct | `Excluded _, `Excluded _ -> top () (* The good case: *) | `Definite x, `Definite y -> - (try `Definite (BigInt.bitand x y) with | Division_by_zero -> top ()) + (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) | `Bot, `Bot -> `Bot | _ -> (* If only one of them is bottom, we raise an exception that eval_rv will catch *) raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - let bitor = lift2 BigInt.bitor - let bitxor = lift2 BigInt.bitxor + let bitor = lift2 Z.logor + let bitxor = lift2 Z.logxor let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = (* BigInt only accepts int as second argument for shifts; perform conversion here *) @@ -2416,7 +2416,7 @@ module Enums : S with type int_t = BigInt.t = struct let bot_of ik = Inc (BISet.empty ()) let top_bool = Inc (BISet.of_list [I.zero; I.one]) - let range ik = BatTuple.Tuple2.mapn I.of_bigint (Size.range ik) + let range ik = Size.range ik (* let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) @@ -2589,10 +2589,10 @@ module Enums : S with type int_t = BigInt.t = struct let rem = lift2 I.rem - let bitnot = lift1 BigInt.bitnot - let bitand = lift2 BigInt.bitand - let bitor = lift2 BigInt.bitor - let bitxor = lift2 BigInt.bitxor + let bitnot = lift1 Z.lognot + let bitand = lift2 Z.logand + let bitor = lift2 Z.logor + let bitxor = lift2 Z.logxor let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = handle_bot x y (fun () -> From 35d8cd749efbd7cd794195358ef033e0d87ec7a2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 18:19:51 +0200 Subject: [PATCH 456/517] Define bitnot as Z.lognot in BigIntOpsBase --- src/common/util/intOps.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index 7c8e5d31e1..24aa4e3f66 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -241,7 +241,7 @@ struct let shift_left = Z.shift_left let shift_right = Z.shift_right - let bitnot x = sub (neg x) one + let bitnot = Z.lognot let bitand = Z.logand let bitor = Z.logor let bitxor = Z.logxor From d929216777885ac1545250b848dd4c7f640768de Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 21:04:36 +0200 Subject: [PATCH 457/517] Revert "Include Z instead of IntOps.BigIntOps in BigInt" This reverts commit 944b531737e89e78b5bfef781af2c2717469a690. --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c55a13a975..1ba13da47b 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1775,7 +1775,7 @@ struct end module BigInt = struct - include Z + include IntOps.BigIntOps let name () = "BigIntPrintable" let top () = raise Unknown let bot () = raise Error From 4e95cff843ae0315081517beb47b97677670feb6 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 21:11:48 +0200 Subject: [PATCH 458/517] Remove unused FlattenedBI module --- src/cdomain/value/cdomains/intDomain.ml | 1 - src/cdomain/value/cdomains/intDomain.mli | 4 ---- unittest/cdomains/intDomainTest.ml | 4 +--- 3 files changed, 1 insertion(+), 8 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1ba13da47b..34fba4104d 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1765,7 +1765,6 @@ struct end module Flattened = Flat (Integers (IntOps.Int64Ops)) -module FlattenedBI = Flat (Integers (IntOps.BigIntOps)) module Lifted = Lift (Integers (IntOps.Int64Ops)) module Reverse (Base: IkindUnawareS) = diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 4b14aeec72..27a766e7aa 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -396,10 +396,6 @@ module Flattened : IkindUnawareS with type t = [`Top | `Lifted of IntOps.Int64Op (** This is the typical flattened integer domain used in Kildall's constant * propagation. *) -module FlattenedBI : IkindUnawareS with type t = [`Top | `Lifted of IntOps.BigIntOps.t | `Bot] and type int_t = IntOps.BigIntOps.t -(** This is the typical flattened integer domain used in Kildall's constant - * propagation, using Big_int instead of int64. *) - module Lifted : IkindUnawareS with type t = [`Top | `Lifted of int64 | `Bot] and type int_t = int64 (** Artificially bounded integers in their natural ordering. *) diff --git a/unittest/cdomains/intDomainTest.ml b/unittest/cdomains/intDomainTest.ml index f803ef1c35..763c3e7e93 100644 --- a/unittest/cdomains/intDomainTest.ml +++ b/unittest/cdomains/intDomainTest.ml @@ -110,7 +110,6 @@ end module Ikind = struct let ikind () = Cil.ILong end module A = IntTest (IntDomain.Integers (IntOps.BigIntOps)) -module B = IntTest (IntDomain.FlattenedBI) module C = IntTest (IntDomainProperties.WithIkind (IntDomain.DefExc) (Ikind)) module T = struct include IntDomainProperties.WithIkind (IntDomain.DefExc) (Ikind) @@ -283,8 +282,7 @@ end let test () = "intDomainTest" >::: [ "int_Integers" >::: A.test (); - "int_Flattened" >::: B.test (); - "int_DefExc" >::: C.test (); + "int_DefExc" >::: C.test (); "test_bot" >:: test_bot; "test_join" >:: test_join; "test_meet" >:: test_meet; From 89b13d4038a1b39a9ce1d97eb11088afba7ca389 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 21:29:51 +0200 Subject: [PATCH 459/517] Replace BigInt.zero with Z.zero --- src/cdomain/value/cdomains/intDomain.ml | 26 ++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 34fba4104d..6f1228237e 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1962,10 +1962,10 @@ struct let mapped_excl = S.map (fun excl -> BigInt.cast_to ik excl) s in match ik with | IBool -> - begin match S.mem BigInt.zero mapped_excl, S.mem BigInt.one mapped_excl with + begin match S.mem Z.zero mapped_excl, S.mem BigInt.one mapped_excl with | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) | true, false -> `Definite BigInt.one (* Not {0} -> 1 *) - | false, true -> `Definite BigInt.zero (* Not {1} -> 0 *) + | false, true -> `Definite Z.zero (* Not {1} -> 0 *) | true, true -> `Bot (* Not {0, 1} -> bot *) end | ik -> @@ -2081,8 +2081,8 @@ struct let of_interval ?(suppress_ovwarn=false) ik (x,y) = if BigInt.compare x y = 0 then of_int ik x else top_of ik - let starting ?(suppress_ovwarn=false) ikind x = if BigInt.compare x BigInt.zero > 0 then not_zero ikind else top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = if BigInt.compare x BigInt.zero < 0 then not_zero ikind else top_of ikind + let starting ?(suppress_ovwarn=false) ikind x = if BigInt.compare x Z.zero > 0 then not_zero ikind else top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = if BigInt.compare x Z.zero < 0 then not_zero ikind else top_of ikind let of_excl_list t l = let r = size t in (* elements in l are excluded from the full range of t! *) @@ -2182,12 +2182,12 @@ struct let sub ?no_ov ik x y = norm ik @@ lift2_inj BigInt.sub ik x y let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when BigInt.equal z BigInt.zero -> x - | (`Excluded _ | `Definite _), `Definite z when BigInt.equal z BigInt.zero -> y + | `Definite z, (`Excluded _ | `Definite _) when BigInt.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when BigInt.equal z Z.zero -> y | `Definite a, `Excluded (s,r) (* Integer multiplication with even numbers is not injective. *) (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when BigInt.equal (BigInt.rem a (BigInt.of_int 2)) BigInt.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) + | `Excluded (s,r),`Definite a when BigInt.equal (BigInt.rem a (BigInt.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) | _ -> lift2_inj BigInt.mul ik x y let div ?no_ov ik x y = lift2 BigInt.div ik x y let rem ik x y = lift2 BigInt.rem ik x y @@ -2223,10 +2223,10 @@ struct (* We don't bother with exclusion sets: *) | `Excluded _, `Definite i -> (* Except in two special cases *) - if BigInt.equal i BigInt.zero then - `Definite BigInt.zero + if BigInt.equal i Z.zero then + `Definite Z.zero else if BigInt.equal i BigInt.one then - of_interval IBool (BigInt.zero, BigInt.one) + of_interval IBool (Z.zero, BigInt.one) else top () | `Definite _, `Excluded _ @@ -2277,7 +2277,7 @@ struct of_bool ik true | _, _ -> lift2 BigInt.logor ik x y - let lognot ik = eq ik (of_int ik BigInt.zero) + let lognot ik = eq ik (of_int ik Z.zero) let invariant_ikind e ik (x:t) = match x with @@ -2456,10 +2456,10 @@ module Enums : S with type int_t = BigInt.t = struct assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) begin match ikind with | IBool -> - begin match BISet.mem BigInt.zero xs, BISet.mem BigInt.one xs with + begin match BISet.mem Z.zero xs, BISet.mem BigInt.one xs with | false, false -> top_bool (* Not {} -> {0, 1} *) | true, false -> Inc (BISet.singleton BigInt.one) (* Not {0} -> {1} *) - | false, true -> Inc (BISet.singleton BigInt.zero) (* Not {1} -> {0} *) + | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) | true, true -> bot_of ikind (* Not {0, 1} -> bot *) end | _ -> From c2c4d7e15769f1e59784e9a2db0be461ff25fe1c Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 15 Jan 2024 21:35:07 +0200 Subject: [PATCH 460/517] Replace BigInt.one with Z.one --- src/cdomain/value/cdomains/intDomain.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 6f1228237e..4eb1f88a97 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1962,9 +1962,9 @@ struct let mapped_excl = S.map (fun excl -> BigInt.cast_to ik excl) s in match ik with | IBool -> - begin match S.mem Z.zero mapped_excl, S.mem BigInt.one mapped_excl with + begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) - | true, false -> `Definite BigInt.one (* Not {0} -> 1 *) + | true, false -> `Definite Z.one (* Not {0} -> 1 *) | false, true -> `Definite Z.zero (* Not {1} -> 0 *) | true, true -> `Bot (* Not {0, 1} -> bot *) end @@ -2225,8 +2225,8 @@ struct (* Except in two special cases *) if BigInt.equal i Z.zero then `Definite Z.zero - else if BigInt.equal i BigInt.one then - of_interval IBool (Z.zero, BigInt.one) + else if BigInt.equal i Z.one then + of_interval IBool (Z.zero, Z.one) else top () | `Definite _, `Excluded _ @@ -2456,9 +2456,9 @@ module Enums : S with type int_t = BigInt.t = struct assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) begin match ikind with | IBool -> - begin match BISet.mem Z.zero xs, BISet.mem BigInt.one xs with + begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with | false, false -> top_bool (* Not {} -> {0, 1} *) - | true, false -> Inc (BISet.singleton BigInt.one) (* Not {0} -> {1} *) + | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) | true, true -> bot_of ikind (* Not {0, 1} -> bot *) end From 57d9201cf5cccbf22a1eece793c8acd8f9bee7fc Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:18:40 +0200 Subject: [PATCH 461/517] Replace BigInt.equal with Z.equal --- src/cdomain/value/cdomains/intDomain.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 4eb1f88a97..a8aade6b19 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2182,12 +2182,12 @@ struct let sub ?no_ov ik x y = norm ik @@ lift2_inj BigInt.sub ik x y let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when BigInt.equal z Z.zero -> x - | (`Excluded _ | `Definite _), `Definite z when BigInt.equal z Z.zero -> y + | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y | `Definite a, `Excluded (s,r) (* Integer multiplication with even numbers is not injective. *) (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when BigInt.equal (BigInt.rem a (BigInt.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) + | `Excluded (s,r),`Definite a when Z.equal (BigInt.rem a (BigInt.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) | _ -> lift2_inj BigInt.mul ik x y let div ?no_ov ik x y = lift2 BigInt.div ik x y let rem ik x y = lift2 BigInt.rem ik x y @@ -2223,9 +2223,9 @@ struct (* We don't bother with exclusion sets: *) | `Excluded _, `Definite i -> (* Except in two special cases *) - if BigInt.equal i Z.zero then + if Z.equal i Z.zero then `Definite Z.zero - else if BigInt.equal i Z.one then + else if Z.equal i Z.one then of_interval IBool (Z.zero, Z.one) else top () From 12045ea3d1e9c4a023c9f9b042ee9d4d2740ff68 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:19:32 +0200 Subject: [PATCH 462/517] Replace BigInt.add with Z.add --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index a8aade6b19..35743546f8 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2178,7 +2178,7 @@ struct raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) let neg ?no_ov ik (x :t) = norm ik @@ lift1 BigInt.neg ik x - let add ?no_ov ik x y = norm ik @@ lift2_inj BigInt.add ik x y + let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y let sub ?no_ov ik x y = norm ik @@ lift2_inj BigInt.sub ik x y let mul ?no_ov ik x y = norm ik @@ match x, y with From ace1963a7ccd13b9b174719af9ea239475bfe7be Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:20:08 +0200 Subject: [PATCH 463/517] Replace BigInt.sub with Z.sub --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 35743546f8..0dc2c0f114 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2180,7 +2180,7 @@ struct let neg ?no_ov ik (x :t) = norm ik @@ lift1 BigInt.neg ik x let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y - let sub ?no_ov ik x y = norm ik @@ lift2_inj BigInt.sub ik x y + let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y let mul ?no_ov ik x y = norm ik @@ match x, y with | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y From b8c9b4b86a34ca9a11a30fd23b1f2382870b48ed Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:20:43 +0200 Subject: [PATCH 464/517] Replace BigInt.neg with Z.neg --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 0dc2c0f114..c1de32ff18 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2177,7 +2177,7 @@ struct (* If only one of them is bottom, we raise an exception that eval_rv will catch *) raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - let neg ?no_ov ik (x :t) = norm ik @@ lift1 BigInt.neg ik x + let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y From dfe104fd3400278eb5b3f18650b3a309f681f1a2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:21:33 +0200 Subject: [PATCH 465/517] Replace BigInt.of_int with Z.of_int --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c1de32ff18..66e57c2417 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2187,7 +2187,7 @@ struct | `Definite a, `Excluded (s,r) (* Integer multiplication with even numbers is not injective. *) (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (BigInt.rem a (BigInt.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) + | `Excluded (s,r),`Definite a when Z.equal (BigInt.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) | _ -> lift2_inj BigInt.mul ik x y let div ?no_ov ik x y = lift2 BigInt.div ik x y let rem ik x y = lift2 BigInt.rem ik x y From 8b181cf77f30e77993ea13af6f249a1c0b997de8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:22:07 +0200 Subject: [PATCH 466/517] Replace BigInt.rem with Z.rem --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 66e57c2417..d0fa91b1fc 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2187,10 +2187,10 @@ struct | `Definite a, `Excluded (s,r) (* Integer multiplication with even numbers is not injective. *) (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (BigInt.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) | _ -> lift2_inj BigInt.mul ik x y let div ?no_ov ik x y = lift2 BigInt.div ik x y - let rem ik x y = lift2 BigInt.rem ik x y + let rem ik x y = lift2 Z.rem ik x y (* Comparison handling copied from Enums. *) let handle_bot x y f = match x, y with From 1d18891dd0d737794cc40a728e11e3db7e27847d Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:25:59 +0200 Subject: [PATCH 467/517] Replace BigInt.compare with Z.compare --- src/cdomain/value/cdomains/intDomain.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index d0fa91b1fc..338f4508e8 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1977,7 +1977,7 @@ struct if should_wrap ik then ( cast_to ik v ) - else if BigInt.compare min x <= 0 && BigInt.compare x max <= 0 then ( + else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( v ) else if should_ignore_overflow ik then ( @@ -2079,10 +2079,10 @@ struct | _ -> None let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) - let of_interval ?(suppress_ovwarn=false) ik (x,y) = if BigInt.compare x y = 0 then of_int ik x else top_of ik + let of_interval ?(suppress_ovwarn=false) ik (x,y) = if Z.compare x y = 0 then of_int ik x else top_of ik - let starting ?(suppress_ovwarn=false) ikind x = if BigInt.compare x Z.zero > 0 then not_zero ikind else top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = if BigInt.compare x Z.zero < 0 then not_zero ikind else top_of ikind + let starting ?(suppress_ovwarn=false) ikind x = if Z.compare x Z.zero > 0 then not_zero ikind else top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = if Z.compare x Z.zero < 0 then not_zero ikind else top_of ikind let of_excl_list t l = let r = size t in (* elements in l are excluded from the full range of t! *) @@ -2187,9 +2187,9 @@ struct | `Definite a, `Excluded (s,r) (* Integer multiplication with even numbers is not injective. *) (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (BigInt.mul a) r) - | _ -> lift2_inj BigInt.mul ik x y - let div ?no_ov ik x y = lift2 BigInt.div ik x y + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) + | _ -> lift2_inj Z.mul ik x y + let div ?no_ov ik x y = lift2 Z.div ik x y let rem ik x y = lift2 Z.rem ik x y (* Comparison handling copied from Enums. *) @@ -2202,8 +2202,8 @@ struct let lt ik x y = handle_bot x y (fun () -> match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when BigInt.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when BigInt.compare x1 y2 >= 0 -> of_bool ik false + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false | _, _, _, _ -> top_bool) let gt ik x y = lt ik y x @@ -2211,8 +2211,8 @@ struct let le ik x y = handle_bot x y (fun () -> match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when BigInt.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when BigInt.compare x1 y2 > 0 -> of_bool ik false + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false | _, _, _, _ -> top_bool) let ge ik x y = le ik y x From 1b1320781df33e9655fb3c91f19fa54dec76a202 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:26:30 +0200 Subject: [PATCH 468/517] Replace BigInt.shift_left with Z.shift_left --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 338f4508e8..8082195dee 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2258,7 +2258,7 @@ struct norm ik @@ lift2 shift_op_big_int ik x y let shift_left = - shift BigInt.shift_left + shift Z.shift_left let shift_right = shift BigInt.shift_right @@ -2609,7 +2609,7 @@ module Enums : S with type int_t = BigInt.t = struct lift2 shift_op_big_int ik x y) let shift_left = - shift BigInt.shift_left + shift Z.shift_left let shift_right = shift BigInt.shift_right From b5e883b74a6b7ecfd5562ae838a76f7c0cb7b18a Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:26:55 +0200 Subject: [PATCH 469/517] Replace BigInt.shift_right with Z.shift_right --- tests/regression/40-threadid/12-threads.c | 50 +++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 tests/regression/40-threadid/12-threads.c diff --git a/tests/regression/40-threadid/12-threads.c b/tests/regression/40-threadid/12-threads.c new file mode 100644 index 0000000000..636d0da50d --- /dev/null +++ b/tests/regression/40-threadid/12-threads.c @@ -0,0 +1,50 @@ + +#include +#include + +/* Slab sizing definitions. */ +#define POWER_SMALLEST 1 +#define POWER_LARGEST 16 /* actual cap is 255 */ +#define LARGEST_ID POWER_LARGEST +/* Locks for cache LRU operations */ +pthread_mutex_t lru_locks[POWER_LARGEST]; +static pthread_t item_crawler_tid; + +int myglobal; + +void memcached_thread_init(int nthreads, void *arg) { + int i; + for (i = 0; i < POWER_LARGEST; i++) { + pthread_mutex_init(&lru_locks[i], NULL); + } +} + +void *item_crawler_thread(void *arg) { + int i, r1, r2; + for (i = POWER_SMALLEST; i < LARGEST_ID; i++) { + pthread_mutex_lock(&lru_locks[i]); + myglobal = myglobal + 1; // RACE! + if (r1) { + pthread_mutex_unlock(&lru_locks[i]); + continue; + } + // if (r2) { + // int x = 0; + // } + } + return NULL; +} + +int main(void) { + int i; + int num_threads = rand(); + memcached_thread_init(num_threads, NULL); + pthread_create(&item_crawler_tid, NULL, item_crawler_thread, NULL); + for (i = POWER_SMALLEST; i < LARGEST_ID; i++) { + pthread_mutex_lock(&lru_locks[i]); + myglobal = myglobal + 1; // RACE! + pthread_mutex_unlock(&lru_locks[i]); + } + pthread_join(&item_crawler_tid, NULL); + return 0; +} \ No newline at end of file From 68dc1891ef9d39fe1cf5298f7267ae8b3185315b Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:29:57 +0200 Subject: [PATCH 470/517] Replace BigInt.shift_right with Z.shift_right --- src/cdomain/value/cdomains/intDomain.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 8082195dee..43d301e9fa 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -2261,7 +2261,7 @@ struct shift Z.shift_left let shift_right = - shift BigInt.shift_right + shift Z.shift_right (* TODO: lift does not treat Not {0} as true. *) let logand ik x y = match to_bool x, to_bool y with @@ -2612,7 +2612,7 @@ module Enums : S with type int_t = BigInt.t = struct shift Z.shift_left let shift_right = - shift BigInt.shift_right + shift Z.shift_right let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) let to_bool = function From 70871ef3401bc8d5317b23d1edbcd2105eaf1670 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 00:30:51 +0200 Subject: [PATCH 471/517] Revert "Replace BigInt.shift_right with Z.shift_right" This reverts commit b5e883b74a6b7ecfd5562ae838a76f7c0cb7b18a. --- tests/regression/40-threadid/12-threads.c | 50 ----------------------- 1 file changed, 50 deletions(-) delete mode 100644 tests/regression/40-threadid/12-threads.c diff --git a/tests/regression/40-threadid/12-threads.c b/tests/regression/40-threadid/12-threads.c deleted file mode 100644 index 636d0da50d..0000000000 --- a/tests/regression/40-threadid/12-threads.c +++ /dev/null @@ -1,50 +0,0 @@ - -#include -#include - -/* Slab sizing definitions. */ -#define POWER_SMALLEST 1 -#define POWER_LARGEST 16 /* actual cap is 255 */ -#define LARGEST_ID POWER_LARGEST -/* Locks for cache LRU operations */ -pthread_mutex_t lru_locks[POWER_LARGEST]; -static pthread_t item_crawler_tid; - -int myglobal; - -void memcached_thread_init(int nthreads, void *arg) { - int i; - for (i = 0; i < POWER_LARGEST; i++) { - pthread_mutex_init(&lru_locks[i], NULL); - } -} - -void *item_crawler_thread(void *arg) { - int i, r1, r2; - for (i = POWER_SMALLEST; i < LARGEST_ID; i++) { - pthread_mutex_lock(&lru_locks[i]); - myglobal = myglobal + 1; // RACE! - if (r1) { - pthread_mutex_unlock(&lru_locks[i]); - continue; - } - // if (r2) { - // int x = 0; - // } - } - return NULL; -} - -int main(void) { - int i; - int num_threads = rand(); - memcached_thread_init(num_threads, NULL); - pthread_create(&item_crawler_tid, NULL, item_crawler_thread, NULL); - for (i = POWER_SMALLEST; i < LARGEST_ID; i++) { - pthread_mutex_lock(&lru_locks[i]); - myglobal = myglobal + 1; // RACE! - pthread_mutex_unlock(&lru_locks[i]); - } - pthread_join(&item_crawler_tid, NULL); - return 0; -} \ No newline at end of file From aad0a09b051f446313e07106e29764150e7ab526 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 12:34:57 +0200 Subject: [PATCH 472/517] Replace IntOps.BigIntOps with Z where possible in intDomain.mli --- src/cdomain/value/cdomains/intDomain.mli | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 27a766e7aa..cc43c32ace 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -335,7 +335,7 @@ sig end (** The signature of integral value domains keeping track of ikind information *) -module type Z = Y with type int_t = IntOps.BigIntOps.t +module type Z = Y with type int_t = Z.t module IntDomLifter (I: S): Y with type int_t = I.int_t @@ -407,17 +407,17 @@ module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) op module BigInt: sig - include Printable.S with type t = Z.t (* TODO: why doesn't this have a more useful signature like IntOps.BigIntOps? *) + include Printable.S with type t = Z.t val cast_to: Cil.ikind -> Z.t -> Z.t end -module Interval : SOverflow with type int_t = IntOps.BigIntOps.t +module Interval : SOverflow with type int_t = Z.t -module IntervalSet : SOverflow with type int_t = IntOps.BigIntOps.t +module IntervalSet : SOverflow with type int_t = Z.t -module Congruence : S with type int_t = IntOps.BigIntOps.t +module Congruence : S with type int_t = Z.t -module DefExc : S with type int_t = IntOps.BigIntOps.t +module DefExc : S with type int_t = Z.t (** The DefExc domain. The Flattened integer domain is topped by exclusion sets. * Good for analysing branches. *) @@ -440,7 +440,7 @@ module Reverse (Base: IkindUnawareS): IkindUnawareS with type t = Base.t and typ (* module IncExcInterval : S with type t = [ | `Excluded of Interval.t| `Included of Interval.t ] *) (** Inclusive and exclusive intervals. Warning: NOT A LATTICE *) -module Enums : S with type int_t = IntOps.BigIntOps.t +module Enums : S with type int_t = Z.t (** {b Boolean domains} *) From 444290d9dd099444d3c93970aebd9bedbce8c1e6 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 16 Jan 2024 16:05:17 +0200 Subject: [PATCH 473/517] Simplify BigInt and replace with Z where possible --- src/cdomain/value/cdomains/intDomain.ml | 61 ++++++++++++------------- 1 file changed, 28 insertions(+), 33 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 43d301e9fa..873aebb8a9 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1781,11 +1781,9 @@ module BigInt = struct let top_of ik = top () let bot_of ik = bot () let cast_to ik x = Size.cast ik x - let to_bool x = Some (not (Z.equal Z.zero x)) - let show x = Z.to_string x - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - let arbitrary () = QCheck.map ~rev:to_int64 of_int64 QCheck.int64 + include Std (struct type nonrec t = Z.t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 end module BISet = struct @@ -1847,7 +1845,7 @@ struct end end -module DefExc : S with type int_t = BigInt.t = (* definite or set of excluded values *) +module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) struct module S = BISet module R = Interval32 (* range for exclusion *) @@ -1859,10 +1857,10 @@ struct type t = [ | `Excluded of S.t * R.t - | `Definite of BigInt.t + | `Definite of Z.t | `Bot ] [@@deriving eq, ord, hash] - type int_t = BigInt.t + type int_t = Z.t let name () = "def_exc" @@ -1872,13 +1870,11 @@ struct let top_of ik = `Excluded (S.empty (), size ik) let bot_of ik = bot () - - let show x = let short_size x = "("^R.show x^")" in match x with | `Bot -> "Error int" - | `Definite x -> BigInt.show x + | `Definite x -> Z.to_string x (* Print the empty exclusion as if it was a distinct top element: *) | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l (* Prepend the exclusion sets with something: *) @@ -2074,7 +2070,7 @@ struct let of_bool = of_bool_cmp let to_bool x = match x with - | `Definite x -> BigInt.to_bool x + | `Definite x -> Some (BigInt.to_bool x) | `Excluded (s,r) when S.mem Z.zero s -> Some true | _ -> None let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) @@ -2397,9 +2393,8 @@ module Booleans = MakeBooleans ( end) (* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) -module Enums : S with type int_t = BigInt.t = struct +module Enums : S with type int_t = Z.t = struct open Batteries - module I = BigInt module R = Interval32 (* range for exclusion *) let range_ikind = Cil.IInt @@ -2413,20 +2408,20 @@ module Enums : S with type int_t = BigInt.t = struct let top_of ik = Exc (BISet.empty (), size ik) let top () = failwith "top () not implemented for Enums" let bot_of ik = Inc (BISet.empty ()) - let top_bool = Inc (BISet.of_list [I.zero; I.one]) + let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) let range ik = Size.range ik (* let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = I.add (I.neg (min_of_range r)) (max_of_range r) *) - let value_in_range (min, max) v = I.compare min v <= 0 && I.compare v max <= 0 + let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) + let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 let show = function | Inc xs when BISet.is_empty xs -> "bot" - | Inc xs -> "{" ^ (String.concat ", " (List.map I.show (BISet.elements xs))) ^ "}" - | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map I.show (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" + | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" + | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) @@ -2436,7 +2431,7 @@ module Enums : S with type int_t = BigInt.t = struct let min, max = range ikind in (* Whether the value v lies within the values of the specified ikind. *) let value_in_ikind v = - I.compare min v <= 0 && I.compare v max <= 0 + Z.compare min v <= 0 && Z.compare v max <= 0 in match v with | Inc xs when BISet.for_all value_in_ikind xs -> v @@ -2536,7 +2531,7 @@ module Enums : S with type int_t = BigInt.t = struct let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in (* Check that the xs fit into the range r *) - I.compare min_b min_a <= 0 && I.compare max_a max_b <= 0 && + Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) BISet.for_all (fun x -> not (BISet.mem x ys)) xs | Inc xs, Inc ys -> @@ -2566,27 +2561,27 @@ module Enums : S with type int_t = BigInt.t = struct let lift2 f ikind a b = try lift2 f ikind a b with Division_by_zero -> top_of ikind - let neg ?no_ov = lift1 I.neg + let neg ?no_ov = lift1 Z.neg let add ?no_ov ikind = curry @@ function | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,y -> lift2 I.add ikind x y - let sub ?no_ov = lift2 I.sub + | x,y -> lift2 Z.add ikind x y + let sub ?no_ov = lift2 Z.sub let mul ?no_ov ikind a b = match a, b with | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b - | x,y -> lift2 I.mul ikind x y + | x,y -> lift2 Z.mul ikind x y let div ?no_ov ikind a b = match a, b with | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | x,y -> lift2 I.div ikind x y + | x,y -> lift2 Z.div ikind x y - let rem = lift2 I.rem + let rem = lift2 Z.rem let bitnot = lift1 Z.lognot let bitand = lift2 Z.logand @@ -2643,8 +2638,8 @@ module Enums : S with type int_t = BigInt.t = struct | Some b -> of_bool ik (not b) | None -> top_bool - let logand = lift2 I.logand - let logor = lift2 I.logor + let logand = lift2 BigInt.logand + let logor = lift2 BigInt.logor let maximal = function | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) | Exc (excl,r) -> @@ -2672,8 +2667,8 @@ module Enums : S with type int_t = BigInt.t = struct let lt ik x y = handle_bot x y (fun () -> match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when I.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when I.compare x1 y2 >= 0 -> of_bool ik false + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false | _, _, _, _ -> top_bool) let gt ik x y = lt ik y x @@ -2681,8 +2676,8 @@ module Enums : S with type int_t = BigInt.t = struct let le ik x y = handle_bot x y (fun () -> match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when I.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when I.compare x1 y2 > 0 -> of_bool ik false + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false | _, _, _, _ -> top_bool) let ge ik x y = le ik y x @@ -2690,7 +2685,7 @@ module Enums : S with type int_t = BigInt.t = struct let eq ik x y = handle_bot x y (fun () -> match x, y with - | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (I.equal (BISet.choose xs) (BISet.choose ys)) + | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) | _, _ -> if is_bot (meet ik x y) then (* If the meet is empty, there is no chance that concrete values are equal *) From f8ea135e0074ab507166a6ffd4164deddbf9dfdc Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 22 Jan 2024 15:16:28 +0200 Subject: [PATCH 474/517] Inline Z.pred and Z.succ --- src/analyses/baseInvariant.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 366615a1b5..f6cd11afa9 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -380,8 +380,6 @@ struct | _, _ -> a, b end | Lt | Le | Ge | Gt as op -> - let pred x = Z.pred x in - let succ x = Z.succ x in (match ID.minimal a, ID.maximal a, ID.minimal b, ID.maximal b with | Some l1, Some u1, Some l2, Some u2 -> (* if M.tracing then M.tracel "inv" "Op: %s, l1: %Ld, u1: %Ld, l2: %Ld, u2: %Ld\n" (show_binop op) l1 u1 l2 u2; *) @@ -395,9 +393,9 @@ struct | Ge, Some true | Lt, Some false -> meet_bin (ID.starting ikind l2) (ID.ending ikind u1) | Lt, Some true - | Ge, Some false -> meet_bin (ID.ending ikind (pred u2)) (ID.starting ikind (succ l1)) + | Ge, Some false -> meet_bin (ID.ending ikind (Z.pred u2)) (ID.starting ikind (Z.succ l1)) | Gt, Some true - | Le, Some false -> meet_bin (ID.starting ikind (succ l2)) (ID.ending ikind (pred u1)) + | Le, Some false -> meet_bin (ID.starting ikind (Z.succ l2)) (ID.ending ikind (Z.pred u1)) | _, _ -> a, b) | _ -> a, b) | BOr | BXor as op-> From 271cc170734e1c0b645c2114abe76b5047443231 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:19:06 +0200 Subject: [PATCH 475/517] Rename Ptranal wrapper module, add to API docs --- src/analyses/{ptranalEvalFunvar.ml => ptranalAnalysis.ml} | 4 +++- src/goblint_lib.ml | 1 + 2 files changed, 4 insertions(+), 1 deletion(-) rename src/analyses/{ptranalEvalFunvar.ml => ptranalAnalysis.ml} (79%) diff --git a/src/analyses/ptranalEvalFunvar.ml b/src/analyses/ptranalAnalysis.ml similarity index 79% rename from src/analyses/ptranalEvalFunvar.ml rename to src/analyses/ptranalAnalysis.ml index a5d8ca1c9f..d9352448c2 100644 --- a/src/analyses/ptranalEvalFunvar.ml +++ b/src/analyses/ptranalAnalysis.ml @@ -1,4 +1,6 @@ -(** Wrapper analysis to answer EvalFunvar query using Cil's pointer analysis. *) +(** CIL's {!GoblintCil.Ptranal} for function pointer evaluation ([ptranal]). + + Useful for sound analysis of function pointers without base. *) open GoblintCil open Analyses diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 06c51b0c15..4b2eecb632 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -164,6 +164,7 @@ module TaintPartialContexts = TaintPartialContexts module UnassumeAnalysis = UnassumeAnalysis module ExpRelation = ExpRelation module AbortUnless = AbortUnless +module PtranalAnalysis = PtranalAnalysis (** {1 Domains} From 7f80113b2adc89dc9aaeda3f6583879f7b8f5bb2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 22 Jan 2024 15:20:14 +0200 Subject: [PATCH 476/517] Revert part of "Remove unused FlattenedBI module": keep the test This reverts part of the commit 4e95cff843ae0315081517beb47b97677670feb6. --- unittest/cdomains/intDomainTest.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/unittest/cdomains/intDomainTest.ml b/unittest/cdomains/intDomainTest.ml index 763c3e7e93..7caf98a861 100644 --- a/unittest/cdomains/intDomainTest.ml +++ b/unittest/cdomains/intDomainTest.ml @@ -110,6 +110,7 @@ end module Ikind = struct let ikind () = Cil.ILong end module A = IntTest (IntDomain.Integers (IntOps.BigIntOps)) +module B = IntTest (IntDomain.Flat (IntDomain.Integers (IntOps.BigIntOps))) module C = IntTest (IntDomainProperties.WithIkind (IntDomain.DefExc) (Ikind)) module T = struct include IntDomainProperties.WithIkind (IntDomain.DefExc) (Ikind) @@ -282,7 +283,8 @@ end let test () = "intDomainTest" >::: [ "int_Integers" >::: A.test (); - "int_DefExc" >::: C.test (); + "int_Flattened" >::: B.test (); + "int_DefExc" >::: C.test (); "test_bot" >:: test_bot; "test_join" >:: test_join; "test_meet" >:: test_meet; From 808b5d220fe6ea522e9da6f265369eac697468f3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:20:47 +0200 Subject: [PATCH 477/517] Add TODOs to ptranal --- src/analyses/ptranalAnalysis.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/analyses/ptranalAnalysis.ml b/src/analyses/ptranalAnalysis.ml index d9352448c2..6991b5ea22 100644 --- a/src/analyses/ptranalAnalysis.ml +++ b/src/analyses/ptranalAnalysis.ml @@ -2,6 +2,8 @@ Useful for sound analysis of function pointers without base. *) +(* TODO: fix unsoundness on some bench repo examples: https://github.com/goblint/analyzer/pull/1063 *) + open GoblintCil open Analyses @@ -15,6 +17,7 @@ struct match q with | Queries.EvalFunvar (Lval (Mem e, _)) -> let funs = Ptranal.resolve_exp e in + (* TODO: filter compatible function pointers by type? *) List.fold_left (fun xs f -> Queries.AD.add (Queries.AD.Addr.of_var f) xs) (Queries.AD.empty ()) funs | _ -> Queries.Result.top q From 408fbe119057d7f0450be9d63cc2cd11e59fae9a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 22 Jan 2024 15:26:25 +0200 Subject: [PATCH 478/517] Remove dynamic function call debug message --- src/framework/constraints.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 9887f6e4fb..f5c024c24f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -728,7 +728,6 @@ struct [v] | _ -> (* Depends on base for query. *) - M.debug ~category:Program "Dynamic function call through %a" d_exp e; let ad = ctx.ask (Queries.EvalFunvar e) in Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) in From 5c773ed06e6f6d3b354d32132c71b59aba084010 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 22 Jan 2024 16:27:06 +0200 Subject: [PATCH 479/517] Remove unused functions from BigInt --- src/cdomain/value/cdomains/intDomain.ml | 27 ++++++++++++------------ src/cdomain/value/cdomains/intDomain.mli | 2 +- src/domains/intDomainProperties.ml | 2 +- 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 873aebb8a9..085d0f584a 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1774,15 +1774,16 @@ struct end module BigInt = struct + include Printable.StdLeaf include IntOps.BigIntOps let name () = "BigIntPrintable" - let top () = raise Unknown - let bot () = raise Error - let top_of ik = top () - let bot_of ik = bot () - let cast_to ik x = Size.cast ik x let show x = Z.to_string x - include Std (struct type nonrec t = Z.t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 end @@ -1920,13 +1921,13 @@ struct `Excluded (S.empty(), r') else (* downcast: may overflow *) - (* let s' = S.map (BigInt.cast_to ik) s in *) + (* let s' = S.map (Size.cast ik) s in *) (* We want to filter out all i in s' where (t)x with x in r could be i. *) (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) (* S.diff s' s, r' *) (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) `Excluded (S.empty (), r') - | `Definite x -> `Definite (BigInt.cast_to ik x) + | `Definite x -> `Definite (Size.cast ik x) | `Bot -> `Bot (* Wraps definite values and excluded values according to the ikind. @@ -1955,7 +1956,7 @@ struct (* Else an overflow occurred that we should treat with wrap-around *) let r = size ik in (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - let mapped_excl = S.map (fun excl -> BigInt.cast_to ik excl) s in + let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in match ik with | IBool -> begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with @@ -2437,7 +2438,7 @@ module Enums : S with type int_t = Z.t = struct | Inc xs when BISet.for_all value_in_ikind xs -> v | Inc xs -> if should_wrap ikind then - Inc (BISet.map (BigInt.cast_to ikind) xs) + Inc (BISet.map (Size.cast ikind) xs) else if should_ignore_overflow ikind then Inc (BISet.filter value_in_ikind xs) else @@ -2485,7 +2486,7 @@ module Enums : S with type int_t = Z.t = struct else (* downcast: may overflow *) Exc ((BISet.empty ()), r') | Inc xs -> - let casted_xs = BISet.map (BigInt.cast_to ik) xs in + let casted_xs = BISet.map (Size.cast ik) xs in if Cil.isSigned ik && not (BISet.equal xs casted_xs) then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) else Inc casted_xs @@ -2775,7 +2776,7 @@ struct | Some (c, m) -> if m =: Z.zero then if should_wrap ik then - Some (BigInt.cast_to ik c, m) + Some (Size.cast ik c, m) else Some (c, m) else @@ -2897,7 +2898,7 @@ struct match x with | None -> None | Some (c, m) when m =: Z.zero -> - let c' = BigInt.cast_to t c in + let c' = Size.cast t c in (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) (* We go with GCC behavior here: *) (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index cc43c32ace..724c0776b5 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -366,6 +366,7 @@ module Size : sig val range : Cil.ikind -> Z.t * Z.t val is_cast_injective : from_type:Cil.typ -> to_type:Cil.typ -> bool val bits : Cil.ikind -> int * int + val cast : Cil.ikind -> Z.t -> Z.t end module BISet: SetDomain.S with type elt = Z.t @@ -408,7 +409,6 @@ module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) op module BigInt: sig include Printable.S with type t = Z.t - val cast_to: Cil.ikind -> Z.t -> Z.t end module Interval : SOverflow with type int_t = Z.t diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index fa41ba645e..e18ce65554 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -73,7 +73,7 @@ struct module Base = struct include IntDomain.Integers(IntOps.BigIntOps) - let arbitrary () = QCheck.map_same_type (IntDomain.BigInt.cast_to (Ikind.ikind ())) (arbitrary ()) + let arbitrary () = QCheck.map_same_type (IntDomain.Size.cast (Ikind.ikind ())) (arbitrary ()) end include SetDomain.Make(Base) From a8d74cd2b991c33368991cfaf32b0d1a806f2379 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 22 Jan 2024 16:48:09 +0200 Subject: [PATCH 480/517] Include Printable to IntOpsDecorator and make IntOps printable --- src/cdomain/value/cdomains/intDomain.ml | 9 --------- src/cdomain/value/cdomains/intDomain.mli | 5 ----- src/cdomain/value/cdomains/nullByteSet.ml | 6 +++--- src/cdomains/apron/sharedFunctions.apron.ml | 2 +- src/common/util/intOps.ml | 14 ++++++++++++++ 5 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 085d0f584a..1fc6a49143 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1774,16 +1774,7 @@ struct end module BigInt = struct - include Printable.StdLeaf include IntOps.BigIntOps - let name () = "BigIntPrintable" - let show x = Z.to_string x - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 end diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 724c0776b5..35ebc03794 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -406,11 +406,6 @@ module IntervalSetFunctor(Ints_t : IntOps.IntOps): SOverflow with type int_t = I module Interval32 :Y with (* type t = (IntOps.Int64Ops.t * IntOps.Int64Ops.t) option and *) type int_t = IntOps.Int64Ops.t -module BigInt: - sig - include Printable.S with type t = Z.t - end - module Interval : SOverflow with type int_t = Z.t module IntervalSet : SOverflow with type int_t = Z.t diff --git a/src/cdomain/value/cdomains/nullByteSet.ml b/src/cdomain/value/cdomains/nullByteSet.ml index ff5d0270e0..ae382b6118 100644 --- a/src/cdomain/value/cdomains/nullByteSet.ml +++ b/src/cdomain/value/cdomains/nullByteSet.ml @@ -1,7 +1,7 @@ (** 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)) + module M = SetDomain.Reverse (SetDomain.ToppedSet (IntOps.BigIntOps) (struct let topname = "All Null" end)) include M let compute_set len = @@ -45,7 +45,7 @@ module MustSet = struct end module MaySet = struct - module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) + module M = SetDomain.ToppedSet (IntOps.BigIntOps) (struct let topname = "All Null" end) include M let elements ?max_size may_nulls_set = @@ -80,7 +80,7 @@ end module MustMaySet = struct include Lattice.Prod (MustSet) (MaySet) - module Set = SetDomain.Make (IntDomain.BigInt) + module Set = SetDomain.Make (IntOps.BigIntOps) type mode = Definitely | Possibly diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index ff1f14891e..f7b800a404 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -129,7 +129,7 @@ struct match Bounds.bound_texpr d texpr1 with | Some min, Some max when Z.compare type_min min <= 0 && Z.compare max type_max <= 0 -> () | min_opt, max_opt -> - if M.tracing then M.trace "apron" "may overflow: %a (%a, %a)\n" CilType.Exp.pretty exp (Pretty.docOpt (IntDomain.BigInt.pretty ())) min_opt (Pretty.docOpt (IntDomain.BigInt.pretty ())) max_opt; + if M.tracing then M.trace "apron" "may overflow: %a (%a, %a)\n" CilType.Exp.pretty exp (Pretty.docOpt (IntOps.BigIntOps.pretty ())) min_opt (Pretty.docOpt (IntOps.BigIntOps.pretty ())) max_opt; raise (Unsupported_CilExp Overflow) ); expr diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index 24aa4e3f66..0f0da6fa7b 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -9,6 +9,8 @@ module type IntOpsBase = sig type t + val name : unit -> string + (* Constants *) val zero : t val one : t @@ -74,6 +76,7 @@ end module NIntOpsBase : IntOpsBase with type t = int = struct type t = int [@@deriving hash] + let name () = "int" let zero = 0 let one = 1 let lower_bound = Some min_int @@ -117,6 +120,7 @@ end module Int32OpsBase : IntOpsBase with type t = int32 = struct type t = int32 [@@deriving hash] + let name () = "int32" let zero = 0l let one = 1l let lower_bound = Some Int32.min_int @@ -162,6 +166,7 @@ end module Int64OpsBase : IntOpsBase with type t = int64 = struct type t = int64 [@@deriving hash] + let name () = "int64" let zero = 0L let one = 1L let lower_bound = Some Int64.min_int @@ -207,6 +212,7 @@ end module BigIntOpsBase : IntOpsBase with type t = Z.t = struct type t = Z.t + let name () = "Z" let zero = Z.zero let one = Z.one let upper_bound = None @@ -251,7 +257,15 @@ end module IntOpsDecorator(B: IntOpsBase) = struct + include Printable.StdLeaf include B + let show = to_string + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = to_string + end + ) let pred x = sub x one let of_bool x = if x then one else zero let to_bool x = x <> zero From bc267c80c0f4c4a007f5a9222d3474fe1f6847d7 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 22 Jan 2024 16:54:59 +0200 Subject: [PATCH 481/517] Remove IntDomain.BigInt --- src/cdomain/value/cdomains/intDomain.ml | 21 ++++++++------------- src/common/util/intOps.ml | 9 +++++++++ 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 1fc6a49143..e32cf098c1 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1773,13 +1773,8 @@ struct include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) end -module BigInt = struct - include IntOps.BigIntOps - let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 -end - module BISet = struct - include SetDomain.Make (BigInt) + include SetDomain.Make (IntOps.BigIntOps) let is_singleton s = cardinal s = 1 end @@ -2062,7 +2057,7 @@ struct let of_bool = of_bool_cmp let to_bool x = match x with - | `Definite x -> Some (BigInt.to_bool x) + | `Definite x -> Some (IntOps.BigIntOps.to_bool x) | `Excluded (s,r) when S.mem Z.zero s -> Some true | _ -> None let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) @@ -2257,14 +2252,14 @@ struct | _, Some false -> of_bool ik false | _, _ -> - lift2 BigInt.logand ik x y + lift2 IntOps.BigIntOps.logand ik x y let logor ik x y = match to_bool x, to_bool y with | Some true, _ | _, Some true -> of_bool ik true | _, _ -> - lift2 BigInt.logor ik x y + lift2 IntOps.BigIntOps.logor ik x y let lognot ik = eq ik (of_int ik Z.zero) let invariant_ikind e ik (x:t) = @@ -2297,12 +2292,12 @@ struct let definite x = of_int ik x in let shrink = function | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (BigInt.arbitrary ()) x >|= definite) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) | `Bot -> empty in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map excluded (S.arbitrary ()); - 10, QCheck.map definite (BigInt.arbitrary ()); + 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); 1, QCheck.always `Bot ] (* S TODO: decide frequencies *) @@ -2630,8 +2625,8 @@ module Enums : S with type int_t = Z.t = struct | Some b -> of_bool ik (not b) | None -> top_bool - let logand = lift2 BigInt.logand - let logor = lift2 BigInt.logor + let logand = lift2 IntOps.BigIntOps.logand + let logor = lift2 IntOps.BigIntOps.logor let maximal = function | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) | Exc (excl,r) -> diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index 0f0da6fa7b..a14305b0c2 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -55,6 +55,8 @@ sig val to_string : t -> string val of_bigint : Z.t -> t val to_bigint : t -> Z.t + + val arbitrary : unit -> t QCheck.arbitrary end module type IntOps = @@ -115,6 +117,8 @@ struct let to_string = string_of_int let of_bigint = Z.to_int let to_bigint = Z.of_int + + let arbitrary () = QCheck.int end module Int32OpsBase : IntOpsBase with type t = int32 = @@ -161,6 +165,8 @@ struct let to_string = Int32.to_string let of_bigint = Z.to_int32 let to_bigint = Z.of_int32 + + let arbitrary () = QCheck.int32 end module Int64OpsBase : IntOpsBase with type t = int64 = @@ -207,6 +213,8 @@ struct let to_string = Int64.to_string let of_bigint = Z.to_int64 let to_bigint = Z.of_int64 + + let arbitrary () = QCheck.int64 end module BigIntOpsBase : IntOpsBase with type t = Z.t = @@ -252,6 +260,7 @@ struct let bitor = Z.logor let bitxor = Z.logxor + let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 end From 0e1b389f56e419d792c5032ce7d8dc1e74609930 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 23 Jan 2024 12:50:06 +0200 Subject: [PATCH 482/517] Implement GobZ.pretty and use it where possible --- src/analyses/baseInvariant.ml | 6 +++--- src/cdomain/value/cdomains/intDomain.ml | 11 ++++++----- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- src/common/util/cilfacade.ml | 2 +- src/util/std/gobZ.ml | 2 ++ 5 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f6cd11afa9..efd098d994 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -139,7 +139,7 @@ struct match ID.to_int n with | Some n -> (* When x != n, we can return a singleton exclusion set *) - if M.tracing then M.tracec "invariant" "Yes, %a is not %s\n" d_lval x (Z.to_string n); + if M.tracing then M.tracec "invariant" "Yes, %a is not %a\n" d_lval x GobZ.pretty n; let ikind = Cilfacade.get_ikind_exp (Lval lval) in Some (x, Int (ID.of_excl_list ikind [n])) | None -> None @@ -172,7 +172,7 @@ struct let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> - if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (Z.to_string n); + if M.tracing then M.tracec "invariant" "Yes, success! %a is not %a\n\n" d_lval x GobZ.pretty n; Some (x, Int (range_from n)) | None -> None end @@ -187,7 +187,7 @@ struct let limit_from = if tv then ID.maximal else ID.minimal in match limit_from n with | Some n -> - if M.tracing then M.tracec "invariant" "Yes, success! %a is not %s\n\n" d_lval x (Z.to_string n); + if M.tracing then M.tracec "invariant" "Yes, success! %a is not %a\n\n" d_lval x GobZ.pretty n; Some (x, Int (range_from n)) | None -> None end diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e32cf098c1..75224084e1 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -415,7 +415,7 @@ module Size = struct (* size in bits as int, range as int64 *) let is_cast_injective ~from_type ~to_type = let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%s, %s) -> %a (%s, %s)\n" CilType.Typ.pretty from_type (Z.to_string from_min) (Z.to_string from_max) CilType.Typ.pretty to_type (Z.to_string to_min) (Z.to_string to_max); + if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)\n" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 let cast t x = (* TODO: overflow is implementation-dependent! *) @@ -430,7 +430,7 @@ module Size = struct (* size in bits as int, range as int64 *) else if Z.lt y a then Z.add y c else y in - if M.tracing then M.tracel "cast" "Cast %s to range [%s, %s] (%s) = %s (%s in int64)\n" (Z.to_string x) (Z.to_string a) (Z.to_string b) (Z.to_string c) (Z.to_string y) (if is_int64_big_int y then "fits" else "does not fit"); + if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)\n" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); y let min_range_sign_agnostic x = @@ -3215,9 +3215,10 @@ struct | _ -> None let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = - let pretty_intv _ i = (match i with - | Some(l, u) -> let s = "["^Z.to_string l^","^Z.to_string u^"]" in Pretty.text s - | _ -> Pretty.text ("Display Error")) in + let pretty_intv _ i = + match i with + | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u + | _ -> Pretty.text ("Display Error") in let refn = refine_with_interval ik cong intv in if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a\n" pretty cong pretty_intv intv pretty refn; refn diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 5485dd3f02..661e220d69 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -224,7 +224,7 @@ struct let res = bound_texpr d texpr1 in (if M.tracing then match res with - | Some min, Some max -> M.tracel "bounds" "min: %s max: %s" (Z.to_string min) (Z.to_string max) + | Some min, Some max -> M.tracel "bounds" "min: %a max: %a" GobZ.pretty min GobZ.pretty max | _ -> () ); res diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index eff97da404..749ede4fc2 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -427,7 +427,7 @@ let rec pretty_typsig_like_typ (nameOpt: Pretty.doc option) () ts = pretty_typsig_like_typ (Some (name' ++ text "[" - ++ (match lo with None -> nil | Some e -> text (Z.to_string e)) + ++ (match lo with None -> nil | Some e -> GobZ.pretty () e) ++ text "]")) () elemt diff --git a/src/util/std/gobZ.ml b/src/util/std/gobZ.ml index 598b8448dc..02110ac8bb 100644 --- a/src/util/std/gobZ.ml +++ b/src/util/std/gobZ.ml @@ -8,3 +8,5 @@ let rec for_all_range f (a, b) = true else f a && for_all_range f (Z.succ a, b) + +let pretty () x = GoblintCil.Pretty.text (Z.to_string x) From 0417cf723bf1a989b037c2ad21dea50203ac75b3 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Tue, 23 Jan 2024 12:51:24 +0200 Subject: [PATCH 483/517] Simplify same --- src/cdomain/value/cdomains/intDomain.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 75224084e1..c3ab114afc 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -3575,12 +3575,14 @@ module IntDomTupleImpl = struct if List.mem `Eq xs then `Eq else if List.mem `Neq xs then `Neq else `Top - let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in - if n = 1 then Some (List.hd xs) - else ( - if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) + let same show x = + let us = List.unique (to_list_some x) in + match us with + | [x] -> Some (List.hd us) + | [] -> None + | _ -> + Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) None - ) let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } From 3991fbd1a6b358539abf469237e214050f1a22e6 Mon Sep 17 00:00:00 2001 From: Karoliine Holter <44437975+karoliineh@users.noreply.github.com> Date: Tue, 23 Jan 2024 12:54:56 +0200 Subject: [PATCH 484/517] Remove redundant List.hd call Co-authored-by: Simmo Saan --- src/cdomain/value/cdomains/intDomain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index c3ab114afc..46c43f44dd 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -3578,7 +3578,7 @@ module IntDomTupleImpl = struct let same show x = let us = List.unique (to_list_some x) in match us with - | [x] -> Some (List.hd us) + | [x] -> Some x | [] -> None | _ -> Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) From 380979e71c0d3e2b47a05b59b3eee67ea5cf7785 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 13:50:39 +0200 Subject: [PATCH 485/517] Copy VMCAI 2024 artifact description from bench repo --- docs/artifact-descriptions/vmcai24.md | 76 +++++++++++++++++++++++++++ mkdocs.yml | 1 + 2 files changed, 77 insertions(+) create mode 100644 docs/artifact-descriptions/vmcai24.md diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md new file mode 100644 index 0000000000..3673937dc6 --- /dev/null +++ b/docs/artifact-descriptions/vmcai24.md @@ -0,0 +1,76 @@ +# Correctness Witness Validation by Abstract Interpretation +## Artifact + +This artifact contains everything mentioned in the evaluation section of the paper: Goblint implementation, scripts, benchmarks, manual witnesses and other tools. + +**Note to artifact reviewers:** in the smoke test phase, try to only run the performance evaluation since it is very quick compared to the precision evaluation. + +## Requirements +* [VirtualBox](https://www.virtualbox.org/). +* 2 CPU cores. +* 8 GB RAM. +* 7 GB disk space. +* ~45min. + +## Layout +* `README.md`/`README.pdf` — this file. +* `LICENSE`. +* `unassume.ova` — VirtualBox virtual machine. + + In `/home/vagrant` contains: + * `goblint/` ­— Goblint with unassume support, including source code. + * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). + * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). + * `results/` — results (initially empty). + +* `results/` — evaluation results tables with data used for the paper. + +## Reproduction +1. Import the virtual machine into VirtualBox. +2. Start the virtual machine and log in with username "vagrant" (not "Ubuntu"!) and password "vagrant". +3. Right click on the desktop and open Applications → Accessories → Terminal Emulator. + +### Precision evaluation +1. Run `./eval-prec/run.sh` in the terminal emulator. This takes ~42min. +2. Run `firefox results/eval-prec/table-generator.table.html` to view the results. + + The HTML table contains the following status columns (cputime, walltime and memory can be ignored): + 1. Goblint w/o witness (true means verified). + 2. Goblint w/ manual witness (true means witness validated). + 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). + 4. Goblint w/ witness from CPAchecker (true means witness validated). + 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). + 6. Goblint w/ witness from UAutomizer (true means witness validated). + + Table 1 in the paper presents these results, except the rows are likely in a different order. + +### Performance evaluation +1. Run `./eval-perf/run.sh` in the terminal emulator. This takes ~30s. +2. Run `firefox results/eval-perf/table-generator.table.html` to view the results. + + The HTML table contains the following relevant columns (others can be ignored): + 1. Goblint w/o witness, evals. + 2. Goblint w/o witness, cputime. + 3. Goblint w/ manual witness, evals. + 4. Goblint w/ manual witness, cputime. + + Table 2 in the paper presents these results, except the rows are likely in a different order. + + +## Goblint implementation +[Goblint](https://github.com/goblint/analyzer) is an open source static analysis framework for C. +Goblint itself is written in OCaml. +Being open source, it allows existing implementations of analyses and abstract domains to be reused and modified. +As a framework, it also allows new ones to be easily added. +For more details, refer to the linked GitHub repository and related documentation. + +Key parts of the code related to this paper are the following: + +1. `src/analyses/unassumeAnalysis.ml`: analysis, which emits unassume operation events to other analyses for YAML-witness–guided verification. +2. `src/analyses/base.ml` lines 2551–2641: propagating unassume for non-relational domains of the `base` analysis. +3. `src/analyses/apron/relationAnalysis.apron.ml` lines 668–693: strengthening-based dual-narrowing unassume for relational Apron domains of the `apron` analysis. +4. `src/cdomains/apron/apronDomain.apron.ml` lines 625–679: strengthening operator used for dual-narrowing of Apron domains. +5. `src/util/wideningTokens.ml`: analysis lifter that adds widening tokens for delaying widenings from unassuming. +6. `src/witness/yamlWitness.ml` lines 398–683: YAML witness validation. diff --git a/mkdocs.yml b/mkdocs.yml index 428e28078d..8064703c12 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -39,3 +39,4 @@ nav: - '📦 Artifact descriptions': - "🇸 SAS '21": artifact-descriptions/sas21.md - "🇪 ESOP '23": artifact-descriptions/esop23.md + - "🇻 VMCAI '24": artifact-descriptions/vmcai24.md From 3625b6719c2e41064809900c9d408667846c932a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 13:51:23 +0200 Subject: [PATCH 486/517] Fix lists in VMACI24 artifact description --- docs/artifact-descriptions/vmcai24.md | 41 ++++++++++++++------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md index 3673937dc6..9f44bd20e4 100644 --- a/docs/artifact-descriptions/vmcai24.md +++ b/docs/artifact-descriptions/vmcai24.md @@ -17,13 +17,14 @@ This artifact contains everything mentioned in the evaluation section of the pap * `LICENSE`. * `unassume.ova` — VirtualBox virtual machine. - In `/home/vagrant` contains: - * `goblint/` ­— Goblint with unassume support, including source code. - * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). - * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). - * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). - * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). - * `results/` — results (initially empty). + In `/home/vagrant` contains: + + * `goblint/` ­— Goblint with unassume support, including source code. + * `CPAchecker-2.2-unix/` — CPAchecker from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `UAutomizer-linux/` — Ultimate Automizer from [SV-COMP 2023 archives](https://gitlab.com/sosy-lab/sv-comp/archives-2023). + * `eval-prec/` — precision evaluation (script, benchmarks, manual witnesses). + * `eval-perf/` — performance evaluation (script, benchmarks, manual witnesses). + * `results/` — results (initially empty). * `results/` — evaluation results tables with data used for the paper. @@ -36,13 +37,14 @@ This artifact contains everything mentioned in the evaluation section of the pap 1. Run `./eval-prec/run.sh` in the terminal emulator. This takes ~42min. 2. Run `firefox results/eval-prec/table-generator.table.html` to view the results. - The HTML table contains the following status columns (cputime, walltime and memory can be ignored): - 1. Goblint w/o witness (true means verified). - 2. Goblint w/ manual witness (true means witness validated). - 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). - 4. Goblint w/ witness from CPAchecker (true means witness validated). - 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). - 6. Goblint w/ witness from UAutomizer (true means witness validated). + The HTML table contains the following status columns (cputime, walltime and memory can be ignored): + + 1. Goblint w/o witness (true means verified). + 2. Goblint w/ manual witness (true means witness validated). + 3. Goblint w/ witness from CPAchecker (true means program verified with witness-guidance). + 4. Goblint w/ witness from CPAchecker (true means witness validated). + 5. Goblint w/ witness from UAutomizer (true means program verified with witness-guidance). + 6. Goblint w/ witness from UAutomizer (true means witness validated). Table 1 in the paper presents these results, except the rows are likely in a different order. @@ -50,11 +52,12 @@ This artifact contains everything mentioned in the evaluation section of the pap 1. Run `./eval-perf/run.sh` in the terminal emulator. This takes ~30s. 2. Run `firefox results/eval-perf/table-generator.table.html` to view the results. - The HTML table contains the following relevant columns (others can be ignored): - 1. Goblint w/o witness, evals. - 2. Goblint w/o witness, cputime. - 3. Goblint w/ manual witness, evals. - 4. Goblint w/ manual witness, cputime. + The HTML table contains the following relevant columns (others can be ignored): + + 1. Goblint w/o witness, evals. + 2. Goblint w/o witness, cputime. + 3. Goblint w/ manual witness, evals. + 4. Goblint w/ manual witness, cputime. Table 2 in the paper presents these results, except the rows are likely in a different order. From d57d3c1193253ce69f36c7be4e618ad94e7be12c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 14:26:16 +0200 Subject: [PATCH 487/517] Rewrite VMCAI24 artifact description intro --- docs/artifact-descriptions/vmcai24.md | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/docs/artifact-descriptions/vmcai24.md b/docs/artifact-descriptions/vmcai24.md index 9f44bd20e4..860ef6c9fd 100644 --- a/docs/artifact-descriptions/vmcai24.md +++ b/docs/artifact-descriptions/vmcai24.md @@ -1,9 +1,13 @@ -# Correctness Witness Validation by Abstract Interpretation -## Artifact +# VMCAI '24 Artifact Description +## Correctness Witness Validation by Abstract Interpretation + +This is the artifact description for our [VMCAI '24 paper "Correctness Witness Validation by Abstract Interpretation"](https://doi.org/10.1007/978-3-031-50524-9_4). +The artifact is available on [Zenodo](https://doi.org/10.5281/zenodo.8253000). This artifact contains everything mentioned in the evaluation section of the paper: Goblint implementation, scripts, benchmarks, manual witnesses and other tools. -**Note to artifact reviewers:** in the smoke test phase, try to only run the performance evaluation since it is very quick compared to the precision evaluation. +**The description here is provided for convenience and not maintained.** +The artifact is based on [Goblint at `vmcai24` git tag](https://github.com/goblint/analyzer/releases/tag/vmcai24) and [Goblint benchmarks at `vmcai24` git tag](https://github.com/goblint/bench/releases/tag/vmcai24). ## Requirements * [VirtualBox](https://www.virtualbox.org/). From 5d291caf43da73d24f3093ec36cced018972cc30 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 17:30:15 +0200 Subject: [PATCH 488/517] Use Cilfacade.get_stmtLoc in TerminationPreprocessing --- src/util/terminationPreprocessing.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/util/terminationPreprocessing.ml b/src/util/terminationPreprocessing.ml index 9023a68f8a..95fae95d26 100644 --- a/src/util/terminationPreprocessing.ml +++ b/src/util/terminationPreprocessing.ml @@ -59,8 +59,8 @@ class loopCounterVisitor lc (fd : fundec) = object(self) s.skind <- Block nb; s | Goto (sref, l) -> - let goto_jmp_stmt = sref.contents.skind in - let loc_stmt = Cil.get_stmtLoc goto_jmp_stmt in + let goto_jmp_stmt = sref.contents in + let loc_stmt = Cilfacade.get_stmtLoc goto_jmp_stmt in if CilType.Location.compare l loc_stmt >= 0 then ( (* is pos if first loc is greater -> below the second loc *) (* problem: the program might not terminate! *) From b9e390598e3c9306673a1c3b6a2338f34a641f0f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 23 Jan 2024 17:30:23 +0200 Subject: [PATCH 489/517] Use List.concat_map in EvalAssert --- src/transform/evalAssert.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/transform/evalAssert.ml b/src/transform/evalAssert.ml index 91bdb82ce1..9f8f785817 100644 --- a/src/transform/evalAssert.ml +++ b/src/transform/evalAssert.ml @@ -119,7 +119,7 @@ module EvalAssert = struct s | If (e, b1, b2, l,l2) -> let vars = Basetype.CilExp.get_vars e in - let asserts ~node loc vs = if full then make_assert ~node loc None else List.map (fun x -> make_assert ~node loc (Some (Var x,NoOffset))) vs |> List.concat in + let asserts ~node loc vs = if full then make_assert ~node loc None else List.concat_map (fun x -> make_assert ~node loc (Some (Var x,NoOffset))) vs in let add_asserts block = if block.bstmts <> [] then let with_asserts = From f1daea022fb7d85cf5c02de36768417ee797e326 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:11:08 +0200 Subject: [PATCH 490/517] Remove some empty if branches found by semgrep --- src/analyses/base.ml | 2 +- src/analyses/poisonVariables.ml | 2 -- src/cdomain/value/cdomains/arrayDomain.ml | 1 - src/common/framework/cfgTools.ml | 2 -- src/common/util/cilfacade.ml | 2 -- src/framework/constraints.ml | 2 +- src/solver/generic.ml | 2 +- src/solver/sLR.ml | 4 ++-- src/transform/evalAssert.ml | 2 -- 9 files changed, 5 insertions(+), 14 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index fb2b5af517..c66b53320e 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -511,7 +511,7 @@ struct if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with | Top -> - if VD.is_immediate_type t then () else M.info ~category:Unsound "Unknown value in %s could be an escaped pointer address!" description; empty + if not (VD.is_immediate_type t) then M.info ~category:Unsound "Unknown value in %s could be an escaped pointer address!" description; empty | Bot -> (*M.debug ~category:Analyzer "A bottom value when computing reachable addresses!";*) empty | Address adrs when AD.is_top adrs -> M.info ~category:Unsound "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) diff --git a/src/analyses/poisonVariables.ml b/src/analyses/poisonVariables.ml index 865cb928aa..7100534fab 100644 --- a/src/analyses/poisonVariables.ml +++ b/src/analyses/poisonVariables.ml @@ -82,8 +82,6 @@ struct M.info ~category:(Behavior (Undefined Other)) ~loc:(Node longjmp_node) "Since setjmp at %a, potentially all locals were modified! Reading them will yield Undefined Behavior." Node.pretty ctx.prev_node else if not (Queries.VS.is_empty modified_locals) then M.info ~category:(Behavior (Undefined Other)) ~loc:(Node longjmp_node) "Since setjmp at %a, locals %a were modified! Reading them will yield Undefined Behavior." Node.pretty ctx.prev_node Queries.VS.pretty modified_locals - else - () ) longjmp_nodes; D.join modified_locals ctx.local | Access {ad; kind = Read; _} -> diff --git a/src/cdomain/value/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml index d4d5a46e98..ba205fa14f 100644 --- a/src/cdomain/value/cdomains/arrayDomain.ml +++ b/src/cdomain/value/cdomains/arrayDomain.ml @@ -855,7 +855,6 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | _ -> AnalysisStateUtil.set_mem_safety_flag InvalidDeref; M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown "May access array out of bounds" - else () module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = diff --git a/src/common/framework/cfgTools.ml b/src/common/framework/cfgTools.ml index 78aba17060..d47f1efde0 100644 --- a/src/common/framework/cfgTools.ml +++ b/src/common/framework/cfgTools.ml @@ -695,8 +695,6 @@ let getGlobalInits (file: file) : edges = Hashtbl.add inits (assign lval) () else if not (Hashtbl.mem inits (assign (any_index lval))) then Hashtbl.add inits (assign (any_index lval)) () - else - () | CompoundInit (typ, lst) -> let ntyp = match typ, lst with | TArray(t, None, attr), [] -> TArray(t, Some zero, attr) (* set initializer type to t[0] for flexible array members of structs that are intialized with {} *) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index eff97da404..d80ce49543 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -84,8 +84,6 @@ let do_preprocess ast = let f fd visitor_fun = ignore @@ visitCilFunction (visitor_fun fd) fd in if active_visitors <> [] then iterGlobals ast (function GFun (fd,_) -> List.iter (f fd) active_visitors | _ -> ()) - else - () (** @raise GoblintCil.FrontC.ParseError @raise GoblintCil.Errormsg.Error *) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index f5c024c24f..84d7eff1ed 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -1733,7 +1733,7 @@ struct let compare_locals h1 h2 = let eq, le, gr, uk = ref 0, ref 0, ref 0, ref 0 in let f k v1 = - if not (PP.mem h2 k) then () else + if PP.mem h2 k then let v2 = PP.find h2 k in let b1 = D.leq v1 v2 in let b2 = D.leq v2 v1 in diff --git a/src/solver/generic.ml b/src/solver/generic.ml index 636aed8831..1a866546a1 100644 --- a/src/solver/generic.ml +++ b/src/solver/generic.ml @@ -256,7 +256,7 @@ module SoundBoxSolverImpl = H.replace called x (); (* set the new value for [x] *) eval_rhs_event x; - let set_x d = if H.mem called x then set x d else () in + let set_x d = if H.mem called x then set x d in Option.may (fun f -> set_x (f (eval x) side)) (S.system x); (* remove [x] from called *) H.remove called x diff --git a/src/solver/sLR.ml b/src/solver/sLR.ml index d05d87c4f3..8213fe8166 100644 --- a/src/solver/sLR.ml +++ b/src/solver/sLR.ml @@ -327,7 +327,7 @@ module Make0 = let k = X.get_key x in let _ = work := H.insert !work x in let _ = P.rem_item stable x in - if k >= sk then () else + if k < sk then let _ = X.set_value x (D.bot ()) in (* ignore @@ Pretty.printf " also restarting %d: %a\n" k S.Var.pretty_trace x; *) (* flush_all (); *) @@ -348,7 +348,7 @@ module Make0 = let (i,nonfresh) = X.get_index y in let _ = if xi <= i then HM.replace wpoint y () in let _ = if (V.ver>2) && xi <= i then work := H.insert (!work) y in - let _ = if nonfresh then () else solve y in + let _ = if not nonfresh then solve y in let _ = L.add infl y x in X.get_value y diff --git a/src/transform/evalAssert.ml b/src/transform/evalAssert.ml index 9f8f785817..eab06222ef 100644 --- a/src/transform/evalAssert.ml +++ b/src/transform/evalAssert.ml @@ -130,8 +130,6 @@ module EvalAssert = struct [cStmt "{ %I:asserts %S:b }" (fun n t -> makeVarinfo true "unknown" (TVoid [])) b_loc [("asserts", FI b_assert_instr); ("b", FS block.bstmts)]] in block.bstmts <- with_asserts - else - () in if emit_other then (add_asserts b1; add_asserts b2); s From fe4b6b15297363f35f23b6ff3f167a2e220bcbd2 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:11:39 +0200 Subject: [PATCH 491/517] Use String.sub alternatives found by semgrep --- src/cdomain/value/cdomains/addressDomain.ml | 2 +- src/cdomain/value/cdomains/stringDomain.ml | 2 +- src/cdomains/apron/affineEqualityDomain.apron.ml | 2 +- src/config/gobConfig.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/cdomain/value/cdomains/addressDomain.ml b/src/cdomain/value/cdomains/addressDomain.ml index 55b1aceefc..263c1033bb 100644 --- a/src/cdomain/value/cdomains/addressDomain.ml +++ b/src/cdomain/value/cdomains/addressDomain.ml @@ -277,7 +277,7 @@ struct let compute_substring s1 s2 = try let i = Str.search_forward (Str.regexp_string s2) s1 0 in - Some (String.sub s1 i (String.length s1 - i)) + Some (Str.string_after s1 i) with Not_found -> None in (* if any of the input address sets contains an element that isn't a StrPtr, return top *) diff --git a/src/cdomain/value/cdomains/stringDomain.ml b/src/cdomain/value/cdomains/stringDomain.ml index 0621f37eb6..2b968b0321 100644 --- a/src/cdomain/value/cdomains/stringDomain.ml +++ b/src/cdomain/value/cdomains/stringDomain.ml @@ -62,7 +62,7 @@ let to_n_c_string n x = else if n < 0 then None else - Some (String.sub x 0 n) + Some (Str.first_chars x n) | None -> None let to_string_length x = diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index 55937a323d..f6232d95e6 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -282,7 +282,7 @@ struct let res = (String.concat "" @@ Array.to_list @@ Array.map dim_to_str vars) ^ (const_to_str arr.(Array.length arr - 1)) ^ "=0" in if String.starts_with res "+" then - String.sub res 1 (String.length res - 1) + Str.string_after res 1 else res in diff --git a/src/config/gobConfig.ml b/src/config/gobConfig.ml index 24a1701ce6..16b5511717 100644 --- a/src/config/gobConfig.ml +++ b/src/config/gobConfig.ml @@ -140,7 +140,7 @@ struct let rec split' i = if i Date: Wed, 24 Jan 2024 12:11:59 +0200 Subject: [PATCH 492/517] Remove some boolean equality checks found by semgrep --- src/analyses/raceAnalysis.ml | 2 +- src/incremental/compareCFG.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 6b7217147e..7dae319d6f 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -349,7 +349,7 @@ struct | ts when Queries.TS.is_top ts -> includes_uk := true | ts -> - if Queries.TS.is_empty ts = false then + if not (Queries.TS.is_empty ts) then includes_uk := true; let f = function | TComp (ci, _) -> diff --git a/src/incremental/compareCFG.ml b/src/incremental/compareCFG.ml index 55b3fa8fc5..84b120b8e3 100644 --- a/src/incremental/compareCFG.ml +++ b/src/incremental/compareCFG.ml @@ -97,7 +97,7 @@ let compareCfgs (module CfgOld : CfgForward) (module CfgNew : CfgForward) fun1 f * case the edge is directly added to the diff set to avoid undetected ambiguities during the recursive * call. *) let testFalseEdge edge = match edge with - | Test (p,b) -> p = Cil.one && b = false + | Test (p,false) -> p = Cil.one | _ -> false in let posAmbigEdge edgeList = let findTestFalseEdge (ll,_) = testFalseEdge (snd (List.hd ll)) in let numDuplicates l = List.length (List.find_all findTestFalseEdge l) in From 96a57a23900f11dca735786e38aaa65644d97534 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 12:12:11 +0200 Subject: [PATCH 493/517] Use incr in CilCfg.countLoopsVisitor --- src/util/cilCfg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/cilCfg.ml b/src/util/cilCfg.ml index 923cf7600b..df766d5bdd 100644 --- a/src/util/cilCfg.ml +++ b/src/util/cilCfg.ml @@ -29,7 +29,7 @@ class countLoopsVisitor(count) = object inherit nopCilVisitor method! vstmt stmt = match stmt.skind with - | Loop _ -> count := !count + 1; DoChildren + | Loop _ -> incr count; DoChildren | _ -> DoChildren end From 51b3fd0ced852c4f45dc3f92e8a4c0f185796089 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 17:15:21 +0200 Subject: [PATCH 494/517] Add minimized test for issue #1249 Co-authored-by: Michael Schwarz --- tests/regression/46-apron2/58-issue-1249.c | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 tests/regression/46-apron2/58-issue-1249.c diff --git a/tests/regression/46-apron2/58-issue-1249.c b/tests/regression/46-apron2/58-issue-1249.c new file mode 100644 index 0000000000..862c539d15 --- /dev/null +++ b/tests/regression/46-apron2/58-issue-1249.c @@ -0,0 +1,10 @@ +// SKIP PARAM: --set ana.activated[+] apron +int *a; +int b; +void c(int d) { + // *a is a null pointer here, so we should warn but maybe not crash + *a = d; +} +int main() { + c(b); +} From 0c72eddbcf731f7a000eca1eb8b27dd3d1f91f17 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 24 Jan 2024 17:16:00 +0200 Subject: [PATCH 495/517] Fix NullPtr assignment crash in relation analysis --- src/analyses/apron/relationAnalysis.apron.ml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index e572755930..c9f8cd750a 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -158,13 +158,14 @@ struct {st' with rel = rel''} ) | (Mem v, NoOffset) -> - begin match ask.f (Queries.MayPointTo v) with - | ad when Queries.AD.is_top ad -> st - | ad -> - let mvals = Queries.AD.to_mval ad in - let ass' = List.map (fun mval -> assign_to_global_wrapper ask getg sideg st (ValueDomain.Addr.Mval.to_cil mval) f) mvals in - List.fold_right D.join ass' (D.bot ()) - end + let ad = ask.f (Queries.MayPointTo v) in + Queries.AD.fold (fun addr acc -> + match addr with + | ValueDomain.Addr.Addr mval -> + D.join acc (assign_to_global_wrapper ask getg sideg st (ValueDomain.Addr.Mval.to_cil mval) f) + | UnknownPtr | NullPtr | StrPtr _ -> + D.join acc st (* Ignore assign *) + ) ad (D.bot ()) (* Ignoring all other assigns *) | _ -> st @@ -381,6 +382,8 @@ struct if M.tracing then M.tracel "combine" "relation f: %a\n" CilType.Varinfo.pretty f.svar; if M.tracing then M.tracel "combine" "relation formals: %a\n" (d_list "," CilType.Varinfo.pretty) f.sformals; if M.tracing then M.tracel "combine" "relation args: %a\n" (d_list "," d_exp) args; + if M.tracing then M.tracel "combine" "relation st: %a\n" D.pretty st; + if M.tracing then M.tracel "combine" "relation fun_st: %a\n" D.pretty fun_st; let new_fun_rel = RD.add_vars fun_st.rel (RD.vars st.rel) in let arg_substitutes = let filter_actuals (x,e) = From 190dd1fac2ac20551271bd4d212c1c38b542a121 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 26 Jan 2024 13:29:34 +0200 Subject: [PATCH 496/517] Rename log.* functions to c_log.* --- src/analyses/base.ml | 8 +-- src/analyses/baseInvariant.ml | 2 +- src/cdomain/value/cdomains/intDomain.ml | 90 ++++++++++++------------ src/cdomain/value/cdomains/intDomain.mli | 12 ++-- src/common/util/intOps.ml | 20 +++--- src/domains/intDomainProperties.ml | 18 ++--- 6 files changed, 75 insertions(+), 75 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 440a1fcd96..caa718a616 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -174,7 +174,7 @@ struct let unop_ID = function | Neg -> ID.neg | BNot -> ID.bitnot - | LNot -> ID.lognot + | LNot -> ID.c_lognot let unop_FD = function | Neg -> FD.neg @@ -217,8 +217,8 @@ struct | BXor -> ID.bitxor | Shiftlt -> ID.shift_left | Shiftrt -> ID.shift_right - | LAnd -> ID.logand - | LOr -> ID.logor + | LAnd -> ID.c_logand + | LOr -> ID.c_logor | b -> (fun x y -> (ID.top_of result_ik)) let binop_FD (result_fk: Cil.fkind) = function @@ -2436,7 +2436,7 @@ struct | Isgreaterequal (x,y) -> Int(ID.cast_to IInt (apply_binary FDouble FD.ge x y)) | Isless (x,y) -> Int(ID.cast_to IInt (apply_binary FDouble FD.lt x y)) | Islessequal (x,y) -> Int(ID.cast_to IInt (apply_binary FDouble FD.le x y)) - | Islessgreater (x,y) -> Int(ID.logor (ID.cast_to IInt (apply_binary FDouble FD.lt x y)) (ID.cast_to IInt (apply_binary FDouble FD.gt x y))) + | Islessgreater (x,y) -> Int(ID.c_logor (ID.cast_to IInt (apply_binary FDouble FD.lt x y)) (ID.cast_to IInt (apply_binary FDouble FD.gt x y))) | Isunordered (x,y) -> Int(ID.cast_to IInt (apply_binary FDouble FD.unordered x y)) | Fmax (fd, x ,y) -> Float (apply_binary fd FD.fmax x y) | Fmin (fd, x ,y) -> Float (apply_binary fd FD.fmin x y) diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index efd098d994..6634b3f21c 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -44,7 +44,7 @@ struct let unop_ID = function | Neg -> ID.neg | BNot -> ID.bitnot - | LNot -> ID.lognot + | LNot -> ID.c_lognot let unop_FD = function | Neg -> FD.neg diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index 46c43f44dd..e192e1341a 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -122,9 +122,9 @@ sig val shift_left : t -> t -> t val shift_right: t -> t -> t - val lognot: t -> t - val logand: t -> t -> t - val logor : t -> t -> t + val c_lognot: t -> t + val c_logand: t -> t -> t + val c_logor : t -> t -> t end @@ -153,9 +153,9 @@ sig val shift_left : Cil.ikind -> t -> t -> t val shift_right: Cil.ikind -> t -> t -> t - val lognot: Cil.ikind -> t -> t - val logand: Cil.ikind -> t -> t -> t - val logor : Cil.ikind -> t -> t -> t + val c_lognot: Cil.ikind -> t -> t + val c_logand: Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t end @@ -359,9 +359,9 @@ struct let bitxor = lift2 I.bitxor let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) - let lognot = lift_logical I.lognot - let logand = lift2 I.logand - let logor = lift2 I.logor + let c_lognot = lift_logical I.c_lognot + let c_logand = lift2 I.c_logand + let c_logor = lift2 I.c_logor let cast_to ?torg ikind x = {v = I.cast_to ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} @@ -703,8 +703,8 @@ struct | Some x, Some y -> of_bool ik (f x y) | _ -> top_of ik - let logor = log (||) ~annihilator:true - let logand = log (&&) ~annihilator:false + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false let log1 f ik i1 = if is_bot i1 then @@ -714,7 +714,7 @@ struct | Some x -> of_bool ik (f ik x) | _ -> top_of ik - let lognot = log1 (fun _ik -> not) + let c_lognot = log1 (fun _ik -> not) let bit f ik i1 i2 = match is_bot i1, is_bot i2 with @@ -1298,7 +1298,7 @@ struct let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in binary_op_with_ovc x y interval_shiftright - let lognot ik x = + let c_lognot ik x = let log1 f ik i1 = match interval_to_bool i1 with | Some x -> of_bool ik (f x) @@ -1307,11 +1307,11 @@ struct let interval_lognot = log1 not ik in unop x interval_lognot - let logand ik x y = + let c_logand ik x y = let interval_logand = log (&&) ik in binop x y interval_logand - let logor ik x y = + let c_logor ik x y = let interval_logor = log (||) ik in binop x y interval_logor @@ -1597,9 +1597,9 @@ struct let bitxor = Ints_t.bitxor let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) - let lognot n1 = of_bool (not (to_bool' n1)) - 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 c_lognot n1 = of_bool (not (to_bool' n1)) + let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) + let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) let cast_to ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) let invariant _ _ = Invariant.none (* TODO *) @@ -1688,9 +1688,9 @@ struct let bitxor = lift2 Base.bitxor let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor let invariant e = function | `Lifted x -> Base.invariant e x @@ -1755,9 +1755,9 @@ struct let bitxor = lift2 Base.bitxor let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor let invariant e = function | `Lifted x -> Base.invariant e x @@ -2246,21 +2246,21 @@ struct let shift_right = shift Z.shift_right (* TODO: lift does not treat Not {0} as true. *) - let logand ik x y = + let c_logand ik x y = match to_bool x, to_bool y with | Some false, _ | _, Some false -> of_bool ik false | _, _ -> - lift2 IntOps.BigIntOps.logand ik x y - let logor ik x y = + lift2 IntOps.BigIntOps.c_logand ik x y + let c_logor ik x y = match to_bool x, to_bool y with | Some true, _ | _, Some true -> of_bool ik true | _, _ -> - lift2 IntOps.BigIntOps.logor ik x y - let lognot ik = eq ik (of_int ik Z.zero) + lift2 IntOps.BigIntOps.c_logor ik x y + let c_lognot ik = eq ik (of_int ik Z.zero) let invariant_ikind e ik (x:t) = match x with @@ -2366,9 +2366,9 @@ struct let bitxor x y = x && not y || not x && y let shift_left n1 n2 = n1 let shift_right n1 n2 = n1 - let lognot = (not) - let logand = (&&) - let logor = (||) + let c_lognot = (not) + let c_logand = (&&) + let c_logor = (||) let arbitrary () = QCheck.bool let invariant _ _ = Invariant.none (* TODO *) end @@ -2617,7 +2617,7 @@ module Enums : S with type int_t = Z.t = struct let starting ?(suppress_ovwarn=false) ikind x = top_of ikind let ending ?(suppress_ovwarn=false) ikind x = top_of ikind - let lognot ik x = + let c_lognot ik x = if is_bot x then x else @@ -2625,8 +2625,8 @@ module Enums : S with type int_t = Z.t = struct | Some b -> of_bool ik (not b) | None -> top_bool - let logand = lift2 IntOps.BigIntOps.logand - let logor = lift2 IntOps.BigIntOps.logor + let c_logand = lift2 IntOps.BigIntOps.c_logand + let c_logor = lift2 IntOps.BigIntOps.c_logor let maximal = function | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) | Exc (excl,r) -> @@ -2680,7 +2680,7 @@ module Enums : S with type int_t = Z.t = struct else top_bool) - let ne ik x y = lognot ik (eq ik x y) + let ne ik x y = c_lognot ik (eq ik x y) let invariant_ikind e ik x = match x with @@ -2929,8 +2929,8 @@ struct | Some x, Some y -> of_bool ik (f x y) | _ -> top_of ik - let logor = log (||) - let logand = log (&&) + let c_logor = log (||) + let c_logand = log (&&) let log1 f ik i1 = if is_bot i1 then @@ -2940,7 +2940,7 @@ struct | Some x -> of_bool ik (f ik x) | _ -> top_of ik - let lognot = log1 (fun _ik -> not) + let c_lognot = log1 (fun _ik -> not) let shift_right _ _ _ = top() @@ -3563,8 +3563,8 @@ module IntDomTupleImpl = struct let bitnot ik = map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.bitnot ik)} - let lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} + let c_lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} let cast_to ?torg ?no_ov t = mapovc ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} @@ -3689,11 +3689,11 @@ module IntDomTupleImpl = struct let shift_right ik = map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} - let logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} + let c_logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} - let logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} + let c_logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} (* printing boilerplate *) diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 35ebc03794..ebbf8ceaf3 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -77,13 +77,13 @@ sig (** {b Logical operators} *) - val lognot: t -> t + val c_lognot: t -> t (** Logical not: [!x] *) - val logand: t -> t -> t + val c_logand: t -> t -> t (** Logical and: [x && y] *) - val logor : t -> t -> t + val c_logor : t -> t -> t (** Logical or: [x || y] *) end @@ -156,13 +156,13 @@ sig (** {b Logical operators} *) - val lognot: Cil.ikind -> t -> t + val c_lognot: Cil.ikind -> t -> t (** Logical not: [!x] *) - val logand: Cil.ikind -> t -> t -> t + val c_logand: Cil.ikind -> t -> t -> t (** Logical and: [x && y] *) - val logor : Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t (** Logical or: [x || y] *) end diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index a14305b0c2..17df714a82 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -62,12 +62,12 @@ end module type IntOps = sig include IntOpsBase - (* Logical: These are intended to be the logical operations in the C sense! *) - (* Int64 calls its bit-wise operations e.g. logand, we call those e.g. bitand *) - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val lognot : t -> t + (* Logical: These are intended to be the logical operations in the C sense! *) + (* Int64 calls its bit-wise operations e.g. logand, without the c_ prefix *) + val c_logand : t -> t -> t + val c_logor : t -> t -> t + val c_logxor : t -> t -> t + val c_lognot : t -> t val to_bool : t -> bool val of_bool : bool -> t end @@ -281,10 +281,10 @@ struct (* These are logical operations in the C sense! *) let log_op op a b = of_bool @@ op (to_bool a) (to_bool b) - let lognot x = of_bool (x = zero) - let logand = log_op (&&) - let logor = log_op (||) - let logxor = log_op (<>) + let c_lognot x = of_bool (x = zero) + let c_logand = log_op (&&) + let c_logor = log_op (||) + let c_logxor = log_op (<>) let lt x y = of_bool (compare x y < 0) let gt x y = of_bool (compare x y > 0) diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index e18ce65554..fcff746936 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -51,9 +51,9 @@ struct let bitxor = bitxor (Ik.ikind ()) let shift_left = shift_left (Ik.ikind ()) let shift_right = shift_right (Ik.ikind ()) - let lognot = lognot (Ik.ikind ()) - let logand = logand (Ik.ikind ()) - let logor = logor (Ik.ikind ()) + let c_lognot = c_lognot (Ik.ikind ()) + let c_logand = c_logand (Ik.ikind ()) + let c_logor = c_logor (Ik.ikind ()) let of_int = of_int (Ik.ikind ()) let of_bool = of_bool (Ik.ikind ()) @@ -104,9 +104,9 @@ struct let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor end @@ -145,9 +145,9 @@ struct let valid_shift_left = make_valid2 ~name:"shift_left" ~cond:shift_cond CD.shift_left AD.shift_left let valid_shift_right = make_valid2 ~name:"shift_right" ~cond:shift_cond CD.shift_right AD.shift_right - let valid_lognot = make_valid1 ~name:"lognot" ~cond:not_bot CD.lognot AD.lognot - let valid_logand = make_valid2 ~name:"logand" ~cond:none_bot CD.logand AD.logand - let valid_logor = make_valid2 ~name:"logor" ~cond:none_bot CD.logor AD.logor + let valid_lognot = make_valid1 ~name:"lognot" ~cond:not_bot CD.c_lognot AD.c_lognot + let valid_logand = make_valid2 ~name:"logand" ~cond:none_bot CD.c_logand AD.c_logand + let valid_logor = make_valid2 ~name:"logor" ~cond:none_bot CD.c_logor AD.c_logor let tests = [ valid_neg; From bdd61d1a2a2ef9c290e682a14db9109d71fa3419 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Fri, 26 Jan 2024 13:48:30 +0200 Subject: [PATCH 497/517] Rename bit.* functions to log.* --- src/analyses/base.ml | 8 +- src/analyses/baseInvariant.ml | 2 +- src/cdomain/value/cdomains/intDomain.ml | 132 +++++++++++------------ src/cdomain/value/cdomains/intDomain.mli | 16 +-- src/common/util/intOps.ml | 40 +++---- src/domains/intDomainProperties.ml | 32 +++--- unittest/cdomains/intDomainTest.ml | 12 +-- 7 files changed, 121 insertions(+), 121 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index caa718a616..b945f34f9d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -173,7 +173,7 @@ struct let unop_ID = function | Neg -> ID.neg - | BNot -> ID.bitnot + | BNot -> ID.lognot | LNot -> ID.c_lognot let unop_FD = function @@ -212,9 +212,9 @@ struct evalint: base eval_rv 1 -> (1,[1,1]) evalint: base query_evalint m == 1 -> (0,[1,1]) *) | Ne -> ID.ne - | BAnd -> ID.bitand - | BOr -> ID.bitor - | BXor -> ID.bitxor + | BAnd -> ID.logand + | BOr -> ID.logor + | BXor -> ID.logxor | Shiftlt -> ID.shift_left | Shiftrt -> ID.shift_right | LAnd -> ID.c_logand diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 6634b3f21c..003ac06b92 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -43,7 +43,7 @@ struct let unop_ID = function | Neg -> ID.neg - | BNot -> ID.bitnot + | BNot -> ID.lognot | LNot -> ID.c_lognot let unop_FD = function diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e192e1341a..4372df13fe 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -114,10 +114,10 @@ sig val eq: t -> t -> t val ne: t -> t -> t - val bitnot: t -> t - val bitand: t -> t -> t - val bitor : t -> t -> t - val bitxor: t -> t -> t + val lognot: t -> t + val logand: t -> t -> t + val logor : t -> t -> t + val logxor: t -> t -> t val shift_left : t -> t -> t val shift_right: t -> t -> t @@ -145,10 +145,10 @@ sig val eq: Cil.ikind -> t -> t -> t val ne: Cil.ikind -> t -> t -> t - val bitnot: Cil.ikind -> t -> t - val bitand: Cil.ikind -> t -> t -> t - val bitor : Cil.ikind -> t -> t -> t - val bitxor: Cil.ikind -> t -> t -> t + val lognot: Cil.ikind -> t -> t + val logand: Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t val shift_left : Cil.ikind -> t -> t -> t val shift_right: Cil.ikind -> t -> t -> t @@ -353,10 +353,10 @@ struct let ge = lift2_cmp I.ge let eq = lift2_cmp I.eq let ne = lift2_cmp I.ne - let bitnot = lift I.bitnot - let bitand = lift2 I.bitand - let bitor = lift2 I.bitor - let bitxor = lift2 I.bitxor + let lognot = lift I.lognot + let logand = lift2 I.logand + let logor = lift2 I.logor + let logxor = lift2 I.logxor let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) let c_lognot = lift_logical I.c_lognot @@ -736,21 +736,21 @@ struct | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) | _ -> (top_of ik,{underflow=true; overflow=true}) - let bitxor = bit (fun _ik -> Ints_t.bitxor) + let logxor = bit (fun _ik -> Ints_t.logxor) - let bitand ik i1 i2 = + let logand ik i1 i2 = match is_bot i1, is_bot i2 with | true, true -> bot_of ik | true, _ | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) | _ -> match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.bitand x y) |> fst with Division_by_zero -> top_of ik) + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst | _ -> top_of ik - let bitor = bit (fun _ik -> Ints_t.bitor) + let logor = bit (fun _ik -> Ints_t.logor) let bit1 f ik i1 = if is_bot i1 then @@ -760,7 +760,7 @@ struct | Some x -> of_int ik (f ik x) |> fst | _ -> top_of ik - let bitnot = bit1 (fun _ik -> Ints_t.bitnot) + let lognot = bit1 (fun _ik -> Ints_t.lognot) let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) @@ -1270,25 +1270,25 @@ struct | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) | _, _ -> (top_of ik,{overflow=false; underflow=false}) - let bitand ik x y = - let interval_bitand = bit Ints_t.bitand ik in - binop x y interval_bitand + let logand ik x y = + let interval_logand = bit Ints_t.logand ik in + binop x y interval_logand - let bitor ik x y = - let interval_bitor = bit Ints_t.bitor ik in - binop x y interval_bitor + let logor ik x y = + let interval_logor = bit Ints_t.logor ik in + binop x y interval_logor - let bitxor ik x y = - let interval_bitxor = bit Ints_t.bitxor ik in - binop x y interval_bitxor + let logxor ik x y = + let interval_logxor = bit Ints_t.logxor ik in + binop x y interval_logxor - let bitnot ik x = - let interval_bitnot i = + let lognot ik x = + let interval_lognot i = match interval_to_int i with - | Some x -> of_int ik (Ints_t.bitnot x) |> fst + | Some x -> of_int ik (Ints_t.lognot x) |> fst | _ -> top_of ik in - unop x interval_bitnot + unop x interval_lognot let shift_left ik x y = let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in @@ -1591,10 +1591,10 @@ struct let ge n1 n2 = of_bool (n1 >= n2) let eq n1 n2 = of_bool (n1 = n2) let ne n1 n2 = of_bool (n1 <> n2) - let bitnot = Ints_t.bitnot - let bitand = Ints_t.bitand - let bitor = Ints_t.bitor - let bitxor = Ints_t.bitxor + let lognot = Ints_t.lognot + let logand = Ints_t.logand + let logor = Ints_t.logor + let logxor = Ints_t.logxor let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) let c_lognot n1 = of_bool (not (to_bool' n1)) @@ -1682,10 +1682,10 @@ struct let ge = lift2 Base.ge let eq = lift2 Base.eq let ne = lift2 Base.ne - let bitnot = lift1 Base.bitnot - let bitand = lift2 Base.bitand - let bitor = lift2 Base.bitor - let bitxor = lift2 Base.bitxor + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right let c_lognot = lift1 Base.c_lognot @@ -1749,10 +1749,10 @@ struct let ge = lift2 Base.ge let eq = lift2 Base.eq let ne = lift2 Base.ne - let bitnot = lift1 Base.bitnot - let bitand = lift2 Base.bitand - let bitor = lift2 Base.bitor - let bitxor = lift2 Base.bitxor + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right let c_lognot = lift1 Base.c_lognot @@ -2200,9 +2200,9 @@ struct let ge ik x y = le ik y x - let bitnot = lift1 Z.lognot + let lognot = lift1 Z.lognot - let bitand ik x y = norm ik (match x,y with + let logand ik x y = norm ik (match x,y with (* We don't bother with exclusion sets: *) | `Excluded _, `Definite i -> (* Except in two special cases *) @@ -2223,8 +2223,8 @@ struct raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - let bitor = lift2 Z.logor - let bitxor = lift2 Z.logxor + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = (* BigInt only accepts int as second argument for shifts; perform conversion here *) @@ -2360,10 +2360,10 @@ struct let ge n1 n2 = true let eq n1 n2 = true let ne n1 n2 = true - let bitnot x = true - let bitand x y = x && y - let bitor x y = x || y - let bitxor x y = x && not y || not x && y + let lognot x = true + let logand x y = x && y + let logor x y = x || y + let logxor x y = x && not y || not x && y let shift_left n1 n2 = n1 let shift_right n1 n2 = n1 let c_lognot = (not) @@ -2570,10 +2570,10 @@ module Enums : S with type int_t = Z.t = struct let rem = lift2 Z.rem - let bitnot = lift1 Z.lognot - let bitand = lift2 Z.logand - let bitor = lift2 Z.logor - let bitxor = lift2 Z.logxor + let lognot = lift1 Z.lognot + let logand = lift2 Z.logand + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = handle_bot x y (fun () -> @@ -3061,7 +3061,7 @@ struct pretty res ; res - let bitnot ik x = match x with + let lognot ik x = match x with | None -> None | Some (c, m) -> if (Cil.isSigned ik) then @@ -3080,9 +3080,9 @@ struct if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) else top () - let bitor ik x y = bit2 Z.logor ik x y + let logor ik x y = bit2 Z.logor ik x y - let bitand ik x y = match x, y with + let logand ik x y = match x, y with | None, None -> None | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) | Some (c, m), Some (c', m') -> @@ -3096,7 +3096,7 @@ struct else top () - let bitxor ik x y = bit2 Z.logxor ik x y + let logxor ik x y = bit2 Z.logxor ik x y let rem ik x y = match x, y with @@ -3560,8 +3560,8 @@ module IntDomTupleImpl = struct let neg ?no_ov ik = mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} - let bitnot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.bitnot ik)} + let lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} let c_lognot ik = map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} @@ -3674,14 +3674,14 @@ module IntDomTupleImpl = struct let ne ik = map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} - let bitand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.bitand ik)} + let logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} - let bitor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.bitor ik)} + let logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} - let bitxor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.bitxor ik)} + let logxor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} let shift_left ik = map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index ebbf8ceaf3..64295bd440 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -56,16 +56,16 @@ sig (** {b Bit operators} *) - val bitnot: t -> t + val lognot: t -> t (** Bitwise not (one's complement): [~x] *) - val bitand: t -> t -> t + val logand: t -> t -> t (** Bitwise and: [x & y] *) - val bitor : t -> t -> t + val logor : t -> t -> t (** Bitwise or: [x | y] *) - val bitxor: t -> t -> t + val logxor: t -> t -> t (** Bitwise exclusive or: [x ^ y] *) val shift_left : t -> t -> t @@ -135,16 +135,16 @@ sig (** {b Bit operators} *) - val bitnot: Cil.ikind -> t -> t + val lognot: Cil.ikind -> t -> t (** Bitwise not (one's complement): [~x] *) - val bitand: Cil.ikind -> t -> t -> t + val logand: Cil.ikind -> t -> t -> t (** Bitwise and: [x & y] *) - val bitor : Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t (** Bitwise or: [x | y] *) - val bitxor: Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t (** Bitwise exclusive or: [x ^ y] *) val shift_left : Cil.ikind -> t -> t -> t diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index 17df714a82..5b33751d96 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -33,10 +33,10 @@ sig (* Bitwise *) val shift_left : t -> int -> t val shift_right : t -> int -> t - val bitand : t -> t -> t - val bitor : t -> t -> t - val bitxor : t -> t -> t - val bitnot : t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val lognot : t -> t (* Comparison *) val compare : t -> t -> int @@ -97,10 +97,10 @@ struct let shift_left = (lsl) let shift_right = (lsr) - let bitand = (land) - let bitor = (lor) - let bitxor = (lxor) - let bitnot = (lnot) + let logand = (land) + let logor = (lor) + let logxor = (lxor) + let lognot = (lnot) let compare = compare @@ -143,11 +143,11 @@ struct let shift_left = Int32.shift_left let shift_right = Int32.shift_right_logical - let bitand = Int32.logand (* Int32 calls bitwise operations 'log' *) - let bitor = Int32.logor (* Int32 calls bitwise operations 'log' *) - let bitxor = Int32.logxor (* Int32 calls bitwise operations 'log' *) + let logand = Int32.logand (* Int32 calls bitwise operations 'log' *) + let logor = Int32.logor (* Int32 calls bitwise operations 'log' *) + let logxor = Int32.logxor (* Int32 calls bitwise operations 'log' *) - let bitnot = Int32.lognot (* Int32 calls bitwise operations 'log' *) + let lognot = Int32.lognot (* Int32 calls bitwise operations 'log' *) let compare = Int32.compare let equal = Int32.equal @@ -191,11 +191,11 @@ struct let shift_left = Int64.shift_left let shift_right = Int64.shift_right_logical - let bitand = Int64.logand (* Int64 calls bitwise operations 'log' *) - let bitor = Int64.logor (* Int64 calls bitwise operations 'log' *) - let bitxor = Int64.logxor (* Int64 calls bitwise operations 'log' *) + let logand = Int64.logand (* Int64 calls bitwise operations 'log' *) + let logor = Int64.logor (* Int64 calls bitwise operations 'log' *) + let logxor = Int64.logxor (* Int64 calls bitwise operations 'log' *) - let bitnot = Int64.lognot (* Int64 calls bitwise operations 'log' *) + let lognot = Int64.lognot (* Int64 calls bitwise operations 'log' *) let compare = Int64.compare let equal = Int64.equal @@ -255,10 +255,10 @@ struct let shift_left = Z.shift_left let shift_right = Z.shift_right - let bitnot = Z.lognot - let bitand = Z.logand - let bitor = Z.logor - let bitxor = Z.logxor + let lognot = Z.lognot + let logand = Z.logand + let logor = Z.logor + let logxor = Z.logxor let arbitrary () = QCheck.map ~rev:Z.to_int64 Z.of_int64 QCheck.int64 end diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index fcff746936..8757a16c0d 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -45,10 +45,10 @@ struct let ge = ge (Ik.ikind ()) let eq = eq (Ik.ikind ()) let ne = ne (Ik.ikind ()) - let bitnot = bitnot (Ik.ikind ()) - let bitand = bitand (Ik.ikind ()) - let bitor = bitor (Ik.ikind ()) - let bitxor = bitxor (Ik.ikind ()) + let lognot = lognot (Ik.ikind ()) + let logand = logand (Ik.ikind ()) + let logor = logor (Ik.ikind ()) + let logxor = logxor (Ik.ikind ()) let shift_left = shift_left (Ik.ikind ()) let shift_right = shift_right (Ik.ikind ()) let c_lognot = c_lognot (Ik.ikind ()) @@ -97,10 +97,10 @@ struct let eq = lift2 Base.eq let ne = lift2 Base.ne - let bitnot = lift1 Base.bitnot - let bitand = lift2 Base.bitand - let bitor = lift2 Base.bitor - let bitxor = lift2 Base.bitxor + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor let shift_left = lift2 Base.shift_left let shift_right = lift2 Base.shift_right @@ -133,10 +133,10 @@ struct let valid_eq = make_valid2 ~name:"eq" ~cond:none_bot CD.eq AD.eq let valid_ne = make_valid2 ~name:"ne" ~cond:none_bot CD.ne AD.ne - let valid_bitnot = make_valid1 ~name:"bitnot" ~cond:not_bot CD.bitnot AD.bitnot - let valid_bitand = make_valid2 ~name:"bitand" ~cond:none_bot CD.bitand AD.bitand - let valid_bitor = make_valid2 ~name:"bitor" ~cond:none_bot CD.bitor AD.bitor - let valid_bitxor = make_valid2 ~name:"bitxor" ~cond:none_bot CD.bitxor AD.bitxor + let valid_lognot = make_valid1 ~name:"lognot" ~cond:not_bot CD.lognot AD.lognot + let valid_logand = make_valid2 ~name:"logand" ~cond:none_bot CD.logand AD.logand + let valid_logor = make_valid2 ~name:"logor" ~cond:none_bot CD.logor AD.logor + let valid_logxor = make_valid2 ~name:"logxor" ~cond:none_bot CD.logxor AD.logxor let defined_shift (a, b) = let max_shift = Z.of_int @@ snd @@ IntDomain.Size.bits (AD.Ikind.ikind ()) in @@ -164,10 +164,10 @@ struct valid_eq; valid_ne; - valid_bitnot; - valid_bitand; - valid_bitor; - valid_bitxor; + valid_lognot; + valid_logand; + valid_logor; + valid_logxor; valid_shift_left; valid_shift_right; diff --git a/unittest/cdomains/intDomainTest.ml b/unittest/cdomains/intDomainTest.ml index 7caf98a861..dfa8f88d63 100644 --- a/unittest/cdomains/intDomainTest.ml +++ b/unittest/cdomains/intDomainTest.ml @@ -82,12 +82,12 @@ struct let test_bit _ = - assert_equal ~printer:I.show iminus_one (I.bitnot izero); - assert_equal ~printer:I.show iminus_two (I.bitnot ione); - assert_equal ~printer:I.show i5 (I.bitand i5 i5); - assert_equal ~printer:I.show i4 (I.bitand i5 i4); - assert_equal ~printer:I.show i5 (I.bitor i4 ione); - assert_equal ~printer:I.show ione (I.bitxor i4 i5); + assert_equal ~printer:I.show iminus_one (I.lognot izero); + assert_equal ~printer:I.show iminus_two (I.lognot ione); + assert_equal ~printer:I.show i5 (I.logand i5 i5); + assert_equal ~printer:I.show i4 (I.logand i5 i4); + assert_equal ~printer:I.show i5 (I.logor i4 ione); + assert_equal ~printer:I.show ione (I.logxor i4 i5); assert_equal ~printer:I.show itwo (I.shift_left ione ione ); assert_equal ~printer:I.show ione (I.shift_left ione izero); assert_equal ~printer:I.show ione (I.shift_right itwo ione); From 29b951d6c8efb88c7172b3060b6e9a7ff0a8234a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 26 Jan 2024 14:33:25 +0100 Subject: [PATCH 498/517] Remark that OS X needs `ggrep` --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4d97baa842..c9addbf7b2 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ For benchmarking Goblint, please follow the [Benchmarking guide on Read the Docs 6. _Optional:_ See [`scripts/bash-completion.sh`](./scripts/bash-completion.sh) for setting up bash completion for Goblint arguments. ### MacOS -1. Install GCC with `brew install gcc` (first run `xcode-select --install` if you don't want to build it from source). Goblint requires GCC while macOS's default `cpp` is Clang, which will not work. +1. Install GCC with `brew install gcc ggrep` (first run `xcode-select --install` if you don't want to build it from source). Goblint requires GCC while macOS's default `cpp` is Clang, which will not work. 2. ONLY for M1 (ARM64) processor: homebrew changed its install location from `/usr/local/` to `/opt/homebrew/`. For packages to find their dependecies execute `sudo ln -s /opt/homebrew/{include,lib} /usr/local/`. 3. Continue using Linux instructions (the formulae in brew for `patch`, `libgmp-dev`, `libmpfr-dev` are `gpatch`, `gmp`, `mpfr`, respectively). From 639258348d4d8b7207944c3c5049e387126d3c58 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Fri, 26 Jan 2024 14:34:15 +0100 Subject: [PATCH 499/517] OS X: Formula is `grep` for `ggrep` --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index c9addbf7b2..090d354203 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ For benchmarking Goblint, please follow the [Benchmarking guide on Read the Docs 6. _Optional:_ See [`scripts/bash-completion.sh`](./scripts/bash-completion.sh) for setting up bash completion for Goblint arguments. ### MacOS -1. Install GCC with `brew install gcc ggrep` (first run `xcode-select --install` if you don't want to build it from source). Goblint requires GCC while macOS's default `cpp` is Clang, which will not work. +1. Install GCC with `brew install gcc grep` (first run `xcode-select --install` if you don't want to build it from source). Goblint requires GCC while macOS's default `cpp` is Clang, which will not work. 2. ONLY for M1 (ARM64) processor: homebrew changed its install location from `/usr/local/` to `/opt/homebrew/`. For packages to find their dependecies execute `sudo ln -s /opt/homebrew/{include,lib} /usr/local/`. 3. Continue using Linux instructions (the formulae in brew for `patch`, `libgmp-dev`, `libmpfr-dev` are `gpatch`, `gmp`, `mpfr`, respectively). From 6400e574e118cb5f33246d117eac4a85c83fb62b Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 12:03:28 +0100 Subject: [PATCH 500/517] Float domain: Fix eval_comparison_binop --- src/cdomain/value/cdomains/floatDomain.ml | 32 ++++++++++++++++------- tests/regression/57-floats/05-invariant.c | 16 ++++++++++++ 2 files changed, 38 insertions(+), 10 deletions(-) diff --git a/src/cdomain/value/cdomains/floatDomain.ml b/src/cdomain/value/cdomains/floatDomain.ml index e3787541bd..c22b6dfa4d 100644 --- a/src/cdomain/value/cdomains/floatDomain.ml +++ b/src/cdomain/value/cdomains/floatDomain.ml @@ -348,24 +348,36 @@ module FloatIntervalImpl(Float_t : CFloatType) = struct | _ -> ()); result - let eval_comparison_binop min max sym eval_operation (op1: t) op2 = + let eval_comparison_binop min max reflexive eval_operation (op1: t) op2 = warn_on_specials_comparison op1 op2; let a, b = match (op1, op2) with | Bot, _ | _, Bot -> raise (ArithmeticOnFloatBot (Printf.sprintf "%s op %s" (show op1) (show op2))) | Interval v1, Interval v2 -> eval_operation v1 v2 - | NaN, NaN -> (0,0) - | NaN, _ | _, NaN -> (0,0) - | Top, _ | _, Top -> (0,1) (*neither of the arguments is Top/Bot/NaN*) - | v1, v2 when v1 = min -> if v2 <> min || sym then (1,1) else (0,0) - | _, v2 when v2 = min -> (0,0) (* first argument cannot be min *) - | v1, v2 when v1 = max -> if v2 <> max || sym then (0,0) else (0,0) + | NaN, _ | _, NaN -> (0,0) (* comparisons involving NaN always return false *) + | Top, _ | _, Top -> (0,1) (* comparisons with Top yield top *) + (* neither of the arguments below is Top/Bot/NaN *) + | v1, v2 when v1 = min -> + (* v1 is the minimal element w.r.t. the order *) + if v2 <> min || reflexive then + (* v2 is different, i.e., greater or the relation is reflexive *) + (1,1) + else + (0,0) + | _, v2 when v2 = min -> + (* second argument is minimal, first argument cannot be *) + (0,0) + | v1, v2 when v1 = max -> + (* v1 is maximal element w.r.t. the order *) + if v2 = max && reflexive then + (* v2 is also maximal and the relation is reflexive *) + (1,1) + else + (0,0) | _, v2 when v2 = max -> (1,1) (* first argument cannot be max *) | _ -> (0, 1) in - IntDomain.IntDomTuple.of_interval IBool - (Z.of_int a, Z.of_int b) - + IntDomain.IntDomTuple.of_interval IBool (Z.of_int a, Z.of_int b) let eval_neg = function | (low, high) -> Interval (Float_t.neg high, Float_t.neg low) diff --git a/tests/regression/57-floats/05-invariant.c b/tests/regression/57-floats/05-invariant.c index d38a882eab..d7ae4114c5 100644 --- a/tests/regression/57-floats/05-invariant.c +++ b/tests/regression/57-floats/05-invariant.c @@ -1,6 +1,7 @@ // PARAM: --enable ana.float.interval --enable ana.int.interval #include #include +#include int main() { @@ -119,5 +120,20 @@ int main() } } + float max = INFINITY; + float min = -INFINITY; + + int res = max <= max; + __goblint_check(res); + + res = max <= min; + __goblint_check(res == 0); + + res = max < max; + __goblint_check(res == 0); + + res = max > max; + __goblint_check(res == 0); + return 0; } From d55b0e00d7fff8cea01be495270edd216377f864 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 22:59:14 +0100 Subject: [PATCH 501/517] Apron: Only replace deref expression with pointed to variable if types coincide --- src/analyses/apron/relationAnalysis.apron.ml | 17 ++++++++--- tests/regression/46-apron2/59-issue-1319.c | 30 ++++++++++++++++++++ 2 files changed, 43 insertions(+), 4 deletions(-) create mode 100644 tests/regression/46-apron2/59-issue-1319.c diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index c9f8cd750a..c1f3c927c5 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -218,10 +218,19 @@ struct | Lval (Mem e, NoOffset) -> begin match ask (Queries.MayPointTo e) with | ad when not (Queries.AD.is_top ad) && (Queries.AD.cardinal ad) = 1 -> - begin match Queries.AD.Addr.to_mval (Queries.AD.choose ad) with - | Some mval -> ValueDomain.Addr.Mval.to_cil_exp mval - | None -> Lval (Mem e, NoOffset) - end + let replace mval = + let pointee = ValueDomain.Addr.Mval.to_cil_exp mval in + let pointee_typ = Cil.typeSig @@ Cil.typeOf pointee in + let lval_typ = Cil.typeSig @@ Cil.typeOfLval (Mem e, NoOffset) in + if pointee_typ = lval_typ then + Some pointee + else + (* there is a type-mismatch between pointee and pointer-type *) + (* to avoid mismatch errors, we bail on this expression *) + None + in + let r = Option.bind (Queries.AD.Addr.to_mval (Queries.AD.choose ad)) replace in + Option.default (Lval (Mem e, NoOffset)) r (* It would be possible to do better here, exploiting e.g. that the things pointed to are known to be equal *) (* see: https://github.com/goblint/analyzer/pull/742#discussion_r879099745 *) | _ -> Lval (Mem e, NoOffset) diff --git a/tests/regression/46-apron2/59-issue-1319.c b/tests/regression/46-apron2/59-issue-1319.c new file mode 100644 index 0000000000..ae3ff69b58 --- /dev/null +++ b/tests/regression/46-apron2/59-issue-1319.c @@ -0,0 +1,30 @@ +// SKIP PARAM: --enable ana.int.def_exc --enable ana.int.interval --set ana.activated[+] apron +#include + +int main() +{ + unsigned char *t; + char c = 'b'; + + t = &c; + + // Type of *t and c do not match, this caused a crash before + if(*t == 'a') { + t++; + } + + other(); +} + +int other() +{ + // Same problem, but a bit more involved + unsigned char *t; + char buf[100] = "bliblablubapk\r"; + + t = buf; + + if(*t == 'a') { + t++; + } +} \ No newline at end of file From ba0233f87d0aab77bcbbefcefd2a1678fb5edf5a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 23:03:39 +0100 Subject: [PATCH 502/517] Use Cilfacade --- 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 c1f3c927c5..9df2360482 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -220,8 +220,8 @@ struct | ad when not (Queries.AD.is_top ad) && (Queries.AD.cardinal ad) = 1 -> let replace mval = let pointee = ValueDomain.Addr.Mval.to_cil_exp mval in - let pointee_typ = Cil.typeSig @@ Cil.typeOf pointee in - let lval_typ = Cil.typeSig @@ Cil.typeOfLval (Mem e, NoOffset) in + let pointee_typ = Cil.typeSig @@ Cilfacade.typeOf pointee in + let lval_typ = Cil.typeSig @@ Cilfacade.typeOfLval (Mem e, NoOffset) in if pointee_typ = lval_typ then Some pointee else From 880d59f91c2d47d7d6337d4edb7c0a314c753dca Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 23:36:50 +0100 Subject: [PATCH 503/517] Refine Points-To set on locking a mutex --- src/analyses/base.ml | 5 +++++ src/analyses/mutexEventsAnalysis.ml | 4 ++-- src/domains/events.ml | 5 ++++- tests/regression/79-mutex2/01-split.c | 20 ++++++++++++++++++++ 4 files changed, 31 insertions(+), 3 deletions(-) create mode 100644 tests/regression/79-mutex2/01-split.c diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 42e43b623a..c20fb71447 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2929,6 +2929,11 @@ struct {st' with cpa = CPA.remove !longjmp_return st'.cpa} | None -> ctx.local end + | Events.RefinePointerExp {exp; ad} -> + (match exp with + | Lval lval -> + set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOf exp) (Address ad) + | _ -> ctx.local) | _ -> ctx.local end diff --git a/src/analyses/mutexEventsAnalysis.ml b/src/analyses/mutexEventsAnalysis.ml index 162527b32b..84190e6df4 100644 --- a/src/analyses/mutexEventsAnalysis.ml +++ b/src/analyses/mutexEventsAnalysis.ml @@ -24,7 +24,7 @@ struct match lv_opt with | None -> Queries.AD.iter (fun e -> - ctx.split () [Events.Lock (e, rw)] + ctx.split () [Events.Lock (e, rw); Events.RefinePointerExp {exp = arg; ad = Queries.AD.singleton e}] ) (eval_exp_addr a arg); if may_fail then ctx.split () []; @@ -32,7 +32,7 @@ struct | Some lv -> let sb = Events.SplitBranch (Lval lv, nonzero_return_when_aquired) in Queries.AD.iter (fun e -> - ctx.split () [sb; Events.Lock (e, rw)]; + ctx.split () [sb; Events.Lock (e, rw); Events.RefinePointerExp {exp = arg; ad = Queries.AD.singleton e}]; ) (eval_exp_addr a arg); if may_fail then ( let fail_exp = if nonzero_return_when_aquired then Lval lv else BinOp(Gt, Lval lv, zero, intType) in diff --git a/src/domains/events.ml b/src/domains/events.ml index 06561bddbe..78fedeafa2 100644 --- a/src/domains/events.ml +++ b/src/domains/events.ml @@ -16,6 +16,7 @@ type t = | Assert of exp | Unassume of {exp: CilType.Exp.t; uuids: string list} | Longjmped of {lval: CilType.Lval.t option} + | RefinePointerExp of {exp: CilType.Exp.t; ad: ValueDomain.AD.t} (** Should event be emitted after transfer function raises [Deadcode]? *) let emit_on_deadcode = function @@ -31,7 +32,8 @@ let emit_on_deadcode = function | UpdateExpSplit _ (* Pointless to split on dead. *) | Unassume _ (* Avoid spurious writes. *) | Assert _ (* Pointless to refine dead. *) - | Longjmped _ -> + | Longjmped _ + | RefinePointerExp _ -> false let pretty () = function @@ -47,3 +49,4 @@ let pretty () = function | Assert exp -> dprintf "Assert %a" d_exp exp | Unassume {exp; uuids} -> dprintf "Unassume {exp=%a; uuids=%a}" d_exp exp (docList Pretty.text) uuids | Longjmped {lval} -> dprintf "Longjmped {lval=%a}" (docOpt (CilType.Lval.pretty ())) lval + | RefinePointerExp {exp; ad} -> dprintf "RefinePointerExp {exp=%a; ad=%a}" CilType.Exp.pretty exp ValueDomain.AD.pretty ad \ No newline at end of file diff --git a/tests/regression/79-mutex2/01-split.c b/tests/regression/79-mutex2/01-split.c new file mode 100644 index 0000000000..0ca07f5b4d --- /dev/null +++ b/tests/regression/79-mutex2/01-split.c @@ -0,0 +1,20 @@ +#include + +pthread_mutex_t m1; +pthread_mutex_t m2; + +int main(int argc, char const *argv[]) +{ + int top; + pthread_mutex_t* ptr; + ptr = &m1; + + if(top) { + ptr = &m2; + } + + pthread_mutex_lock(ptr); + pthread_mutex_unlock(ptr); //NOWARN + + return 0; +} \ No newline at end of file From 036bbc6057efbab7cc40f93ae209a2a793a1012f Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 23:40:58 +0100 Subject: [PATCH 504/517] Indentation --- src/analyses/base.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index c20fb71447..fbd169d1ca 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2931,9 +2931,9 @@ struct end | Events.RefinePointerExp {exp; ad} -> (match exp with - | Lval lval -> - set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOf exp) (Address ad) - | _ -> ctx.local) + | Lval lval -> + set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOf exp) (Address ad) + | _ -> ctx.local) | _ -> ctx.local end From 55dacde527593460dafc4fd1c41ad1b9463edd9c Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sat, 27 Jan 2024 23:45:01 +0100 Subject: [PATCH 505/517] Add multithreaded example --- tests/regression/79-mutex2/02-split-mt.c | 37 ++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 tests/regression/79-mutex2/02-split-mt.c diff --git a/tests/regression/79-mutex2/02-split-mt.c b/tests/regression/79-mutex2/02-split-mt.c new file mode 100644 index 0000000000..9e397f9c2e --- /dev/null +++ b/tests/regression/79-mutex2/02-split-mt.c @@ -0,0 +1,37 @@ +#include + +pthread_mutex_t m1; +pthread_mutex_t m2; +pthread_mutex_t* ptr; + +void other() { + int top; + ptr = &m2; + + if(top) { + ptr = &m1; + } +} + +int main(int argc, char const *argv[]) +{ + int top; + + ptr = &m1; + + if(top) { + ptr = &m2; + } + + pthread_t mischievous; + pthread_create(&mischievous, NULL, other, NULL); + + + pthread_mutex_lock(ptr); + + // This has to produce a warning, as the other thread may have changed what + // ptr points to such that it's not the same mutex being unlocked here. + pthread_mutex_unlock(ptr); //WARN + + return 0; +} \ No newline at end of file From dfaa55babf015f0547468975240835bfea34f2a6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 28 Jan 2024 19:39:08 +0100 Subject: [PATCH 506/517] eval_rv_base: cast without torg when typeOf fails --- src/analyses/base.ml | 7 +++++-- tests/regression/46-apron2/60-issue-1338.c | 11 +++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 tests/regression/46-apron2/60-issue-1338.c diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 42e43b623a..5a214562b8 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -877,8 +877,11 @@ struct Address (AD.map array_start (eval_lv ~ctx st lval)) | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - let v = eval_rv ~ctx st exp in - VD.cast ~torg:(Cilfacade.typeOf exp) t v + (let v = eval_rv ~ctx st exp in + try + VD.cast ~torg:(Cilfacade.typeOf exp) t v + with Cilfacade.TypeOfError _ -> + VD.cast t v) | SizeOf _ | Real _ | Imag _ diff --git a/tests/regression/46-apron2/60-issue-1338.c b/tests/regression/46-apron2/60-issue-1338.c new file mode 100644 index 0000000000..899fe613b3 --- /dev/null +++ b/tests/regression/46-apron2/60-issue-1338.c @@ -0,0 +1,11 @@ +// SKIP PARAM: --set ana.activated[+] apron +#include +int main() +{ + char *ptr = malloc(2); + char s = *(ptr+0)+0; + + char *arr; + arr = malloc(8); + int tmp = (int)*(arr+0); +} \ No newline at end of file From 1bb8d43bdcd3b4228d1671facc1df204a56e556d Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Sun, 28 Jan 2024 19:39:52 +0100 Subject: [PATCH 507/517] Indent --- src/analyses/base.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 5a214562b8..b4f01d2188 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -878,10 +878,10 @@ struct | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~ctx st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> (let v = eval_rv ~ctx st exp in - try - VD.cast ~torg:(Cilfacade.typeOf exp) t v - with Cilfacade.TypeOfError _ -> - VD.cast t v) + try + VD.cast ~torg:(Cilfacade.typeOf exp) t v + with Cilfacade.TypeOfError _ -> + VD.cast t v) | SizeOf _ | Real _ | Imag _ From ae226c9e34929a640d360658fdc11ae7f12e55d3 Mon Sep 17 00:00:00 2001 From: Julian Erhard Date: Mon, 29 Jan 2024 10:41:59 +0100 Subject: [PATCH 508/517] Declare other() before calling it. --- tests/regression/46-apron2/59-issue-1319.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/regression/46-apron2/59-issue-1319.c b/tests/regression/46-apron2/59-issue-1319.c index ae3ff69b58..1c11d6093e 100644 --- a/tests/regression/46-apron2/59-issue-1319.c +++ b/tests/regression/46-apron2/59-issue-1319.c @@ -1,5 +1,5 @@ // SKIP PARAM: --enable ana.int.def_exc --enable ana.int.interval --set ana.activated[+] apron -#include +int other(); int main() { From 018166e8f3678b9cd136a6db48483de6c9bd7251 Mon Sep 17 00:00:00 2001 From: Karoliine Holter <44437975+karoliineh@users.noreply.github.com> Date: Mon, 29 Jan 2024 12:43:20 +0200 Subject: [PATCH 509/517] rename log* -> c_log* Co-authored-by: Simmo Saan --- src/domains/intDomainProperties.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index 8757a16c0d..2de416ff26 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -145,9 +145,9 @@ struct let valid_shift_left = make_valid2 ~name:"shift_left" ~cond:shift_cond CD.shift_left AD.shift_left let valid_shift_right = make_valid2 ~name:"shift_right" ~cond:shift_cond CD.shift_right AD.shift_right - let valid_lognot = make_valid1 ~name:"lognot" ~cond:not_bot CD.c_lognot AD.c_lognot - let valid_logand = make_valid2 ~name:"logand" ~cond:none_bot CD.c_logand AD.c_logand - let valid_logor = make_valid2 ~name:"logor" ~cond:none_bot CD.c_logor AD.c_logor + let valid_c_lognot = make_valid1 ~name:"c_lognot" ~cond:not_bot CD.c_lognot AD.c_lognot + let valid_c_logand = make_valid2 ~name:"c_logand" ~cond:none_bot CD.c_logand AD.c_logand + let valid_c_logor = make_valid2 ~name:"c_logor" ~cond:none_bot CD.c_logor AD.c_logor let tests = [ valid_neg; From 3d9997891633a710895868b5fa27ec41de0e72c2 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 29 Jan 2024 12:49:04 +0200 Subject: [PATCH 510/517] Rename valid_log* -> valid_c_log* in tests --- src/domains/intDomainProperties.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/domains/intDomainProperties.ml b/src/domains/intDomainProperties.ml index 2de416ff26..155be6f90a 100644 --- a/src/domains/intDomainProperties.ml +++ b/src/domains/intDomainProperties.ml @@ -171,9 +171,9 @@ struct valid_shift_left; valid_shift_right; - valid_lognot; - valid_logand; - valid_logor + valid_c_lognot; + valid_c_logand; + valid_c_logor ] end From 67320d479c521f27e27541997e01863985aa4e37 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 29 Jan 2024 13:00:05 +0200 Subject: [PATCH 511/517] Update and add comments about log* functions --- src/cdomain/value/cdomains/intDomain.mli | 10 +++++----- src/common/util/intOps.ml | 6 ++++++ 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/cdomain/value/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli index 64295bd440..632128ff72 100644 --- a/src/cdomain/value/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -54,19 +54,19 @@ sig (** Not equal to: [x != y] *) - (** {b Bit operators} *) + (** {b Bitwise logical operators} *) val lognot: t -> t - (** Bitwise not (one's complement): [~x] *) + (** Bitwise logical not (one's complement): [~x] *) val logand: t -> t -> t - (** Bitwise and: [x & y] *) + (** Bitwise logical and: [x & y] *) val logor : t -> t -> t - (** Bitwise or: [x | y] *) + (** Bitwise logical or: [x | y] *) val logxor: t -> t -> t - (** Bitwise exclusive or: [x ^ y] *) + (** Bitwise logical exclusive or: [x ^ y] *) val shift_left : t -> t -> t (** Shifting bits left: [x << y] *) diff --git a/src/common/util/intOps.ml b/src/common/util/intOps.ml index 5b33751d96..fa9a96f465 100644 --- a/src/common/util/intOps.ml +++ b/src/common/util/intOps.ml @@ -32,11 +32,17 @@ sig (* Bitwise *) val shift_left : t -> int -> t + (* shift_left x y shifts x to the left by y bits. *) val shift_right : t -> int -> t + (* shift_right x y shifts x to the right by y bits. *) val logand : t -> t -> t + (* Bitwise logical and. *) val logor : t -> t -> t + (* Bitwise logical or. *) val logxor : t -> t -> t + (* Bitwise logical exclusive or. *) val lognot : t -> t + (* Bitwise logical negation. *) (* Comparison *) val compare : t -> t -> int From 43033130c440418789c90a00eac9f9e0735067c8 Mon Sep 17 00:00:00 2001 From: Karoliine Holter Date: Mon, 29 Jan 2024 13:39:12 +0200 Subject: [PATCH 512/517] Fix AllocVar onstack=true for AllocA --- src/analyses/mallocFresh.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/analyses/mallocFresh.ml b/src/analyses/mallocFresh.ml index 138a208558..ca14de0a3c 100644 --- a/src/analyses/mallocFresh.ml +++ b/src/analyses/mallocFresh.ml @@ -39,15 +39,16 @@ struct let special ctx lval f args = let desc = LibraryFunctions.find f in + let alloc_var on_stack = + match ctx.ask (AllocVar {on_stack = on_stack}) with + | `Lifted var -> D.add var ctx.local + | _ -> ctx.local + in match desc.special args with | Malloc _ | Calloc _ - | Realloc _ - | Alloca _ -> - begin match ctx.ask (AllocVar {on_stack = false}) with - | `Lifted var -> D.add var ctx.local - | _ -> ctx.local - end + | Realloc _ -> alloc_var false + | Alloca _ -> alloc_var true | _ -> match lval with | None -> ctx.local From c27f1bd6d6138d0eb4afc8692b736da5a51eeeeb Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 29 Jan 2024 13:09:16 +0100 Subject: [PATCH 513/517] Get rid of custom event --- src/analyses/base.ml | 5 ----- src/analyses/mutexEventsAnalysis.ml | 10 ++++++++-- src/domains/events.ml | 5 +---- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index fbd169d1ca..42e43b623a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -2929,11 +2929,6 @@ struct {st' with cpa = CPA.remove !longjmp_return st'.cpa} | None -> ctx.local end - | Events.RefinePointerExp {exp; ad} -> - (match exp with - | Lval lval -> - set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOf exp) (Address ad) - | _ -> ctx.local) | _ -> ctx.local end diff --git a/src/analyses/mutexEventsAnalysis.ml b/src/analyses/mutexEventsAnalysis.ml index 84190e6df4..7f544b0ffd 100644 --- a/src/analyses/mutexEventsAnalysis.ml +++ b/src/analyses/mutexEventsAnalysis.ml @@ -21,10 +21,16 @@ struct let eval_exp_addr (a: Queries.ask) exp = a.f (Queries.MayPointTo exp) let lock ctx rw may_fail nonzero_return_when_aquired a lv_opt arg = + let compute_refine_split (e:Mutexes.elt) = match e with + | Addr a -> + let e' = BinOp(Eq, arg, AddrOf ((PreValueDomain.Mval.to_cil a)), intType) in + [Events.SplitBranch (e',true)] + | _ -> [] + in match lv_opt with | None -> Queries.AD.iter (fun e -> - ctx.split () [Events.Lock (e, rw); Events.RefinePointerExp {exp = arg; ad = Queries.AD.singleton e}] + ctx.split () (Events.Lock (e, rw) :: compute_refine_split e) ) (eval_exp_addr a arg); if may_fail then ctx.split () []; @@ -32,7 +38,7 @@ struct | Some lv -> let sb = Events.SplitBranch (Lval lv, nonzero_return_when_aquired) in Queries.AD.iter (fun e -> - ctx.split () [sb; Events.Lock (e, rw); Events.RefinePointerExp {exp = arg; ad = Queries.AD.singleton e}]; + ctx.split () (sb :: Events.Lock (e, rw) :: compute_refine_split e); ) (eval_exp_addr a arg); if may_fail then ( let fail_exp = if nonzero_return_when_aquired then Lval lv else BinOp(Gt, Lval lv, zero, intType) in diff --git a/src/domains/events.ml b/src/domains/events.ml index 78fedeafa2..06561bddbe 100644 --- a/src/domains/events.ml +++ b/src/domains/events.ml @@ -16,7 +16,6 @@ type t = | Assert of exp | Unassume of {exp: CilType.Exp.t; uuids: string list} | Longjmped of {lval: CilType.Lval.t option} - | RefinePointerExp of {exp: CilType.Exp.t; ad: ValueDomain.AD.t} (** Should event be emitted after transfer function raises [Deadcode]? *) let emit_on_deadcode = function @@ -32,8 +31,7 @@ let emit_on_deadcode = function | UpdateExpSplit _ (* Pointless to split on dead. *) | Unassume _ (* Avoid spurious writes. *) | Assert _ (* Pointless to refine dead. *) - | Longjmped _ - | RefinePointerExp _ -> + | Longjmped _ -> false let pretty () = function @@ -49,4 +47,3 @@ let pretty () = function | Assert exp -> dprintf "Assert %a" d_exp exp | Unassume {exp; uuids} -> dprintf "Unassume {exp=%a; uuids=%a}" d_exp exp (docList Pretty.text) uuids | Longjmped {lval} -> dprintf "Longjmped {lval=%a}" (docOpt (CilType.Lval.pretty ())) lval - | RefinePointerExp {exp; ad} -> dprintf "RefinePointerExp {exp=%a; ad=%a}" CilType.Exp.pretty exp ValueDomain.AD.pretty ad \ No newline at end of file From 3945a840f95024ddff182af0d757542f8170c850 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 29 Jan 2024 15:09:51 +0200 Subject: [PATCH 514/517] Add test for EvalFunvar query on dead code --- tests/regression/00-sanity/38-evalfunvar-dead.c | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 tests/regression/00-sanity/38-evalfunvar-dead.c diff --git a/tests/regression/00-sanity/38-evalfunvar-dead.c b/tests/regression/00-sanity/38-evalfunvar-dead.c new file mode 100644 index 0000000000..26c779c7e6 --- /dev/null +++ b/tests/regression/00-sanity/38-evalfunvar-dead.c @@ -0,0 +1,8 @@ +#include + +int main() { + int (*fp)() = &rand; + abort(); + fp(); // NOWARN (No suitable function to call) + return 0; +} From 82c9f97271406064db7ded64a0bb37d905e82133 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 29 Jan 2024 15:12:53 +0200 Subject: [PATCH 515/517] Fix no function to call warnings on dead code --- src/framework/constraints.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 84d7eff1ed..31dc668937 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -758,7 +758,7 @@ struct None in let funs = List.filter_map one_function functions in - if [] = funs then begin + if [] = funs && not (S.D.is_bot ctx.local) then begin M.msg_final Warning ~category:Unsound ~tags:[Category Call] "No suitable function to call"; M.warn ~category:Unsound ~tags:[Category Call] "No suitable function to be called at call site. Continuing with state before call."; d (* because LevelSliceLifter *) From 3e9d7f165401fcf46745a3fad3cf91c4583e01ec Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 29 Jan 2024 14:35:23 +0100 Subject: [PATCH 516/517] Move to pre-existing folder --- tests/regression/{79-mutex2/01-split.c => 04-mutex/96-split.c} | 0 .../{79-mutex2/02-split-mt.c => 04-mutex/97-split-mt.c} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename tests/regression/{79-mutex2/01-split.c => 04-mutex/96-split.c} (100%) rename tests/regression/{79-mutex2/02-split-mt.c => 04-mutex/97-split-mt.c} (100%) diff --git a/tests/regression/79-mutex2/01-split.c b/tests/regression/04-mutex/96-split.c similarity index 100% rename from tests/regression/79-mutex2/01-split.c rename to tests/regression/04-mutex/96-split.c diff --git a/tests/regression/79-mutex2/02-split-mt.c b/tests/regression/04-mutex/97-split-mt.c similarity index 100% rename from tests/regression/79-mutex2/02-split-mt.c rename to tests/regression/04-mutex/97-split-mt.c From 2e9284d460183e649947b706b8fd99943ed88688 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Mon, 29 Jan 2024 15:33:09 +0100 Subject: [PATCH 517/517] Fix for issue #1342 caused regression for #1338 --- src/analyses/apron/relationAnalysis.apron.ml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index 9df2360482..ea570b338a 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -219,14 +219,17 @@ struct begin match ask (Queries.MayPointTo e) with | ad when not (Queries.AD.is_top ad) && (Queries.AD.cardinal ad) = 1 -> let replace mval = - let pointee = ValueDomain.Addr.Mval.to_cil_exp mval in - let pointee_typ = Cil.typeSig @@ Cilfacade.typeOf pointee in - let lval_typ = Cil.typeSig @@ Cilfacade.typeOfLval (Mem e, NoOffset) in - if pointee_typ = lval_typ then - Some pointee - else - (* there is a type-mismatch between pointee and pointer-type *) - (* to avoid mismatch errors, we bail on this expression *) + try + let pointee = ValueDomain.Addr.Mval.to_cil_exp mval in + let pointee_typ = Cil.typeSig @@ Cilfacade.typeOf pointee in + let lval_typ = Cil.typeSig @@ Cilfacade.typeOfLval (Mem e, NoOffset) in + if pointee_typ = lval_typ then + Some pointee + else + (* there is a type-mismatch between pointee and pointer-type *) + (* to avoid mismatch errors, we bail on this expression *) + None + with Cilfacade.TypeOfError _ -> None in let r = Option.bind (Queries.AD.Addr.to_mval (Queries.AD.choose ad)) replace in