[Ival] New files int_set and int_interval.

They respectively implements the semantics of small integer sets and integer
intervals.

Makefile

@@ -587,6 +587,8 @@ KERNEL_CMO=\
 	src/kernel_services/abstract_interp/fc_float.cmo                \
 	src/kernel_services/abstract_interp/float_interval.cmo          \
 	src/kernel_services/abstract_interp/fval.cmo                    \
+	src/kernel_services/abstract_interp/int_interval.cmo            \
+	src/kernel_services/abstract_interp/int_set.cmo                 \
 	src/kernel_services/abstract_interp/ival.cmo                    \
 	src/kernel_services/abstract_interp/base.cmo                    \
 	src/kernel_services/abstract_interp/origin.cmo                  \
@@ -633,6 +635,7 @@ MLI_ONLY+=\
 	src/kernel_services/abstract_interp/float_sig.mli                    \
 	src/kernel_services/abstract_interp/float_interval_sig.mli           \
 	src/kernel_services/abstract_interp/lattice_type.mli                 \
+	src/kernel_services/abstract_interp/eva_lattice_type.mli             \
 	src/kernel_services/abstract_interp/int_Intervals_sig.mli            \
 	src/kernel_services/abstract_interp/offsetmap_lattice_with_isotropy.mli \
 	src/kernel_services/abstract_interp/offsetmap_sig.mli                \

headers/header_spec.txt

@@ -412,6 +412,7 @@ src/kernel_services/abstract_interp/base.ml: CEA_LGPL
 src/kernel_services/abstract_interp/base.mli: CEA_LGPL
 src/kernel_services/abstract_interp/bottom.ml: CEA_LGPL
 src/kernel_services/abstract_interp/bottom.mli: CEA_LGPL
+src/kernel_services/abstract_interp/eva_lattice_type.mli: CEA_LGPL
 src/kernel_services/abstract_interp/fc_float.ml: CEA_LGPL
 src/kernel_services/abstract_interp/fc_float.mli: CEA_LGPL
 src/kernel_services/abstract_interp/float_sig.mli: CEA_LGPL
@@ -425,6 +426,10 @@ src/kernel_services/abstract_interp/int_Base.mli: CEA_LGPL
 src/kernel_services/abstract_interp/int_Intervals.ml: CEA_LGPL
 src/kernel_services/abstract_interp/int_Intervals.mli: CEA_LGPL
 src/kernel_services/abstract_interp/int_Intervals_sig.mli: CEA_LGPL
+src/kernel_services/abstract_interp/int_interval.ml: CEA_LGPL
+src/kernel_services/abstract_interp/int_interval.mli: CEA_LGPL
+src/kernel_services/abstract_interp/int_set.ml: CEA_LGPL
+src/kernel_services/abstract_interp/int_set.mli: CEA_LGPL
 src/kernel_services/abstract_interp/ival.ml: CEA_LGPL
 src/kernel_services/abstract_interp/ival.mli: CEA_LGPL
 src/kernel_services/abstract_interp/lattice_messages.ml: CEA_LGPL

src/kernel_services/abstract_interp/eva_lattice_type.mli

