@ -47,8 +47,6 @@ module Degree = struct
( NonNegativeInt . to_int_exn d . linear * 100 ) + NonNegativeInt . to_int_exn d . log
( NonNegativeInt . to_int_exn d . linear * 100 ) + NonNegativeInt . to_int_exn d . log
let is_zero d = NonNegativeInt . is_zero d . linear && NonNegativeInt . is_zero d . log
let pp f d =
let pp f d =
NonNegativeInt . pp f d . linear ;
NonNegativeInt . pp f d . linear ;
if not ( NonNegativeInt . is_zero d . log ) then
if not ( NonNegativeInt . is_zero d . log ) then
@ -272,20 +270,22 @@ module MakePolynomial (S : NonNegativeSymbolWithDegreeKind) = struct
mult_const p1 p2 . const | > M . fold ( fun s p acc -> plus ( mult_symb ( mult p p1 ) s ) acc ) p2 . terms
mult_const p1 p2 . const | > M . fold ( fun s p acc -> plus ( mult_symb ( mult p p1 ) s ) acc ) p2 . terms
let rec of_valclass : ( NonNegativeInt . t , S . t , ' t ) Bounds . valclass -> ( t , ' t ) below_above =
let rec of_valclass : ( NonNegativeInt . t , S . t , ' t ) Bounds . valclass -> ( ' t , t , ' t ) below_above =
function
function
| ValTop trace ->
| ValTop trace ->
Above trace
Above trace
| Constant i ->
| Constant i ->
Below ( of_non_negative_int i )
Val ( of_non_negative_int i )
| Symbolic s -> (
| Symbolic s -> (
match S . split_mult s with
match S . split_mult s with
| None ->
| None ->
Below { const = NonNegativeInt . zero ; terms = M . singleton s one }
Val { const = NonNegativeInt . zero ; terms = M . singleton s one }
| Some ( s1 , s2 ) -> (
| Some ( s1 , s2 ) -> (
match ( of_valclass ( S . classify s1 ) , of_valclass ( S . classify s2 ) ) with
match ( of_valclass ( S . classify s1 ) , of_valclass ( S . classify s2 ) ) with
| Below s1 , Below s2 ->
| Val s1 , Val s2 ->
Below ( mult s1 s2 )
Val ( mult s1 s2 )
| Below _ , _ | _ , Below _ ->
assert false
| ( Above _ as t ) , _ | _ , ( Above _ as t ) ->
| ( Above _ as t ) , _ | _ , ( Above _ as t ) ->
t ) )
t ) )
@ -373,7 +373,7 @@ module MakePolynomial (S : NonNegativeSymbolWithDegreeKind) = struct
terms ( of_non_negative_int const )
terms ( of_non_negative_int const )
in
in
fun p eval_sym ->
fun p eval_sym ->
match subst p eval_sym with p -> Below p | exception ReturnTop s_trace -> Above s_trace
match subst p eval_sym with p -> Val p | exception ReturnTop s_trace -> Above s_trace
(* * Emit a pair ( d,t ) where d is the degree of the polynomial and t is the first term with such
(* * Emit a pair ( d,t ) where d is the degree of the polynomial and t is the first term with such
@ -509,24 +509,79 @@ module TopTraces = struct
match min_elt traces with None -> [] | Some trace -> TopTrace . make_err_trace ~ depth : 0 trace
match min_elt traces with None -> [] | Some trace -> TopTrace . make_err_trace ~ depth : 0 trace
end
end
module UnreachableTrace = struct
type t =
| UnreachableNode of Location . t
| Call of { location : Location . t ; callee_pname : Procname . t ; callee_trace : t }
[ @@ deriving compare ]
let rec length = function
| UnreachableNode _ ->
1
| Call { callee_trace } ->
1 + length callee_trace
let compare t1 t2 = [ % compare : int * t ] ( length t1 , t1 ) ( length t2 , t2 )
let unreachable_node node_loc = UnreachableNode node_loc
let call ~ location ~ callee_pname callee_trace = Call { location ; callee_pname ; callee_trace }
let rec pp f = function
| UnreachableNode node_loc ->
F . fprintf f " UnreachableNode (%a) " Location . pp node_loc
| Call { callee_pname ; callee_trace ; location } ->
F . fprintf f " %a -> Call `%a` (%a) " pp callee_trace Procname . pp callee_pname Location . pp
location
let rec make_err_trace ~ depth trace =
match trace with
| UnreachableNode node_loc ->
[ Errlog . make_trace_element depth node_loc " Unreachable node " [] ]
| Call { location ; callee_pname ; callee_trace } ->
let desc = F . asprintf " Call to %a " Procname . pp callee_pname in
Errlog . make_trace_element depth location desc []
:: make_err_trace ~ depth : ( depth + 1 ) callee_trace
end
module UnreachableTraces = struct
include AbstractDomain . MinReprSet ( UnreachableTrace )
let make_err_trace traces =
match min_elt traces with
| None ->
[]
| Some trace ->
UnreachableTrace . make_err_trace ~ depth : 0 trace
end
module NonNegativePolynomial = struct
module NonNegativePolynomial = struct
(* Use Below for non-Top values and Above for Top values with their trace *)
(* Use Above for Top values, Below for Unreachable values with their trace, and Val for non-negative polynomials *)
type t = ( NonNegativeNonTopPolynomial . t , TopTraces . t ) below_above
type t = ( UnreachableTraces. t , NonNegativeNonTopPolynomial. t , TopTraces . t ) below_above
type degree_with_term =
type degree_with_term =
( Degree . t * NonNegativeNonTopPolynomial . t , TopTraces . t ) AbstractDomain . Types . below_above
( UnreachableTraces . t
, Degree . t * NonNegativeNonTopPolynomial . t
, TopTraces . t )
AbstractDomain . Types . below_above
let leq =
let leq =
AbstractDomain . StackedUtils . leq ~ leq_below : NonNegativeNonTopPolynomial . leq
AbstractDomain . StackedUtils . leq ~ leq_below : UnreachableTraces . leq
~ leq_above : TopTraces . leq
~ leq : NonNegativeNonTopPolynomial . leq ~ leq _above: TopTraces . leq
let pp ~ hum =
let pp ~ hum =
let pp_below f traces =
AbstractDomain . BottomLiftedUtils . pp_bottom f ;
if not hum then F . fprintf f " : %a " UnreachableTraces . pp traces
in
let pp_above f traces =
let pp_above f traces =
AbstractDomain . TopLiftedUtils . pp_top f ;
AbstractDomain . TopLiftedUtils . pp_top f ;
if not hum then F . fprintf f " : %a " TopTraces . pp traces
if not hum then F . fprintf f " : %a " TopTraces . pp traces
in
in
AbstractDomain . StackedUtils . pp ~ pp_below : ( NonNegativeNonTopPolynomial . pp ~ hum ) ~ pp_above
AbstractDomain . StackedUtils . pp ~ pp : ( NonNegativeNonTopPolynomial . pp ~ hum ) ~ pp_above ~ pp_below
let pp_hum = pp ~ hum : true
let pp_hum = pp ~ hum : true
@ -535,48 +590,69 @@ module NonNegativePolynomial = struct
let top = Above TopTraces . bottom
let top = Above TopTraces . bottom
let zero = Below NonNegativeNonTopPolynomial . zero
let zero = Val NonNegativeNonTopPolynomial . zero
let one = Val NonNegativeNonTopPolynomial . one
let one = Below NonNegativeNonTopPolynomial . one
let of_unreachable node_loc =
Below ( UnreachableTraces . singleton ( UnreachableTrace . unreachable_node node_loc ) )
let of_int_exn i = Below ( NonNegativeNonTopPolynomial . of_int_exn i )
let of_int_exn i = Val ( NonNegativeNonTopPolynomial . of_int_exn i )
let make_trace_set ~ map_above =
let make_trace_set ~ map_above =
AbstractDomain . StackedUtils . map ~ f_below : Fn . id ~ f_above : ( fun above ->
AbstractDomain . StackedUtils . map
TopTraces . singleton ( map_above above ) )
~ f_below : ( fun _ -> assert false )
~ f : Fn . id
~ f_above : ( fun above -> TopTraces . singleton ( map_above above ) )
let of_non_negative_bound ? ( degree_kind = DegreeKind . Linear ) b =
let of_non_negative_bound ? ( degree_kind = DegreeKind . Linear ) b =
b
b
| > NonNegativeBoundWithDegreeKind . make degree_kind
| > NonNegativeBoundWithDegreeKind . make degree_kind
| > NonNegativeBoundWithDegreeKind . classify | > NonNegativeNonTopPolynomial . of_valclass
| > NonNegativeBoundWithDegreeKind . classify | > NonNegativeNonTopPolynomial . of_valclass
(* Invariant: we always get a non-below bound from [of_valclass] *)
| > make_trace_set ~ map_above : TopTrace . unbounded_loop
| > make_trace_set ~ map_above : TopTrace . unbounded_loop
let is_symbolic = function
let is_symbolic = function
| Above _ ->
| Below _ | Above _ ->
false
false
| Below p ->
| Val p ->
NonNegativeNonTopPolynomial . is_symbolic p
NonNegativeNonTopPolynomial . is_symbolic p
let is_top = function Above _ -> true | _ -> false
let is_top = function Above _ -> true | _ -> false
let is_ zero = function Below p when NonNegativeNonTopPolynomial . is_zero p -> true | _ -> false
let is_ unreachable = function Below _ -> true | _ -> false
let is_one = function Below p when NonNegativeNonTopPolynomial . is_one p -> true | _ -> false
let is_zero = function Val p when NonNegativeNonTopPolynomial . is_zero p -> true | _ -> false
let is_one = function Val p when NonNegativeNonTopPolynomial . is_one p -> true | _ -> false
let top_lifted_increasing ~ f p1 p2 =
let top_lifted_increasing ~ f p1 p2 =
AbstractDomain . StackedUtils . combine ~ dir : ` Increasing p1 p2 ~ f_below : f ~ f_above : TopTraces . join
AbstractDomain . StackedUtils . combine ~ f_below : UnreachableTraces . join ~ dir : ` Increasing p1 p2 ~ f
~ f_above : TopTraces . join
let unreachable_lifted_increasing ~ f p1 p2 =
match ( p1 , p2 ) with
| ( Below _ as below ) , Val _ | Val _ , ( Below _ as below ) ->
below
| _ ->
top_lifted_increasing ~ f p1 p2
let plus = top_lifted_increasing ~ f : NonNegativeNonTopPolynomial . plus
let plus = top_lifted_increasing ~ f : NonNegativeNonTopPolynomial . plus
let mult_unreachable = unreachable_lifted_increasing ~ f : NonNegativeNonTopPolynomial . mult
let mult = top_lifted_increasing ~ f : NonNegativeNonTopPolynomial . mult
let mult = top_lifted_increasing ~ f : NonNegativeNonTopPolynomial . mult
let min_default_left p1 p2 =
let min_default_left p1 p2 =
AbstractDomain . StackedUtils . combine ~ dir : ` Decreasing p1 p2
AbstractDomain . StackedUtils . combine ~ dir : ` Decreasing p1 p2
~ f_below : NonNegativeNonTopPolynomial . min_default_left ~ f_above : TopTraces . join
~ f : NonNegativeNonTopPolynomial . min_default_left ~ f_above : TopTraces . join
~ f_below : UnreachableTraces . join
let subst callee_pname location p eval_sym =
let subst callee_pname location p eval_sym =
@ -586,37 +662,47 @@ module NonNegativePolynomial = struct
( TopTraces . map
( TopTraces . map
( fun callee_trace -> TopTrace . call ~ callee_pname ~ location callee_trace )
( fun callee_trace -> TopTrace . call ~ callee_pname ~ location callee_trace )
callee_traces )
callee_traces )
| Below p ->
| Below callee_traces ->
Below
( UnreachableTraces . map
( fun callee_trace -> UnreachableTrace . call ~ callee_pname ~ location callee_trace )
callee_traces )
| Val p ->
NonNegativeNonTopPolynomial . subst callee_pname location p eval_sym
NonNegativeNonTopPolynomial . subst callee_pname location p eval_sym
| > make_trace_set ~ map_above : ( fun ( symbol , bound_trace ) ->
| > make_trace_set ~ map_above : ( fun ( symbol , bound_trace ) ->
TopTrace . unbounded_symbol ~ location ~ symbol bound_trace )
TopTrace . unbounded_symbol ~ location ~ symbol bound_trace )
let degree p =
let degree p =
match p with Above _ -> None | Below p -> Some ( NonNegativeNonTopPolynomial . degree p )
match p with Above _ | Below _ -> None | Val p -> Some ( NonNegativeNonTopPolynomial . degree p )
let compare_by_degree =
let compare_by_degree =
let cmp_above _ _ = 0 (* All Top should be considered equal *) in
let cmp _ _ = 0 (* All pairs of Top/Unreachable should be considered equal *) in
AbstractDomain . StackedUtils . compare ~ cmp_above ~ cmp_below : ( fun p1 p2 ->
AbstractDomain . StackedUtils . compare ~ cmp_above : cmp
~ cmp : ( fun p1 p2 ->
Degree . compare
Degree . compare
( NonNegativeNonTopPolynomial . degree p1 )
( NonNegativeNonTopPolynomial . degree p1 )
( NonNegativeNonTopPolynomial . degree p2 ) )
( NonNegativeNonTopPolynomial . degree p2 ) )
~ cmp_below : cmp
let get_degree_with_term =
let get_degree_with_term =
AbstractDomain . StackedUtils . map ~ f _below : NonNegativeNonTopPolynomial . degree_with_term
AbstractDomain . StackedUtils . map ~ f : NonNegativeNonTopPolynomial . degree_with_term ~ f_above : Fn . id
~ f_ a bov e: Fn . id
~ f_ below : Fn . id
let get_symbols =
let get_symbols =
AbstractDomain . StackedUtils . map ~ f_below : NonNegativeNonTopPolynomial . get_symbols ~ f_above : Fn . id
AbstractDomain . StackedUtils . map ~ f : NonNegativeNonTopPolynomial . get_symbols ~ f_above : Fn . id
~ f_below : Fn . id
let pp_degree ~ only_bigO fmt = function
let pp_degree ~ only_bigO fmt = function
| Above _ ->
| Above _ ->
Format . pp_print_string fmt " Top "
Format . pp_print_string fmt " Top "
| Below ( degree , degree_term ) ->
| Below _ ->
Format . pp_print_string fmt " Unreachable "
| Val ( degree , degree_term ) ->
if only_bigO then
if only_bigO then
Format . fprintf fmt " O(%a) "
Format . fprintf fmt " O(%a) "
( NonNegativeNonTopPolynomial . pp ~ hum : true )
( NonNegativeNonTopPolynomial . pp ~ hum : true )
@ -634,7 +720,9 @@ module NonNegativePolynomial = struct
let polynomial_traces p =
let polynomial_traces p =
match get_symbols p with
match get_symbols p with
| Below symbols ->
| Below trace ->
UnreachableTraces . make_err_trace trace
| Val symbols ->
List . map symbols ~ f : Bounds . NonNegativeBound . make_err_trace | > Errlog . concat_traces
List . map symbols ~ f : Bounds . NonNegativeBound . make_err_trace | > Errlog . concat_traces
| Above trace ->
| Above trace ->
TopTraces . make_err_trace trace
TopTraces . make_err_trace trace