+(**************************************************************************)
+(*                                                                        *)
+(*  This file is part of Frama-C.                                         *)
+(*                                                                        *)
+(*  Copyright (C) 2007-2019                                               *)
+(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
+(*         alternatives)                                                  *)
+(*                                                                        *)
+(*  you can redistribute it and/or modify it under the terms of the GNU   *)
+(*  Lesser General Public License as published by the Free Software       *)
+(*  Foundation, version 2.1.                                              *)
+(*                                                                        *)
+(*  It is distributed in the hope that it will be useful,                 *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
+(*  GNU Lesser General Public License for more details.                   *)
+(*                                                                        *)
+(*  See the GNU Lesser General Public License version 2.1                 *)
+(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Lattice signatures using the Bottom type:
+    these lattices do not include a bottom element, and return `Bottom instead
+    when needed. Except that, they are identical to the module signatures in
+    {!Lattice_type}. *)
+
+open Bottom.Type
+
+module type Join_Semi_Lattice = Lattice_type.Join_Semi_Lattice
+module type With_Top = Lattice_type.With_Top
+module type With_Intersects = Lattice_type.With_Intersects
+module type With_Enumeration = Lattice_type.With_Enumeration
+module type With_Cardinal_One = Lattice_type.With_Cardinal_One
+module type With_Widening = Lattice_type.With_Widening
+
+module type With_Narrow = sig
+  type t
+  val narrow: t -> t -> t or_bottom (** over-approximation of intersection *)
+end
+
+module type With_Under_Approximation = sig
+  type t
+  val link: t -> t -> t (** under-approximation of union *)
+  val meet: t -> t -> t or_bottom (** under-approximation of intersection *)
+end
+
+module type With_Diff = sig
+  type t
+  val diff : t -> t -> t or_bottom
+  (** [diff t1 t2] is an over-approximation of [t1-t2]. [t2] must
+      be an under-approximation or exact. *)
+end
+
+module type With_Diff_One = sig
+  type t
+  val diff_if_one : t -> t -> t or_bottom
+  (** [diff_of_one t1 t2] is an over-approximation of [t1-t2].
+      @return [t1] if [t2] is not a singleton. *)
+end
+
+(** {2 Common signatures} *)
+
+(** Signature shared by some functors of module {!Abstract_interp}. *)
+module type AI_Lattice_with_cardinal_one = sig
+  include Join_Semi_Lattice
+  include With_Top with type t:= t
+  include With_Widening with type t:= t
+  include With_Cardinal_One with type t := t
+  include With_Narrow with type t := t
+  include With_Under_Approximation with type t := t
+  include With_Intersects with type t := t
+end
+
+(** Most complete lattices: all operations plus widening, notion of cardinal
+    (including enumeration) and difference. *)
+module type Full_AI_Lattice_with_cardinality = sig
+  include AI_Lattice_with_cardinal_one
+  include With_Diff with type t := t
+  include With_Diff_One with type t := t
+  include With_Enumeration with type t := t
+end
+
+(*
+Local Variables:
+compile-command: "make -C ../../.."
+End:
+*)

src/kernel_services/abstract_interp/int_interval.mli

+(**************************************************************************)
+(*                                                                        *)
+(*  This file is part of Frama-C.                                         *)
+(*                                                                        *)
+(*  Copyright (C) 2007-2019                                               *)
+(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
+(*         alternatives)                                                  *)
+(*                                                                        *)
+(*  you can redistribute it and/or modify it under the terms of the GNU   *)
+(*  Lesser General Public License as published by the Free Software       *)
+(*  Foundation, version 2.1.                                              *)
+(*                                                                        *)
+(*  It is distributed in the hope that it will be useful,                 *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
+(*  GNU Lesser General Public License for more details.                   *)
+(*                                                                        *)
+(*  See the GNU Lesser General Public License version 2.1                 *)
+(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Bottom.Type
+
+include Datatype.S_with_collections
+
+include Eva_lattice_type.Full_AI_Lattice_with_cardinality
+  with type t := t
+   and type widen_hint = Integer.t * Datatype.Integer.Set.t
+
+val make:
+  min:Integer.t option -> max:Integer.t option ->
+  rem:Integer.t -> modu:Integer.t -> t
+
+val inject_range: Integer.t option -> Integer.t option -> t
+
+val min_and_max: t -> Integer.t option * Integer.t option
+
+val min_max_rem_modu:
+  t -> Integer.t option * Integer.t option * Integer.t * Integer.t
+
+val mem: Integer.t -> t -> bool
+
+val cardinal: t -> Integer.t option
+
+val add : t -> t -> t
+(** Addition of two integer (ie. not [Float]) ivals. *)
+val add_under : t -> t -> t or_bottom
+(** Underapproximation of the same operation *)
+val add_singleton_int: Integer.t -> t -> t
+(** Addition of an integer ival with an integer. Exact operation. *)
+
+val neg : t -> t
+(** Negation of an integer ival. Exact operation. *)
+
+
+val scale: Integer.t -> t -> t
+val scale_div: pos:bool -> Integer.t -> t -> t
+val scale_div_under: pos:bool -> Integer.t -> t -> t or_bottom
+val scale_rem: pos:bool -> Integer.t -> t -> t
+
+val mul: t -> t -> t
+val div: t -> t -> t or_bottom
+val c_rem: t -> t -> t or_bottom
+
+val subdivide: t -> t * t
+
+val reduce_sign: t -> bool -> t or_bottom
+val reduce_bit: int -> t -> bool -> t or_bottom
+
+val fold_int: (Integer.t -> 'a -> 'a) -> t -> 'a -> 'a

src/kernel_services/abstract_interp/int_set.ml

+(**************************************************************************)
+(*                                                                        *)
+(*  This file is part of Frama-C.                                         *)
+(*                                                                        *)
+(*  Copyright (C) 2007-2019                                               *)
+(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
+(*         alternatives)                                                  *)
+(*                                                                        *)
+(*  you can redistribute it and/or modify it under the terms of the GNU   *)
+(*  Lesser General Public License as published by the Free Software       *)
+(*  Foundation, version 2.1.                                              *)
+(*                                                                        *)
+(*  It is distributed in the hope that it will be useful,                 *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
+(*  GNU Lesser General Public License for more details.                   *)
+(*                                                                        *)
+(*  See the GNU Lesser General Public License version 2.1                 *)
+(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Abstract_interp
+open Bottom.Type
+
+(* Make sure all this is synchronized with the default value of -ilevel *)
+let small_cardinal = ref 8
+let set_small_cardinal i = small_cardinal := i
+
+let debug_cardinal = false
+
+let emitter = Lattice_messages.register "Int_set";;
+let log_imprecision s = Lattice_messages.emit_imprecision emitter s
+
+type set = Int.t array
+
+let bottom = Array.make 0 Int.zero
+
+let small_nums = Array.init 33 (fun i -> [| (Integer.of_int i) |])
+
+let zero = small_nums.(0)
+let one = small_nums.(1)
+let minus_one = [| Int.minus_one |]
+let zero_or_one = [| Int.zero ; Int.one |]
+
+let inject_singleton e =
+  if Int.le Int.zero e && Int.le e Int.thirtytwo
+  then small_nums.(Int.to_int e)
+  else [| e |]
+
+let unsafe_share_array a s =
+  let e = a.(0) in
+  if s = 1 && Int.le Int.zero e && Int.le e Int.thirtytwo
+  then small_nums.(Int.to_int e)
+  else if s = 2 && Int.is_zero e && Int.is_one a.(1)
+  then zero_or_one
+  else a
+
+(* TODO: assert s <> 0 *)
+let share_array a s =
+  if s = 0 then bottom else unsafe_share_array a s
+
+let share_array_or_bottom a s =
+  if s = 0 then `Bottom else `Value (unsafe_share_array a s)
+
+let inject_array = share_array
+
+let project_array t = t
+
+(* ------------------------------- Datatype --------------------------------- *)
+
+let hash s = Array.fold_left (fun acc v -> 1031 * acc + (Int.hash v)) 17 s
+
+let rehash s = share_array s (Array.length s)
+
+exception Unequal of int
+
+let compare s1 s2 =
+  if s1 == s2 then 0 else
+    let l1 = Array.length s1 in
+    let l2 = Array.length s2 in
+    if l1 <> l2
+    then l1 - l2 (* no overflow here *)
+    else
+      (try
+         for i = 0 to l1 - 1 do
+           let r = Int.compare s1.(i) s2.(i) in
+           if r <> 0 then raise (Unequal r)
+         done;
+         0
+       with Unequal v -> v)
+
+let equal e1 e2 = compare e1 e2 = 0
+
+let pretty fmt s =
+  if Array.length s = 0 then Format.fprintf fmt "BottomMod"
+  else begin
+    Pretty_utils.pp_iter
+      ~pre:"@[<hov 1>{"
+      ~suf:"}@]"
+      ~sep:";@ "
+      Array.iter Int.pretty fmt s
+  end
+
+include Datatype.Make_with_collections
+    (struct
+      type t = set
+      let name = "int_set"
+      open Structural_descr
+      let structural_descr = t_array (Descr.str Int.descr)
+      let reprs = [ zero ]
+      let equal = equal
+      let compare = compare
+      let hash = hash
+      let pretty = pretty
+      let rehash = rehash
+      let internal_pretty_code = Datatype.pp_fail
+      let mem_project = Datatype.never_any_project
+      let copy = Datatype.undefined
+      let varname = Datatype.undefined
+    end)
+
+(* ---------------------------------- Utils --------------------------------- *)
+
+let cardinal = Array.length
+
+let for_all f (a : Integer.t array) =
+  let l = Array.length a in
+  let rec c i = i = l || ((f a.(i)) && c (succ i)) in
+  c 0
+
+let exists = Extlib.array_exists
+
+let iter = Array.iter
+let fold = Array.fold_left
+
+let truncate r i =
+  if i = 0
+  then `Bottom
+  else if i = 1
+  then `Value (inject_singleton r.(0))
+  else begin
+    (Obj.truncate (Obj.repr r) i);
+    assert (Array.length r = i);
+    `Value r
+  end
+
+exception Empty
+
+let map_reduce (f : 'a -> 'b) (g : 'b -> 'b -> 'b) (set : 'a array) : 'b =
+  if Array.length set <= 0 then
+    raise Empty
+  else
+    let acc = ref (f set.(0)) in
+    for i = 1 to Array.length set - 1 do
+      acc := g !acc (f set.(i))
+    done;
+    !acc
+
+let filter (f : Int.t -> bool) (a : Int.t array) : t or_bottom =
+  let l = Array.length a in
+  let r = Array.make l Int.zero in
+  let j = ref 0 in
+  for i = 0 to l  - 1 do
+    let x = a.(i) in
+    if f x then begin
+      r.(!j) <- x;
+      incr j;
+    end
+  done;
+  truncate r !j
+
+let mem v a =
+  let l = Array.length a in
+  let rec c i =
+    if i = l then (-1)
+    else
+      let ae = a.(i) in
+      if Int.equal ae v
+      then i
+      else if Int.gt ae v
+      then (-1)
+      else c (succ i)
+  in
+  c 0
+
+(* ------------------------------- Set or top ------------------------------- *)
+
+type set_or_top = [ `Set of t | `Top of Integer.t * Integer.t * Integer.t ]
+
+module O = FCSet.Make (Integer)
+
+type pre_set =
+  | Pre_set of O.t * int
+  | Pre_top of Int.t * Int.t * Int.t
+
+let empty_ps = Pre_set (O.empty, 0)
+
+(* TODO: share this code with ival2.make_itv_from_set? *)
+let make_top_from_set s =
+  if debug_cardinal then assert (O.cardinal s >= 2);
+  let min = O.min_elt s in
+  let max = O.max_elt s in
+  let modu = O.fold
+      (fun x acc ->
+         if Int.equal x min then acc else Int.pgcd (Int.sub x min) acc)
+      s Int.zero
+  in
+  (min, max, modu)
+
+let add_ps ps x =
+  match ps with
+  | Pre_set (o, s) ->
+    if debug_cardinal then assert (O.cardinal o = s);
+    if O.mem x o (* TODO: improve *)
+    then ps
+    else
+      let no = O.add x o in
+      if s < !small_cardinal
+      then begin
+        if debug_cardinal then assert (O.cardinal no = succ s);
+        Pre_set (no, succ s)
+      end
+      else
+        let min, max, modu =  make_top_from_set no in
+        Pre_top (min, max, modu)
+  | Pre_top (min, max, modu) ->
+    let new_modu =
+      if Int.equal x min
+      then modu
+      else Int.pgcd (Int.sub x min) modu
+    in
+    let new_min = Int.min min x in
+    let new_max = Int.max max x in
+    Pre_top (new_min, new_max, new_modu)
+
+let o_zero = O.singleton Int.zero
+let o_one = O.singleton Int.one
+let o_zero_or_one = O.union o_zero o_one
+
+let share_set o s =
+  if s = 0 then bottom
+  else if s = 1
+  then begin
+    let e = O.min_elt o in
+    inject_singleton e
+  end
+  else if O.equal o o_zero_or_one
+  then zero_or_one
+  else
+    let a = Array.make s Int.zero in
+    let i = ref 0 in
+    O.iter (fun e -> a.(!i) <- e; incr i) o;
+    assert (!i = s);
+    a
+
+let inject_ps = function
+  | Pre_set (o, s) -> `Set (share_set o s)
+  | Pre_top (min, max, modu) -> `Top (min, max, modu)
+
+(* Given a set of elements that is an under-approximation, returns an
+   ival (while maintaining the ival invariants that the "Set"
+   constructor is used only for small sets of elements. *)
+let set_to_ival_under set =
+  let card = Int.Set.cardinal set in
+  if card <= !small_cardinal
+  then
+    let a = Array.make card Int.zero in
+    ignore (Int.Set.fold (fun elt i -> Array.set a i elt; i + 1) set 0);
+    `Set (share_array a card)
+  else
+    (* If by chance the set is contiguous. *)
+  if (Int.equal
+        (Int.sub (Int.Set.max_elt set) (Int.Set.min_elt set))
+        (Int.of_int (card - 1)))
+  then `Top (Int.Set.min_elt set, Int.Set.max_elt set, Int.one)
+  (* Else: arbitrarily drop some elements of the under approximation. *)
+  else
+    let a = Array.make !small_cardinal Int.zero in
+    log_imprecision "Ival.set_to_ival_under";
+    try
+      ignore (Int.Set.fold (fun elt i ->
+          if i = !small_cardinal then raise Exit;
+          Array.set a i elt;
+          i + 1) set 0);
+      assert false
+    with Exit -> `Set a
+
+(* ------------------------------ Apply and map ----------------------------- *)
+
+let apply_bin_1_strict_incr f x (s : Integer.t array) =
+  let l = Array.length s in
+  let r = Array.make l Int.zero in
+  let rec c i =
+    if i = l
+    then share_array r l
+    else
+      let v = f x s.(i) in
+      r.(i) <- v;
+      c (succ i)
+  in
+  c 0
+
+let apply_bin_1_strict_decr f x (s : Integer.t array) =
+  let l = Array.length s in
+  let r = Array.make l Int.zero in
+  let rec c i =
+    if i = l
+    then share_array r l
+    else
+      let v = f x s.(i) in
+      r.(l - i - 1) <- v;
+      c (succ i)
+  in
+  c 0
+
+let apply2_n f (s1 : Integer.t array) (s2 : Integer.t array) =
+  let ps = ref empty_ps in
+  let l1 = Array.length s1 in
+  let l2 = Array.length s2 in
+  for i1 = 0 to pred l1 do
+    let e1 = s1.(i1) in
+    for i2 = 0 to pred l2 do
+      ps := add_ps !ps (f e1 s2.(i2))
+    done
+  done;
+  inject_ps !ps
+
+let apply2_notzero f (s1 : Integer.t array) s2 =
+  inject_ps
+    (Array.fold_left
+       (fun acc v1 ->
+          Array.fold_left
+            (fun acc v2 ->
+               if Int.is_zero v2
+               then acc
+               else add_ps acc (f v1 v2))
+            acc
+            s2)
+       empty_ps
+       s1)
+
+let map_set_decr f (s : Integer.t array) =
+  let l = Array.length s in
+  if l = 0
+  then `Bottom
+  else
+    let r = Array.make l Int.zero in
+    let rec c srcindex dstindex last =
+      if srcindex < 0
+      then begin
+        r.(dstindex) <- last;
+        truncate r (succ dstindex)
+      end
+      else
+        let v = f s.(srcindex) in
+        if Int.equal v last
+        then
+          c (pred srcindex) dstindex last
+        else begin
+          r.(dstindex) <- last;
+          c (pred srcindex) (succ dstindex) v
+        end
+    in
+    c (l-2) 0 (f s.(pred l))
+
+let map_set_strict_decr f (s : Integer.t array) =
+  let l = Array.length s in
+  let r = Array.make l Int.zero in
+  let rec c i =
+    if i = l
+    then share_array r l
+    else
+      let v = f s.(i) in
+      r.(l - i - 1) <- v;
+      c (succ i)
+  in
+  c 0
+
+let map_set_incr f (s : Integer.t array) =
+  let l = Array.length s in
+  if l = 0
+  then `Bottom
+  else
+    let r = Array.make l Int.zero in
+    let rec c srcindex dstindex last =
+      if srcindex = l
+      then begin
+        r.(dstindex) <- last;
+        truncate r (succ dstindex)
+      end
+      else
+        let v = f s.(srcindex) in
+        if Int.equal v last
+        then
+          c (succ srcindex) dstindex last
+        else begin
+          r.(dstindex) <- last;