diff --git a/CodeHawk/CHJ/jchcmdline/dune b/CodeHawk/CHJ/jchcmdline/dune index 5ddf04e1..070bb6aa 100644 --- a/CodeHawk/CHJ/jchcmdline/dune +++ b/CodeHawk/CHJ/jchcmdline/dune @@ -32,7 +32,3 @@ (modules jCHXNativeMethodSignatures) (package exes) (public_name chj_native)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchcmdline/jCHXClassExperiment.ml b/CodeHawk/CHJ/jchcmdline/jCHXClassExperiment.ml index bb1609e2..34e766ee 100644 --- a/CodeHawk/CHJ/jchcmdline/jCHXClassExperiment.ml +++ b/CodeHawk/CHJ/jchcmdline/jCHXClassExperiment.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk C Analyzer + CodeHawk Java Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcmdline/jCHXInspectSummaries.ml b/CodeHawk/CHJ/jchcmdline/jCHXInspectSummaries.ml index 34f42b5a..c2e817c7 100644 --- a/CodeHawk/CHJ/jchcmdline/jCHXInspectSummaries.ml +++ b/CodeHawk/CHJ/jchcmdline/jCHXInspectSummaries.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk C Analyzer + CodeHawk Java Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcmdline/jCHXIntegrateSummaries.ml b/CodeHawk/CHJ/jchcmdline/jCHXIntegrateSummaries.ml index d62e3625..9727959b 100644 --- a/CodeHawk/CHJ/jchcmdline/jCHXIntegrateSummaries.ml +++ b/CodeHawk/CHJ/jchcmdline/jCHXIntegrateSummaries.ml @@ -1,11 +1,11 @@ (* ============================================================================= - CodeHawk C Analyzer + CodeHawk Java Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcmdline/jCHXNativeMethodSignatures.ml b/CodeHawk/CHJ/jchcmdline/jCHXNativeMethodSignatures.ml index 292cb7be..768e7e77 100644 --- a/CodeHawk/CHJ/jchcmdline/jCHXNativeMethodSignatures.ml +++ b/CodeHawk/CHJ/jchcmdline/jCHXNativeMethodSignatures.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk C Analyzer + CodeHawk Java Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcmdline/jCHXTemplate.ml b/CodeHawk/CHJ/jchcmdline/jCHXTemplate.ml index bbd1e0eb..ac3b41cd 100644 --- a/CodeHawk/CHJ/jchcmdline/jCHXTemplate.ml +++ b/CodeHawk/CHJ/jchcmdline/jCHXTemplate.ml @@ -1,10 +1,11 @@ (* ============================================================================= - CodeHawk C Analyzer + CodeHawk Java Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcost/dune b/CodeHawk/CHJ/jchcost/dune index 284714d6..1d44ced0 100644 --- a/CodeHawk/CHJ/jchcost/dune +++ b/CodeHawk/CHJ/jchcost/dune @@ -3,7 +3,3 @@ (libraries chlib chutil jchlib jchpoly jchpre jchsys zarith) (public_name codehawk.jchcost) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchcost/jCHCostAPI.mli b/CodeHawk/CHJ/jchcost/jCHCostAPI.mli index 79b5a9ce..1be1cf89 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostAPI.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostAPI.mli @@ -3,8 +3,9 @@ Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -62,7 +63,7 @@ class type sidechannelcheck_int = class type costmodel_int = object - + (* utility *) method mk_bottom: 'a method mk_top : 'a @@ -88,7 +89,7 @@ object (* xml *) method write_xml_cost: xml_element_int -> 'a -> unit method save_xml_class: class_info_int -> unit - method save_xml_atlas_class: class_info_int -> unit + method save_xml_atlas_class: class_info_int -> unit method read_xml_cost: xml_element_int -> unit method read_xml_class: class_info_int -> unit diff --git a/CodeHawk/CHJ/jchcost/jCHCostBound.ml b/CodeHawk/CHJ/jchcost/jCHCostBound.ml index 2596c48b..20900876 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBound.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostBound.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -49,13 +50,13 @@ open JCHCostUtils let dbg = ref false -(* cost <= (sum terms) + const / div or cost => (sum terms) + const / div +(* cost <= (sum terms) + const / div or cost => (sum terms) + const / div * each term is of the form coeff x jterm1 ^ n1 x jterm ^ n2 x ... * div is pos *) - + let max_small_coeff = mkNumerical 100 let max_small_div = mkNumerical 100 - + class cost_bound_t (is_lb: bool) (terms: numerical_t JTermTableCollections.table_t) @@ -96,7 +97,7 @@ object (self : 'a) comp_div method is_const = - !terms#size = 0 + !terms#size = 0 method is_pos_const = !terms#size = 0 && !const#geq numerical_zero @@ -108,21 +109,21 @@ object (self : 'a) !terms#size = 0 && not (!const#equal numerical_zero) method has_negative_coefficient = - List.exists (fun (t,n) -> n#lt numerical_zero) !terms#listOfPairs + List.exists (fun (_, n) -> n#lt numerical_zero) !terms#listOfPairs method has_pos_jterms = List.for_all is_pos_jterm self#get_jterms#toList (* assume that the coeffs are pos *) method is_small = - if !const#leq max_small_coeff then + if !const#leq max_small_coeff then List.for_all (fun n -> n#leq max_small_coeff) !terms#listOfValues else false method number_terms = !terms#size - method private change_is_lb (a: 'a) = + method private change_is_lb (a: 'a) = {< is_lb = not a#is_lb; terms = ref a#get_terms; const = ref a#get_const; @@ -132,14 +133,18 @@ object (self : 'a) (index_map: (int * numerical_t JTermCollections.table_t) list) (t: numerical_t JTermCollections.table_t) = try - fst (List.find - (fun (_, j) -> (compare_tables jterm_compare compare_num) t j = 0) index_map) + fst + (List.find + (fun (_, j) -> + (compare_tables jterm_compare compare_num) t j = 0) index_map) with | Not_found -> - raise (JCH_failure - (LBLOCK [ STR "term " ; t#toPretty; - STR " not found in JCHCostBounds.cost_bound_t find_index" ])) - + raise + (JCH_failure + (LBLOCK [ + STR "term " ; t#toPretty; + STR " not found in JCHCostBounds.cost_bound_t find_index"])) + method get_jterms = let set = new JTermCollections.set_t in let add_prod table = set#addList table#listOfKeys in @@ -149,7 +154,7 @@ object (self : 'a) end method equal (a: 'a) = - if !div#equal a#get_div && !const#equal a#get_const then + if !div#equal a#get_div && !const#equal a#get_const then begin let prods = JTermTableCollections.set_of_list @@ -165,17 +170,17 @@ object (self : 'a) false method private augment (bound: 'a) (num: numerical_t) = - {< is_lb = bound#is_lb; + {< is_lb = bound#is_lb; terms = ref (bound#get_terms#map (fun t -> t#mult num)); const = ref (bound#get_const#mult num) ; - div = ref (bound#get_div#mult num) >} + div = ref (bound#get_div#mult num) >} method make_opposite = {< is_lb = not is_lb >} method private add_same_div (b1: 'a) (b2: 'a) = let new_terms = b1#get_terms#clone in - let add_pair t num = + let add_pair t num = match new_terms#get t with | Some n -> let new_num = n#add num in @@ -189,7 +194,7 @@ object (self : 'a) const = ref (b1#get_const#add b2#get_const) ; div = ref b1#get_div >} end - + method add (a: 'a) = if self#is_zero_const then a else if a#is_zero_const then @@ -197,16 +202,16 @@ object (self : 'a) else if is_lb != a#is_lb then begin pr_debug [STR "adding a lower bound and an upper bound in " ; - STR "JCHCostBounds.cost_bound_t add"]; + STR "JCHCostBounds.cost_bound_t add"]; raise (JCH_failure (LBLOCK [STR "adding a lower bound and an upper bound " ; STR "in JCHCostBounds.cost_bound_t add"])) end - else + else let lcm = !div#lcm a#get_div in let bound = self#augment self (lcm#div !div) in let abound = self#augment a (lcm#div a#get_div) in - self#add_same_div bound abound + self#add_same_div bound abound method neg = {< is_lb = not is_lb; @@ -217,7 +222,7 @@ object (self : 'a) self#add (a#neg) (* We assume that we multiply two positive cost bounds - * mult is also used when multiplying two cost_bound_t that are viewed as just + * mult is also used when multiplying two cost_bound_t that are viewed as just * expressions not bounds, for instance in bound_from_jterm *) method mult (a: 'a) = let mult_prods (t1: numerical_t JTermCollections.table_t) @@ -254,13 +259,13 @@ object (self : 'a) List.iter add_terms pairs ; List.iter add_terms pairs1; List.iter add_terms pairs2; - + self#simplify_coeffs {< terms = ref new_terms ; const = ref (!const#mult a#get_const); div = ref (!div#mult a#get_div)>} end - + (* assume a is a pos const *) method div (a: 'a) = if not a#is_const then @@ -269,7 +274,7 @@ object (self : 'a) let aconst = a#get_const in if aconst#equal numerical_zero then raise (JCH_failure (STR "division by 0")) - else + else let adiv = a#get_div in self#simplify_coeffs {< terms = ref (!terms#clone#map (fun n -> n#mult adiv)); @@ -300,24 +305,24 @@ object (self : 'a) method make_small_div = if !div#leq max_small_div then self - else if self#has_pos_jterms then + else if self#has_pos_jterms then begin let nrs = !const :: !terms#listOfValues in let min = ref !div in let check_nr n = - if not (n#equal numerical_zero) then + if not (n#equal numerical_zero) then let nabs = n#abs in if nabs#lt !min then min := nabs in List.iter check_nr nrs ; let changed = ref (!min != !div) in let change down n = - let new_n = + let new_n = let md = n#modulo !min in let n' = (n#sub md)#div !min in if down || md#equal numerical_zero then n' else n'#add numerical_one in - new_n in - let res = + new_n in + let res = {< terms = ref (!terms#map (change is_lb)); const = ref (change is_lb !const) ; div = ref (change (not is_lb) !div) >} in @@ -332,7 +337,7 @@ object (self : 'a) (LBLOCK [STR (pretty_to_string pp)]) ; pr__debug [STR "cost loss of precision "; pp] ; end ; - res + res end else begin @@ -341,7 +346,7 @@ object (self : 'a) NL; self#toPretty; NL ]); self end - + method private mk_constant (is_lb:bool) (n:numerical_t) = self#make_cost_bound is_lb (new JTermTableCollections.table_t) n numerical_one @@ -381,7 +386,7 @@ object (self : 'a) else begin let res = ref bound in - for i = 2 to int_p do + for _i = 2 to int_p do res := !res#mult bound done ; !res @@ -391,7 +396,7 @@ object (self : 'a) (is_lb:bool) ((jterm, power):jterm_t * numerical_t) (map: (jterm_t * 'a) list) - (is_jterm_to_keep:(jterm_t -> bool)): 'a = + (is_jterm_to_keep:(jterm_t -> bool)): 'a = if is_jterm_to_keep jterm then let t = new JTermCollections.table_t in let table = new JTermTableCollections.table_t in @@ -407,7 +412,7 @@ object (self : 'a) try (* not in the map *) let new_bound = snd (List.find (fun (j, _) -> jterm_compare j jterm = 0) map) in - self#power new_bound power + self#power new_bound power with | _ -> begin @@ -416,16 +421,16 @@ object (self : 'a) end method private subst_term - (is_lb:bool) + (is_lb:bool) ((prod, num):numerical_t JTermCollections.table_t * numerical_t) (map:(jterm_t * 'a) list) (is_jterm_to_keep:(jterm_t -> bool)): 'a = let bound = - ref {< is_lb = is_lb; + ref {< is_lb = is_lb; terms = ref (new JTermTableCollections.table_t); const = ref num; div = ref numerical_one >} in - let mult_by_power (jterm, power) = + let mult_by_power (jterm, power) = bound := !bound#mult (self#subst_power is_lb (jterm, power) map is_jterm_to_keep) in @@ -433,7 +438,7 @@ object (self : 'a) List.iter mult_by_power prod#listOfPairs ; !bound end - + method private subst_ (a: 'a) (map: (jterm_t * 'a) list) @@ -449,7 +454,7 @@ object (self : 'a) self#make_cost_bound sum#is_lb sum#get_terms sum#get_const (sum#get_div#mult !div) - method has_only_jterms_to_keep (is_jterm_to_keep: jterm_t -> bool) = + method has_only_jterms_to_keep (is_jterm_to_keep: jterm_t -> bool) = let is_good table = List.for_all is_jterm_to_keep table#listOfKeys in List.for_all is_good !terms#listOfKeys @@ -484,7 +489,7 @@ object (self : 'a) let new_terms = new JTermTableCollections.table_t in let diff = new JTermTableCollections.table_t in let adiff = new JTermTableCollections.table_t in - + let set prod (n: numerical_t) (m: numerical_t) = let n = n#mult mult in let m = m#mult amult in @@ -494,7 +499,7 @@ object (self : 'a) else if n#lt m then begin if n#gt numerical_zero then new_terms#set prod n ; - adiff#set prod (m#sub n) + adiff#set prod (m#sub n) end else begin @@ -514,16 +519,16 @@ object (self : 'a) new_terms#set prod m; diff#set prod (m#sub n) end in - + let prods = JTermTableCollections.set_of_list (!terms#listOfKeys @ a#get_terms#listOfKeys) in - + let get_coeff (prod: numerical_t JTermCollections.table_t) - (ts: numerical_t JTermTableCollections.table_t) = + (ts: numerical_t JTermTableCollections.table_t) = match ts#get prod with Some n -> n | None -> numerical_zero in - + let add_prod prod = let c = get_coeff prod !terms in let ac = get_coeff prod a#get_terms in @@ -544,14 +549,14 @@ object (self : 'a) new_const := !new_const#add (Option.get diff_cost_bound#find_const_lb_no_div) ; new_aconst := - !new_aconst#add (Option.get adiff_cost_bound#find_const_lb_no_div) ; + !new_aconst#add (Option.get adiff_cost_bound#find_const_lb_no_div) ; end else begin new_const := !new_const#sub (Option.get diff_cost_bound#find_const_lb_no_div) ; new_aconst := - !new_aconst#sub (Option.get adiff_cost_bound#find_const_lb_no_div) ; + !new_aconst#sub (Option.get adiff_cost_bound#find_const_lb_no_div) ; end ; let new_const = @@ -568,11 +573,11 @@ object (self : 'a) let new_const = if new_const#lt numerical_zero then numerical_zero else new_const in - let bound = + let bound = {< terms = ref new_terms; const = ref new_const; div = ref new_div >} in - self#simplify_coeffs bound + self#simplify_coeffs bound method has_pos_coeffs = List.for_all (fun n -> n#geq numerical_zero) !terms#listOfValues @@ -598,9 +603,9 @@ object (self : 'a) ((prod, coeff):numerical_t JTermCollections.table_t * numerical_t) : numerical_t = let find_lb_jterm jterm = match jterm with - | JConstant i + | JConstant i | JSymbolicConstant (_, Some i, _, _) -> i - | JSize t -> numerical_zero + | JSize _ -> numerical_zero | _ -> begin match JCHNumericAnalysis.get_pos_field_interval jterm with @@ -610,32 +615,32 @@ object (self : 'a) (JCH_failure (LBLOCK [ STR "find_const_lb expected pos symbolic const, pos field, or size " ; - jterm_to_pretty jterm; NL])) + jterm_to_pretty jterm; NL])) end in - - + + let find_lb_power ((jterm, n): jterm_t * numerical_t) = let lb = find_lb_jterm jterm in let res = ref numerical_one in - for i = 1 to n#toInt do + for _i = 1 to n#toInt do res := !res#mult lb ; done; !res in - + let res = ref coeff in let mult_power p = res := !res#mult (find_lb_power p) in List.iter mult_power prod#listOfPairs ; - !res + !res method find_const_lb_no_div = - let find_lb_sum () = + let find_lb_sum () = let res = ref !const in let add_term t = res := !res#add (self#find_const_lb_term t) in List.iter add_term !terms#listOfPairs ; !res in - + if self#has_pos_jterms && self#has_pos_coeffs then try Some (find_lb_sum ()) @@ -652,7 +657,7 @@ object (self : 'a) method is_local_var_linear = let is_linear (term, coeff) = let ps = term#listOfPairs in - if (List.length ps) == 1 then + if (List.length ps) == 1 then let (jt, power) = List.hd ps in power#equal numerical_one || not (is_local_var true jt) else @@ -688,12 +693,12 @@ object (self : 'a) let cnst = if is_lb then !const#neg#getNum else !const#getNum in new JCHLinearConstraint.linear_constraint_t false ps cnst - method to_jterm = + method to_jterm = let prod_to_jterm t = let rec power_to_jterm power j n = if n = 0 then power else power_to_jterm (JArithmeticExpr (JTimes, power, j)) j (pred n) in - let rec func pairs = + let rec func pairs = match pairs with | [(j, n)] -> power_to_jterm j j (pred n#toInt) | (j, n) :: rest_pairs -> @@ -701,10 +706,10 @@ object (self : 'a) func rest_pairs) | _ -> raise (JCHBasicTypes.JCH_failure (STR "empty product")) in func t#listOfPairs in - + let add_pair s (t, num) = if num#equal numerical_one then - JArithmeticExpr (JPlus, s, prod_to_jterm t) + JArithmeticExpr (JPlus, s, prod_to_jterm t) else JArithmeticExpr (JPlus, s, JArithmeticExpr (JTimes, JConstant num, prod_to_jterm t)) in @@ -716,7 +721,7 @@ object (self : 'a) jtdictionary#write_xml_jterm node self#to_jterm method toPretty = - self#to_pretty_small + self#to_pretty_small method to_string = let rel_str = if is_lb then " >= " else " <= " in @@ -731,7 +736,7 @@ object (self : 'a) let first = ref true in let pp_sign = if is_lb then STR ">= " else STR "<= " in let pp_jterm jterm = - let rec pp_str jt = + let rec pp_str jt = match jt with (* TBA: JPower(t,n), JUninterpreted (name,terms) ?? *) | JLocalVar (-1) -> "return" @@ -746,7 +751,7 @@ object (self : 'a) | JLoopCounter i -> "loop-counter@pc_" ^ (string_of_int i) | JStaticFieldValue (cnix,name) -> ((JCHDictionary.retrieve_cn cnix)#name ^ "." ^ name) - | JObjectFieldValue (cmsix,varix,cnix,name) -> + | JObjectFieldValue (cmsix, _varix, _cnix, name) -> ((JCHDictionary.retrieve_cms cmsix)#name ^ ":var" ^ "." ^ name) | JConstant i -> i#toString | JBoolConstant b -> if b then "true" else "false" @@ -756,14 +761,17 @@ object (self : 'a) | JUninterpreted (str, js) -> let add_j (first, pp) j = (false, - if first then pp ^ (jterm_to_string j) else pp ^ ", "^(jterm_to_string j)) in - (snd (List.fold_left add_j (true, str ^ "(") js)) ^ ")" + if first then + pp ^ (jterm_to_string j) + else + pp ^ ", "^(jterm_to_string j)) in + (snd (List.fold_left add_j (true, str ^ "(") js)) ^ ")" | _ -> raise (JCH_failure (STR "unacceptable term in cost_bound_t")) in STR (pp_str jterm) in let pp_n n = n#toPretty in - let terms_const : ((jterm_t * numerical_t) list * numerical_t) list = + let terms_const : ((jterm_t * numerical_t) list * numerical_t) list = (List.map (fun (t, n) -> (t#listOfPairs, n)) !terms#listOfPairs) @ [([], !const)] in let pp_product @@ -771,13 +779,13 @@ object (self : 'a) ((jterm, n): jterm_t * numerical_t):pretty_t list = if n#equal numerical_one then pp @ [STR "("; pp_jterm jterm; STR ")"] else pp @ [STR "("; pp_jterm jterm; STR ")^"; n#toPretty] in - let rec pp_terms pp (t, n) = + let pp_terms pp (t, n) = let pp_coeff c = if t = [] then [pp_n c] else if n#equal numerical_one then [] else [pp_n c; STR " x "] in if n#equal numerical_zero && t = [] then pp - else if n#geq numerical_zero then + else if n#geq numerical_zero then begin if !first then begin @@ -796,7 +804,7 @@ object (self : 'a) end else List.fold_left pp_product (pp @ [STR " - "] @ (pp_coeff n_abs)) t end in - let pp_sum = + let pp_sum = if self#is_const then LBLOCK [pp_sign; pp_n !const] else @@ -804,18 +812,18 @@ object (self : 'a) if !div#equal numerical_one then pp_sum else - LBLOCK [STR "("; pp_sum; STR ") / "; !div#toPretty] - + LBLOCK [STR "("; pp_sum; STR ") / "; !div#toPretty] + method to_evx : external_value_exchange_format_t = let is_lb_evx = EVX_STRING (if is_lb then "true" else "false") in let div_evx = EVX_STRING !div#toString in let pair_to_evx (table, num) = - let power_to_evx (j, n) = + let power_to_evx (j, _n) = EVX_LIST [EVX_STRING (jterm_to_string j); EVX_STRING num#toString] in let powers_evx = EVX_LIST (List.map power_to_evx table#listOfPairs) in EVX_LIST [EVX_STRING num#toString; powers_evx] in - + let pairs_evx = EVX_LIST (List.map pair_to_evx !terms#listOfPairs) in let const_evx = EVX_STRING !const#toString in EVX_LIST [is_lb_evx; pairs_evx; const_evx; div_evx] @@ -823,7 +831,7 @@ end let cost_bound_from_num is_lb n = new cost_bound_t is_lb (new JTermTableCollections.table_t) n numerical_one - + let bounds_from_linear_constraint index_map (constr: JCHLinearConstraint.linear_constraint_t) = let (ps, cnst) = constr#get_pairs_const in @@ -852,7 +860,7 @@ let bounds_from_linear_constraint [new cost_bound_t true terms const neg_div; new cost_bound_t false terms const neg_div] else - [new cost_bound_t false terms const neg_div] + [new cost_bound_t false terms const neg_div] let rec bound_from_jterm is_lb jterm : cost_bound_t = match jterm with @@ -869,7 +877,7 @@ let rec bound_from_jterm is_lb jterm : cost_bound_t = | JAuxiliaryVar _ | JLocalVar _ | JLoopCounter _ - | JStaticFieldValue _ + | JStaticFieldValue _ | JObjectFieldValue _ | JSize _ | JUninterpreted _ -> @@ -881,17 +889,17 @@ let rec bound_from_jterm is_lb jterm : cost_bound_t = | JPower (j, n) -> if n < 0 then raise (JCH_failure - (LBLOCK [STR "bound_from_jterm encountered negative power"; NL])) - else + (LBLOCK [STR "bound_from_jterm encountered negative power"; NL])) + else begin let c = bound_from_jterm is_lb j in - c#power c (mkNumerical n) + c#power c (mkNumerical n) end | JArithmeticExpr (JTimes, j1, j2) -> let c1 = bound_from_jterm is_lb j1 in let c2 = bound_from_jterm is_lb j2 in c1#mult c2 - | JArithmeticExpr (JDivide, j1, j2) -> + | JArithmeticExpr (JDivide, j1, j2) -> let c1 = bound_from_jterm is_lb j1 in let c2 = bound_from_jterm is_lb j2 in c1#div c2 @@ -902,7 +910,7 @@ let rec bound_from_jterm is_lb jterm : cost_bound_t = | JArithmeticExpr (JMinus, j1, j2) -> let c1 = bound_from_jterm is_lb j1 in let c2 = bound_from_jterm (not is_lb) j2 in - c1#sub c2 + c1#sub c2 | _ -> raise Exit let cost_bound_to_string (cbound:cost_bound_t):string = @@ -910,7 +918,7 @@ let cost_bound_to_string (cbound:cost_bound_t):string = | false -> "Sym" | true -> cbound#get_const#toString -module CostBoundCollections = CHCollections.Make +module CostBoundCollections = CHCollections.Make (struct type t = cost_bound_t let compare b1 b2 = b1#compare b2 diff --git a/CodeHawk/CHJ/jchcost/jCHCostBound.mli b/CodeHawk/CHJ/jchcost/jCHCostBound.mli index cd6f7886..91c587e5 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBound.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostBound.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -39,7 +40,7 @@ open JCHBasicTypesAPI open JCHCostUtils val dbg : bool ref - + class cost_bound_t : bool -> numerical_t JTermTableCollections.table_t -> numerical_t -> numerical_t -> @@ -90,17 +91,17 @@ class cost_bound_t : method write_xml : xml_element_int -> unit end -val bounds_from_linear_constraint : +val bounds_from_linear_constraint : (int * numerical_t JTermCollections.table_t) list -> JCHLinearConstraint.linear_constraint_t -> cost_bound_t list - + val cost_bound_from_num : bool -> numerical_t -> cost_bound_t val bound_from_jterm : bool -> jterm_t -> cost_bound_t val cost_bound_to_string : cost_bound_t -> string - + module CostBoundCollections : sig class set_t : diff --git a/CodeHawk/CHJ/jchcost/jCHCostBounds.ml b/CodeHawk/CHJ/jchcost/jCHCostBounds.ml index a0682bc9..1bb42c07 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBounds.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostBounds.ml @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -46,7 +46,7 @@ open JCHDictionary open JCHJTerm open JCHJTDictionary -(* jchsys *) +(* jchsys *) open JCHPrintUtils (* jchcost *) @@ -68,22 +68,22 @@ let st_inf_lb = ref false let st_inf_ub = ref false let set_st_bounds lbs ubs inf_lb inf_ub = st_lbs := lbs; - st_ubs := ubs ; - st_inf_lb := inf_lb ; + st_ubs := ubs; + st_inf_lb := inf_lb; st_inf_ub := inf_ub let get_st_bounds () = (!st_lbs, !st_ubs, !st_inf_lb, !st_inf_ub) let cost_var_name = "$cost$" - + let make_index_map boundss = - let terms = new JTermTableCollections.set_t in - + let terms = new JTermTableCollections.set_t in + let get_terms (b: cost_bound_t) = terms#addList b#get_terms#listOfKeys in - List.iter (fun bounds -> List.iter get_terms bounds) boundss; + List.iter (fun bounds -> List.iter get_terms bounds) boundss; let init_map = let t = new JTermCollections.table_t in - t#set (JAuxiliaryVar cost_var_name) numerical_one ; + t#set (JAuxiliaryVar cost_var_name) numerical_one; [(0, t)] in let mk_index_map ts = @@ -97,7 +97,7 @@ let get_linear_constraint_list (ubs: cost_bound_t list) = List.rev_append (List.map (fun b -> b#to_linear_constraint index_map) lbs) - (List.map (fun b -> b#to_linear_constraint index_map) ubs) + (List.map (fun b -> b#to_linear_constraint index_map) ubs) let mk_poly_stage @@ -113,13 +113,14 @@ let mk_poly_stage begin let index_map = make_index_map [lbs; ubs] in let constrs = get_linear_constraint_list index_map lbs ubs in - try + try let poly = JCHPoly.mk_poly_from_constraints true (constrs@extra_constrs) in (lbs, ubs, Some poly, index_map) with _ -> chlog#add "too many rays" - (LBLOCK [STR "proc "; INT !cmsix; NL; STR "constrs: "; pp_list constrs; NL]) ; + (LBLOCK [ + STR "proc "; INT !cmsix; NL; STR "constrs: "; pp_list constrs; NL]); (lbs, ubs, None, []) end | 1 -> @@ -128,7 +129,7 @@ let mk_poly_stage let ubs = List.map (fun b -> b#make_small_div) ubs in let index_map = make_index_map [lbs; ubs] in let constrs = get_linear_constraint_list index_map lbs ubs in - try + try let poly = JCHPoly.mk_poly_from_constraints true (constrs@extra_constrs) in (lbs, ubs, Some poly, index_map) with _ -> (lbs, ubs, None, []) @@ -142,15 +143,15 @@ let mk_poly_stage begin let pp = LBLOCK [STR "eliminated bound with large coefficients "; b#toPretty; NL] in - chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]) ; - pr__debug [STR "cost loss of precision "; pp] ; + chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]); + pr__debug [STR "cost loss of precision "; pp]; false end in let lbs = List.filter is_small lbs in let ubs = List.filter is_small ubs in let index_map = make_index_map [lbs; ubs] in let constrs = get_linear_constraint_list index_map lbs ubs in - try + try let poly = JCHPoly.mk_poly_from_constraints true (constrs@extra_constrs) in (lbs, ubs, Some poly, index_map) with _ -> (lbs, ubs, None, []) @@ -163,15 +164,15 @@ let mk_poly_stage else begin let pp = LBLOCK [STR "eliminated bound with more than 100 terms "; NL] in - chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]) ; - pr__debug [STR "cost loss of precision "; pp] ; + chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]); + pr__debug [STR "cost loss of precision "; pp]; false end in let lbs = List.filter has_few_terms lbs in let ubs = List.filter has_few_terms ubs in let index_map = make_index_map [lbs; ubs] in let constrs = get_linear_constraint_list index_map lbs ubs in - try + try let poly = JCHPoly.mk_poly_from_constraints true (constrs@extra_constrs) in (lbs, ubs, Some poly, index_map) @@ -179,25 +180,25 @@ let mk_poly_stage end | _ -> ([], [], Some JCHPoly.top_poly, []) - + let mk_poly stage (lbs: cost_bound_t list) (ubs: cost_bound_t list) extra_constrs = - if !dbg then pr__debug [STR "mk_poly "; pp_list lbs; pp_list ubs; NL] ; + if !dbg then pr__debug [STR "mk_poly "; pp_list lbs; pp_list ubs; NL]; let poly_opt = ref None in let lbs = ref lbs in let ubs = ref ubs in let index_map = ref [] in let stage = ref stage in - - while !poly_opt = None do + + while !poly_opt = None do let (ls, us, p_opt, i_map) = mk_poly_stage !stage !lbs !ubs extra_constrs in - check_cost_analysis_time (" while making poly in "^(string_of_int !cmsix)) ; - poly_opt := p_opt ; + check_cost_analysis_time (" while making poly in "^(string_of_int !cmsix)); + poly_opt := p_opt; lbs := ls; - ubs := us ; - index_map := i_map ; + ubs := us; + index_map := i_map; stage := !stage + 1 - done ; + done; (Option.get !poly_opt, !index_map, !lbs, !ubs, !stage) let eliminate_duplicates is_lb bounds = @@ -216,7 +217,7 @@ let eliminate_duplicates is_lb bounds = else new_bounds_with_pos_terms := bound :: !new_bounds_with_pos_terms in begin - List.iter add_bound bounds_with_pos_terms ; + List.iter add_bound bounds_with_pos_terms; !new_bounds_with_pos_terms @ other_bounds end @@ -226,29 +227,29 @@ class cost_bounds_t ~(inflb: bool) ~(infub: bool) ~(lbounds: cost_bound_t list) - ~(ubounds: cost_bound_t list) = + ~(ubounds: cost_bound_t list) = object (self : 'a) - + val bottom = ref bottom - (* infinite cost. Example: the time cost of a method that is a - * server ; inf_lb -> inf_ub - * An unknown cost is represented by top: not bottom or inf and + (* infinite cost. Example: the time cost of a method that is a + * server; inf_lb -> inf_ub + * An unknown cost is represented by top: not bottom or inf and * no lbounds or ubounds *) - val inf_lb = inflb + val inf_lb = inflb val inf_ub = infub - val lbs = + val lbs = if inflb then ref (new CostBoundCollections.set_t) else ref (CostBoundCollections.set_of_list lbounds) - + val ubs = if infub then ref (new CostBoundCollections.set_t) else ref (CostBoundCollections.set_of_list ubounds) initializer if simplify then - try + try let (lbs', ubs') = self#simplify lbounds ubounds in lbs := CostBoundCollections.set_of_list lbs'; ubs := CostBoundCollections.set_of_list ubs' @@ -256,22 +257,22 @@ object (self : 'a) (try let (lbs', _) = self#simplify lbounds [] in lbs := CostBoundCollections.set_of_list lbs' - with _ -> lbs := new CostBoundCollections.set_t) ; + with _ -> lbs := new CostBoundCollections.set_t); (try let (_, ubs') = self#simplify [] ubounds in ubs := CostBoundCollections.set_of_list ubs' - with _ -> ubs := new CostBoundCollections.set_t) - - + with _ -> ubs := new CostBoundCollections.set_t) + + (* used to set lbs, ubs *) method kind = begin - set_st_bounds !lbs !ubs inf_lb inf_ub ; + set_st_bounds !lbs !ubs inf_lb inf_ub; "?" end - + method isBottom = !bottom - + method isTop = (not !bottom && not inf_lb && not inf_ub && !lbs#isEmpty && !ubs#isEmpty) @@ -287,29 +288,29 @@ object (self : 'a) if inf_ub then STR "oo" else !ubs#toPretty; NL] method private mkBottom = - {< bottom = ref true ; + {< bottom = ref true; inf_lb = false; inf_ub = false; lbs = ref (new CostBoundCollections.set_t); ubs = ref (new CostBoundCollections.set_t) >} - + method private mkTop = {< bottom = ref false; - inf_lb = false; - inf_ub = false; + inf_lb = false; + inf_ub = false; lbs = ref (new CostBoundCollections.set_t); ubs = ref (new CostBoundCollections.set_t) >} method private mk_inf_lb = {< bottom = ref false; - inf_lb = true; - inf_ub = true; + inf_lb = true; + inf_ub = true; lbs = ref (new CostBoundCollections.set_t); ubs = ref (new CostBoundCollections.set_t) >} - + method private find_index (index_map: (int * numerical_t JTermCollections.table_t) list) - (term: numerical_t JTermCollections.table_t) = + (term: numerical_t JTermCollections.table_t) = try let comp = compare_tables jterm_compare compare_num in fst (List.find (fun (_, t) -> comp term t = 0) index_map) @@ -318,13 +319,13 @@ object (self : 'a) raise (JCH_failure (LBLOCK [ term#toPretty; STR " not found in JCHCostBounds.find_index" ])) - + method private simplify (lbs': cost_bound_t list) (ubs': cost_bound_t list) = - + (if !dbg then - pr__debug [STR "simplify "; pp_list lbs'; pp_list ubs'; NL]) ; - + pr__debug [STR "simplify "; pp_list lbs'; pp_list ubs'; NL]); + let (lbs', ubs') = (eliminate_duplicates true lbs', eliminate_duplicates false ubs') in let (poly, index_map, _, _, _) = mk_poly 0 lbs' ubs' [] in @@ -339,13 +340,13 @@ object (self : 'a) else begin (if !dbg then - pr_debug [STR "simplify poly = "; NL; poly#toPretty; NL]) ; - + pr_debug [STR "simplify poly = "; NL; poly#toPretty; NL]); + let constrs = poly#get_constraints in - + (if !dbg then - pr_debug [STR "constrs = "; pp_list constrs; NL]) ; - + pr_debug [STR "constrs = "; pp_list constrs; NL]); + let bounds = List.concat (List.map (bounds_from_linear_constraint index_map) constrs) in @@ -358,21 +359,21 @@ object (self : 'a) begin (if !dbg then pr_debug [STR "lbs_const = "; pp_list lbs_const; NL]); - + let sorted_consts = List.sort compare lbs_const in let pp = LBLOCK [STR "eliminated const bounds "; pp_list (List.tl sorted_consts); NL] in chlog#add "cost loss of precision" - (LBLOCK [STR (pretty_to_string pp)]) ; - - pr__debug [STR "cost loss of precision "; pp] ; - + (LBLOCK [STR (pretty_to_string pp)]); + + pr__debug [STR "cost loss of precision "; pp]; + (List.hd sorted_consts) :: lbs_not_const end in (if !dbg then - pr_debug [STR "lbs_list = "; pp_list lbs_list; NL]) ; - + pr_debug [STR "lbs_list = "; pp_list lbs_list; NL]); + let (ubs_const, ubs_not_const) = List.partition (fun b -> b#is_const) ubs_list in let ubs_list = @@ -384,28 +385,28 @@ object (self : 'a) pp_list (List.tl sorted_consts); NL] in chlog#add "cost loss of precision" - (LBLOCK [STR (pretty_to_string pp)]) ; - - pr__debug [STR "cost loss of precision "; pp] ; - + (LBLOCK [STR (pretty_to_string pp)]); + + pr__debug [STR "cost loss of precision "; pp]; + (if !dbg then pr_debug [STR "ubs_const = "; pp_list ubs_const; NL]); - + (List.hd sorted_consts) :: ubs_not_const end in (if !dbg then - pr_debug [STR "ubs_list = "; pp_list ubs_list; NL]) ; - + pr_debug [STR "ubs_list = "; pp_list ubs_list; NL]); + (lbs_list, ubs_list) end - + method private check_is_bottom (bs1: cost_bound_t list) (bs2: cost_bound_t list) = (if !dbg then - pr__debug [STR "check_is_bottom"; NL]) ; - + pr__debug [STR "check_is_bottom"; NL]); + let (poly, _, _, _, _) = mk_poly 0 bs1 bs2 [] in - poly#is_bottom + poly#is_bottom method private check_bounds_inclusion ~(upper_bounds:bool) @@ -423,7 +424,7 @@ object (self : 'a) self#check_is_bottom [b2#make_opposite] bs1 else self#check_is_bottom bs1 [b2#make_opposite] in - List.for_all check_one bs2 + List.for_all check_one bs2 method private get_bounds a = let _ = a#kind in @@ -433,21 +434,21 @@ object (self : 'a) let (albs, aubs, _, _) = self#get_bounds a in let set = new JTermCollections.set_t in let add_vars c = set#addSet c#get_jterms in - albs#iter add_vars ; - aubs#iter add_vars ; + albs#iter add_vars; + aubs#iter add_vars; set - + method equal (a: 'a) = - let (albs, aubs, ainf_lb, ainf_ub) = self#get_bounds a in + let (_albs, _aubs, ainf_lb, ainf_ub) = self#get_bounds a in match (!bottom, a#isBottom) with - | (true, true) + | (true, true) | (false, false) -> (inf_lb == ainf_lb) && (inf_ub == ainf_ub) && self#leq a && a#leq self | _ -> false - + method leq (a: 'a) = let (albs, aubs, ainf_lb, ainf_ub) = self#get_bounds a in - match (!bottom, a#isBottom) with + match (!bottom, a#isBottom) with | (true, _) -> true | (_, true) -> false | (false, false) -> @@ -465,12 +466,12 @@ object (self : 'a) ~inf2:ainf_ub) method meet (a: 'a) = - + (if !dbg then pr__debug [STR "meet "; NL; STR " "; self#toPretty; NL; - STR " "; a#toPretty; NL]) ; - - let (albs, aubs, ainf_lb, ainf_ub) = self#get_bounds a in + STR " "; a#toPretty; NL]); + + let (albs, aubs, ainf_lb, _ainf_ub) = self#get_bounds a in match (!bottom, a#isBottom, inf_lb, ainf_lb) with | (true, _, _, _) -> self#mkBottom | (_, true, _, _) -> self#mkBottom @@ -486,13 +487,13 @@ object (self : 'a) mk_poly 0 new_lbs#toList new_ubs#toList [] in self#mk_from_poly index_map poly false - (* adds only one constant bound *) + (* adds only one constant bound *) method private mk_bound_set_from_list lb list = let set = new CostBoundCollections.set_t in let const_bound = ref None in - + let is_smaller (c, d) (c1, d1) = (c#mult d1)#leq (c1#mult d) in - + let add_element b = if b#is_const then match !const_bound with @@ -500,16 +501,16 @@ object (self : 'a) let (c, d) = (b#get_const, b#get_div) in if lb then if is_smaller (c, d) (c1, d1) then () - else + else begin - const_bound := Some (b, c, d) ; + const_bound := Some (b, c, d); set#remove b1; set#add b end else if is_smaller (c, d) (c1, d1) then begin - const_bound := Some (b, c, d) ; + const_bound := Some (b, c, d); set#remove b1; set#add b end @@ -524,49 +525,49 @@ object (self : 'a) set#add b in begin - List.iter add_element list ; + List.iter add_element list; set end - + method private mk_from_poly index_map poly inf_ub = - + (if !dbg then - pr__debug [STR "mk_from_poly "; NL]) ; - + pr__debug [STR "mk_from_poly "; NL]); + if poly#is_bottom then self#mkBottom else begin let constrs = poly#get_constraints in let poly_index_map = poly#get_index_map in - + (if !dbg then pr__debug [STR "poly_index_map = "; - pp_assoc_list_ints poly_index_map; NL]) ; - + pp_assoc_list_ints poly_index_map; NL]); + (if !dbg then pr__debug [STR "index_map = "; pp_list_int (List.map fst index_map); - STR " "; pp_list (List.map snd index_map); NL]) ; - + STR " "; pp_list (List.map snd index_map); NL]); + let eq_constrs = List.filter (fun c -> c#is_const_equality) constrs in let eq_inds = ref [] in let new_index_map = ref index_map in let add_eq (constr: JCHLinearConstraint.linear_constraint_t) = - if !dbg then pr__debug [STR "add_eq "; constr#toPretty; NL] ; + if !dbg then pr__debug [STR "add_eq "; constr#toPretty; NL]; let (pairs, _) = constr#get_pairs_const in let (ind, _) = List.hd pairs in if ind != 0 then begin - + (if !dbg then - pr__debug [STR "ind = "; INT ind; NL]) ; - - eq_inds := ind :: !eq_inds ; + pr__debug [STR "ind = "; INT ind; NL]); + + eq_inds := ind :: !eq_inds; new_index_map := List.filter (fun (i, _) -> i != ind) !new_index_map end in - List.iter add_eq eq_constrs ; + List.iter add_eq eq_constrs; let res_poly = poly#project_out !eq_inds in let constrs = res_poly#get_constraints in let bounds = @@ -579,7 +580,7 @@ object (self : 'a) inf_ub = true; lbs = ref (self#mk_bound_set_from_list true lbs); ubs = ref (new CostBoundCollections.set_t) >} - else + else {< bottom = ref false; inf_lb = false; inf_ub = false; @@ -588,14 +589,14 @@ object (self : 'a) end (* assume that the cost bounds have only one lower and upper bound each - * and that these upper and lower bounds have positive coefficients and + * and that these upper and lower bounds have positive coefficients and * positive terms *) method join (a: 'a) = - + (if !dbg then pr__debug [STR "join "; NL; STR " "; self#toPretty; NL; - STR " "; a#toPretty; NL]) ; - + STR " "; a#toPretty; NL]); + let (albs, aubs, ainf_lb, ainf_ub) = self#get_bounds a in match (!bottom, a#isBottom, self#isTop, a#isTop, inf_lb, ainf_lb) with | (true, _, _, _, _, _) -> a @@ -606,7 +607,7 @@ object (self : 'a) | (false, false, false, false, _, true) -> self#mk_inf_lb | (false, false, false, false, false, false) -> let new_inf_ub = inf_ub || ainf_ub in - + let (lbs, ubs, albs, aubs) = if new_inf_ub then (!lbs#toList, [], albs#toList, []) @@ -619,34 +620,34 @@ object (self : 'a) pp_list (List.tl albs); NL] in chlog#add "cost loss of precision" - (LBLOCK [STR (pretty_to_string pp)]) ; - - pr__debug [STR "cost loss of precision "; pp] ; - end ; + (LBLOCK [STR (pretty_to_string pp)]); + + pr__debug [STR "cost loss of precision "; pp]; + end; if (List.length aubs) > 1 then begin let pp = LBLOCK [STR "ignored bound in join "; pp_list (List.tl aubs); NL] in chlog#add "cost loss of precision" - (LBLOCK [STR (pretty_to_string pp)]) ; - - pr__debug [STR "cost loss of precision "; pp] ; - end ; + (LBLOCK [STR (pretty_to_string pp)]); + + pr__debug [STR "cost loss of precision "; pp]; + end; let rlb = (List.hd lbs)#simple_join (List.hd albs) in let rub = (List.hd ubs)#simple_join (List.hd aubs) in {< bottom = ref false; inf_lb = false; inf_ub = false; lbs = ref (CostBoundCollections.set_of_list [rlb]); - ubs = ref (CostBoundCollections.set_of_list [rub]) >} - + ubs = ref (CostBoundCollections.set_of_list [rub]) >} + method widening (a: 'a) = - + (if !dbg then pr__debug [STR "widening "; NL; STR " "; self#toPretty; NL; - STR " "; a#toPretty; NL]) ; - + STR " "; a#toPretty; NL]); + let (albs, aubs, ainf_lb, ainf_ub) = self#get_bounds a in match (!bottom, a#isBottom, self#isTop, a#isTop, inf_lb, ainf_lb) with | (true, _, _, _, _, _) -> a @@ -694,12 +695,12 @@ object (self : 'a) ~bs2:bs ~inf1:false ~inf2:false) aubs in - {< bottom = ref false ; + {< bottom = ref false; inf_lb = false; inf_ub = false; - lbs = ref (CostBoundCollections.set_of_list (lbs_i @ albs_i)) ; + lbs = ref (CostBoundCollections.set_of_list (lbs_i @ albs_i)); ubs = ref (CostBoundCollections.set_of_list (ubs_i @ aubs_i)) >} - + method narrowing (a: 'a) = self#meet a @@ -707,7 +708,7 @@ object (self : 'a) match (!bottom, inf_lb) with | (true, _) -> EVX_STRING "_|_" | (_, true) -> EVX_STRING "oo" - | _ -> + | _ -> EVX_LIST [ EVX_LIST (List.map (fun b -> b#to_evx) !lbs#toList); EVX_LIST (List.map (fun b -> b#to_evx) !ubs#toList)] @@ -723,7 +724,7 @@ let bottom_cost_bounds = ~infub:false ~lbounds:[] ~ubounds:[] - + let top_cost_bounds = new cost_bounds_t ~bottom:false @@ -732,7 +733,7 @@ let top_cost_bounds = ~infub:false ~lbounds:[] ~ubounds:[] - + let cost_bounds_from_num n = new cost_bounds_t ~bottom:false @@ -751,17 +752,17 @@ let inf_lb_cost_bounds = ~lbounds:[] ~ubounds:[] -let cost_var = +let _cost_var = let name = new symbol_t ~atts:["num"] "$cost$" in new variable_t name NUM_VAR_TYPE -let cost_jterm = JAuxiliaryVar "$cost$" +let _cost_jterm = JAuxiliaryVar "$cost$" let cost_bounds_from_jterm_range (r: jterm_range_int) = - + (if !dbg then pr__debug [STR "cost_bounds_from_jterm_range "; NL; r#toPretty; NL]); - + let lbounds = r#get_lowerbounds in let ubounds = r#get_upperbounds in let lower_cost_bounds = List.map (bound_from_jterm true) lbounds in @@ -773,7 +774,7 @@ let cost_bounds_from_jterm_range (r: jterm_range_int) = ~infub:false ~lbounds:lower_cost_bounds ~ubounds:upper_cost_bounds - + let get_bounds (bounds: cost_bounds_t) = let _ = bounds#kind in begin @@ -781,17 +782,17 @@ let get_bounds (bounds: cost_bounds_t) = end let add_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = - + (if !dbg then pr__debug [STR "add_cost_bounds "; NL; STR " "; s#toPretty; STR " "; a#toPretty; NL]); - + let (slbs, subs, sinf_lb, sinf_ub) = get_bounds s in let (albs, aubs, ainf_lb, ainf_ub) = get_bounds a in match (s#isBottom, a#isBottom, sinf_lb, ainf_lb) with | (true, _, _, _) -> bottom_cost_bounds | (_, true, _, _) -> bottom_cost_bounds - | (false, false, true, _) + | (false, false, true, _) | (false, false, _, true) -> inf_lb_cost_bounds | (false, false, false, false) -> let new_inf_ub = sinf_ub || ainf_ub in @@ -812,13 +813,13 @@ let add_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = add_bounds true slbs albs; if not new_inf_ub then add_bounds false subs aubs; - + (if !dbg then pr__debug [STR "new_lbs = "; pp_list !new_lbs; NL]); - + (if !dbg then pr__debug [STR "new_ubs = "; pp_list !new_ubs; NL]); - + new cost_bounds_t ~bottom:false ~simplify:false @@ -832,7 +833,7 @@ let add_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = let neg_cost_bounds (s: cost_bounds_t) = if s#isBottom then bottom_cost_bounds else - let (slbs, subs, inf_lb, inf_ub) = get_bounds s in + let (slbs, subs, _inf_lb, _inf_ub) = get_bounds s in let new_lbs = List.map (fun ub -> ub#neg) subs#toList in let new_ubs = List.map (fun lb -> lb#neg) slbs#toList in new cost_bounds_t @@ -842,22 +843,22 @@ let neg_cost_bounds (s: cost_bounds_t) = ~infub:false ~lbounds:new_lbs ~ubounds:new_ubs - -let sub_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = + +let _sub_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = add_cost_bounds s (neg_cost_bounds a) let mult_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = - + (if !dbg then pr__debug [STR "mult_cost_bouds "; NL; STR " "; s#toPretty; NL; - STR " "; a#toPretty; NL]) ; - + STR " "; a#toPretty; NL]); + let (slbs, subs, sinf_lb, sinf_ub) = get_bounds s in let (albs, aubs, ainf_lb, ainf_ub) = get_bounds a in match (s#isBottom, a#isBottom, sinf_lb, ainf_lb) with | (true, _, _, _) -> bottom_cost_bounds | (_, true, _, _) -> bottom_cost_bounds - | (false, false, true, _) + | (false, false, true, _) | (false, false, _, true) -> inf_lb_cost_bounds | (false, false, _, _) -> let new_inf_ub = sinf_ub || ainf_ub in @@ -878,7 +879,7 @@ let mult_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = begin mult_bounds false subs aubs; mult_bounds false aubs subs - end) ; + end); new cost_bounds_t ~bottom:false ~simplify:false @@ -890,7 +891,7 @@ let mult_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = let div_cost_bounds (s: cost_bounds_t) (a: cost_bounds_t) = let (slbs, subs, sinf_lb, sinf_ub) = get_bounds s in - let (albs, aubs, ainf_lb, ainf_ub) = get_bounds a in + let (albs, aubs, _ainf_lb, _ainf_ub) = get_bounds a in match (s#isBottom, a#isBottom, sinf_lb) with | (true, _, _) -> bottom_cost_bounds | (_, true, _) -> bottom_cost_bounds @@ -929,19 +930,19 @@ let write_xml_bounds ?(tag="ijtr") (s:cost_bounds_t) (node:xml_element_int) = let (lbs,ubs, inf_lb, inf_ub) = get_bounds s in let bool_to_str b = if b then "true" else "false" in - node#setAttribute "bottom" (bool_to_str s#isBottom) ; - node#setAttribute "inf_lb" (bool_to_str inf_lb) ; - node#setAttribute "inf_ub" (bool_to_str inf_ub) ; + node#setAttribute "bottom" (bool_to_str s#isBottom); + node#setAttribute "inf_lb" (bool_to_str inf_lb); + node#setAttribute "inf_ub" (bool_to_str inf_ub); let lbs = List.map (fun b -> b#to_jterm) lbs#toList in let ubs = List.map (fun b -> b#to_jterm) ubs#toList in jtdictionary#write_xml_jterm_range ~tag node lbs ubs let write_xml_atlas_bounds (node:xml_element_int) (ms:method_signature_int) (b:cost_bounds_t) = - let (lbs,ubs,inf_lb,inf_ub) = get_bounds b in + let (lbs, ubs, _inf_lb, _inf_ub) = get_bounds b in let lbs = List.map (fun b -> b#to_jterm) lbs#toList in let ubs = List.map (fun b -> b#to_jterm) ubs#toList in - let jtrange = mk_jterm_range lbs ubs in + let jtrange = mk_jterm_range lbs ubs in let set = node#setAttribute in let sety tag v = if v then set tag "yes" else () in let _ = sety "bottom" b#isBottom in @@ -951,24 +952,24 @@ let write_xml_atlas_bounds begin (match jtrange#get_lowerbounds with | [ JConstant n ] -> set "lb" n#toString - | _ -> ()) ; + | _ -> ()); (match jtrange#get_upperbounds with | [ JConstant n ] -> set "ub" n#toString - | _ -> ()) ; + | _ -> ()); (match jtrange#to_jterm with | Some t when (depth_of_jterm t) < 6 -> node#appendChildren [ jterm_to_xmlx t ms ] | _ -> ()) end - - + + let bounds_from_jterms simplify lb_jterms ub_jterms = - + (if !dbg then - pr__debug [ STR "bounds_from_jterms "; pp_bool simplify; + pr__debug [ STR "bounds_from_jterms "; pp_bool simplify; pp_list_jterm lb_jterms; STR " "; - pp_list_jterm ub_jterms; NL]) ; - + pp_list_jterm ub_jterms; NL]); + let lbs = List.map (fun j -> bound_from_jterm true j) lb_jterms in let ubs = List.map (fun j -> bound_from_jterm false j) ub_jterms in new cost_bounds_t @@ -996,7 +997,7 @@ let subst_in_cost_bounds ~(use_one_bound: bool) ~(lmap: (jterm_t * cost_bound_t list) list) ~(umap: (jterm_t * cost_bound_t list) list) - ~(inf_lbs : jterm_t list) + ~(inf_lbs : jterm_t list) ~(inf_ubs : jterm_t list) ~(subst_only_local_vars: bool) ~(subst_only_lps: bool) @@ -1004,23 +1005,23 @@ let subst_in_cost_bounds let get_best_bounds lower_bounds (bs:cost_bound_t list):cost_bound_t list = - + (if !dbg then pr__debug [STR "get_best_bounds "; pretty_print_list - bs (fun b -> STR b#to_string) "{" "; " "}"; NL]) ; - + bs (fun b -> STR b#to_string) "{" "; " "}"; NL]); + let bounds = eliminate_duplicates lower_bounds bs in - + (if !dbg then pr__debug [ STR "bounds = "; pretty_print_list - bounds (fun b -> STR b#to_string) "{" "; " "}"; NL]) ; - + bounds (fun b -> STR b#to_string) "{" "; " "}"; NL]); + if List.length bounds < 2 then bounds else - let res_bounds = + let res_bounds = let (bs, ignored_bs) = let (neg_bs, pos_bs) = List.partition (fun b -> b#has_negative_coefficient) bounds in @@ -1039,7 +1040,7 @@ let subst_in_cost_bounds || jterm_compare j sym_max_long = 0) b#get_jterms#toList in let (bs_with_max, bs_wo_max) = List.partition has_max bs in if bs_wo_max <> [] then bs_wo_max else bs_with_max in - let (kept_bs, ignored_bs) = + let (kept_bs, ignored_bs) = if List.length bs < 2 then (bs, ignored_bs) else @@ -1055,29 +1056,31 @@ let subst_in_cost_bounds (retrieve_cms !cmsix)#class_method_signature_string in let pp = LBLOCK [ STR method_name; STR " @ "; INT pc; NL; - STR " used bound "; STR (List.hd bs)#to_string; NL; + STR " used bound "; + STR (List.hd bs)#to_string; NL; STR " ignored "; pretty_print_list - ignored_bs (fun b -> STR b#to_string) "{" "; " "}"; NL] in + ignored_bs + (fun b -> STR b#to_string) "{" "; " "}"; NL] in chlog#add "cost loss of precision" - (LBLOCK [STR (pretty_to_string pp)]) ; - + (LBLOCK [STR (pretty_to_string pp)]); + pr__debug [STR "cost loss of precision "; pp] - - end ; - kept_bs + + end; + kept_bs end in res_bounds in let (lbs, ubs, inf_lb, inf_ub) = get_bounds cost_bounds in - + (if !dbg then begin pr__debug [STR "after add_consts, subst_in_cost_bounds "; pp_bool subst_only_local_vars; STR " "; pp_bool subst_only_lps; NL; - cost_bounds#toPretty; NL] ; + cost_bounds#toPretty; NL]; pr__debug [STR "lmap: "; NL]; List.iter (fun (jt, ls) -> @@ -1086,13 +1089,13 @@ let subst_in_cost_bounds List.iter (fun (jt, ls) -> pr__debug [jterm_to_pretty jt; STR ": "; pp_list ls; NL]) umap - end) ; - + end); + if cost_bounds#isBottom || inf_lb then cost_bounds else begin - + (if !dbg then begin let pr_list is_lb (jterm, cbs) = @@ -1101,8 +1104,8 @@ let subst_in_cost_bounds pp_list cbs; NL] in List.iter (pr_list true) lmap; List.iter (pr_list false) umap - end) ; - + end); + let has_inf_jterm is_lb (bound: cost_bound_t) = let jts = bound#get_jterms in let infs = if is_lb then inf_lbs else inf_ubs in @@ -1116,7 +1119,7 @@ let subst_in_cost_bounds JCHCostUtils.no_local_vars else if subst_only_lps then JCHCostUtils.no_loop_costs - else + else let lcs_with_ubounds = JTermCollections.set_of_list (List.map @@ -1124,44 +1127,44 @@ let subst_in_cost_bounds (List.filter (fun (jt, bs) -> (is_sym_lc jt && bs != [])) umap)) in if subst_all then - JCHCostUtils.no_cost_calls_or_lcs lcs_with_ubounds + JCHCostUtils.no_cost_calls_or_lcs lcs_with_ubounds else JCHCostUtils.no_calls_or_lcs lcs_with_ubounds in (if !dbg then pr__debug [STR "lbs = "; lbs#toPretty; NL]); - + (if !dbg then pr__debug [STR "ubs = "; ubs#toPretty; NL]); - + let (lbs_t, lbs_f) = List.partition - (fun b -> b#has_only_jterms_to_keep is_jterm_to_keep) lbs#toList in + (fun b -> b#has_only_jterms_to_keep is_jterm_to_keep) lbs#toList in let (ubs_t, ubs_f) = List.partition (fun b -> b#has_only_jterms_to_keep is_jterm_to_keep) ubs#toList in - + (if !dbg then - pr__debug [STR "lbs_with_jterms_to_remove = "; pp_list lbs_f; NL]) ; - + pr__debug [STR "lbs_with_jterms_to_remove = "; pp_list lbs_f; NL]); + (if !dbg then - pr__debug [STR "ubs_with_jterms_to_remove = "; pp_list ubs_f; NL]) ; + pr__debug [STR "ubs_with_jterms_to_remove = "; pp_list ubs_f; NL]); let mk_list mp = let choices : ((jterm_t * 'a) list list) ref = ref [] in let add_choice (j, bs) = - + (if !dbg && (List.length bs > 1) then pr__debug [STR "mk_list "; jterm_to_pretty j; - STR " "; pp_list bs; NL]) ; - - let add_to_choice choice : ((jterm_t * 'a) list list) = + STR " "; pp_list bs; NL]); + + let add_to_choice choice : ((jterm_t * 'a) list list) = List.map (fun b -> (j,b) :: choice) bs in choices := if !choices = [] then - (List.map (fun b -> [(j,b)]) bs) + (List.map (fun b -> [(j,b)]) bs) else List.concat (List.map add_to_choice !choices) in - List.iter add_choice (List.filter (fun (_, ls) -> ls != []) mp) ; + List.iter add_choice (List.filter (fun (_, ls) -> ls != []) mp); !choices in let lchoices = let lmap = @@ -1180,7 +1183,7 @@ let subst_in_cost_bounds (if !dbg then pr__debug [STR "lchoices size = "; INT (List.length lchoices); NL]); - + (if !dbg then pr__debug [STR "uchoices size = "; INT (List.length uchoices); NL]); @@ -1197,7 +1200,7 @@ let subst_in_cost_bounds List.flatten (List.map (fun pos_b -> List.map (fun neg_b -> pos_b#sub neg_b) new_bs_neg) new_bs_pos) in - + let new_lbs = List.map (subst_in_bound lchoices uchoices) lbs_f in let new_lbs = List.concat (lbs_t :: new_lbs) in let new_ubs = List.map (subst_in_bound uchoices lchoices) ubs_f in @@ -1213,28 +1216,28 @@ let subst_in_cost_bounds let pos_jterm_table = new JTermCollections.table_t -(* jterm -> cost bounds for jterm dependent on +(* jterm -> cost bounds for jterm dependent on * sym_cost's, sym_call's, sym_lp's and sym_lc's *) - + let pos_jterm_table_final = new JTermCollections.table_t (* jterm -> cost bounds for jterm dependent only on sym_lc's *) let is_const_range cost_bounds = - + (if !dbg then pr__debug [STR "is_const_range "; cost_bounds#toPretty; NL]); - - let res = - let (lbs, ubs, inf_lb, inf_ub) = get_bounds cost_bounds in + + let res = + let (lbs, ubs, _inf_lb, _inf_ub) = get_bounds cost_bounds in match (lbs#toList, ubs#toList) with | ([lb], [ub]) -> lb#is_const && ub#is_const | _ -> false in - + (if !dbg then - pr__debug [STR "is_const_range res = "; pp_bool res; NL]) ; + pr__debug [STR "is_const_range res = "; pp_bool res; NL]); res - - + + let get_jterms cost_bounds = let (lbs, ubs, _, _) = get_bounds cost_bounds in let set = new JTermCollections.set_t in @@ -1242,16 +1245,16 @@ let get_jterms cost_bounds = begin lbs#iter add_bound; ubs#iter add_bound; - set#toList + set#toList end let subst_pos_bounds_ pc cost_bounds only_lps use_pos_jterm_final = - + (if !dbg then pr_debug [STR "subst_pos_bounds_ "; pp_bool only_lps; STR " "; pp_bool use_pos_jterm_final; NL; - cost_bounds#toPretty; NL]) ; - + cost_bounds#toPretty; NL]); + if is_const_range cost_bounds then cost_bounds else @@ -1263,10 +1266,10 @@ let subst_pos_bounds_ pc cost_bounds only_lps use_pos_jterm_final = let jterm_table = if use_pos_jterm_final then pos_jterm_table_final else pos_jterm_table in - + (if !dbg then - pr__debug [STR "jterm_table = "; NL; jterm_table#toPretty; NL]) ; - + pr__debug [STR "jterm_table = "; NL; jterm_table#toPretty; NL]); + let add_jt jterm = if only_lps && not (is_sym_lp jterm) then () @@ -1278,12 +1281,12 @@ let subst_pos_bounds_ pc cost_bounds only_lps use_pos_jterm_final = begin lbounds := (jterm, lbs#toList) :: !lbounds; ubounds := (jterm, ubs#toList) :: !ubounds; - (if inf_lb then inf_lbs := jterm :: !inf_lbs) ; + (if inf_lb then inf_lbs := jterm :: !inf_lbs); (if inf_ub then inf_ubs := jterm :: !inf_ubs) end | _ -> () end in - List.iter add_jt (get_jterms cost_bounds) ; + List.iter add_jt (get_jterms cost_bounds); subst_in_cost_bounds ~pc ~cost_bounds @@ -1294,12 +1297,12 @@ let subst_pos_bounds_ pc cost_bounds only_lps use_pos_jterm_final = ~inf_ubs:!inf_ubs ~subst_only_local_vars:false ~subst_only_lps:only_lps - ~subst_all:use_pos_jterm_final + ~subst_all:use_pos_jterm_final end let subst_pos_bounds pc cost_bounds only_lps = subst_pos_bounds_ pc cost_bounds only_lps false - + let subst_pos_bounds_final pc cost_bounds = subst_pos_bounds_ pc cost_bounds false true @@ -1308,7 +1311,7 @@ let subst_local_vars (cost_bounds: cost_bounds_t) (lmap: (jterm_t * cost_bound_t list) list) (umap: (jterm_t * cost_bound_t list) list):cost_bounds_t = - + (if !dbg then begin pr__debug [STR "subst_local_vars "; cost_bounds#toPretty; NL]; @@ -1318,8 +1321,8 @@ let subst_local_vars pr__debug [STR "umap = "; NL]; List.iter (fun (jt, cs) -> pr__debug [jterm_to_pretty jt; STR ": "; pp_list cs; NL]) umap; - end) ; - + end); + if lmap = [] && umap = [] then cost_bounds else if is_const_range cost_bounds then @@ -1328,26 +1331,26 @@ let subst_local_vars begin let (lbs, ubs, inf_lb, inf_ub) = get_bounds cost_bounds in let (lbs, ubs) = (lbs#toList, ubs#toList) in - + (if !dbg then begin pr__debug [STR "lbs = "; pp_list lbs; NL]; - pr__debug [STR "ubs = "; pp_list ubs; NL] - end) ; - + pr__debug [STR "ubs = "; pp_list ubs; NL] + end); + let new_lbs = List.filter (fun b -> b#is_local_var_linear) lbs in let new_ubs = List.filter (fun b -> b#is_local_var_linear) ubs in - + (if !dbg then begin pr__debug [STR "new_lbs = "; pp_list new_lbs; NL]; - pr__debug [STR "new_ubs = "; pp_list new_ubs; NL] - end) ; - + pr__debug [STR "new_ubs = "; pp_list new_ubs; NL] + end); + if List.length new_lbs < List.length lbs || List.length new_ubs < List.length ubs then begin - + (if !dbg then begin pr__debug [STR "subst_local_vars lost precision"; @@ -1361,8 +1364,8 @@ let subst_local_vars pr__debug [jterm_to_pretty jt; STR ": "; pp_list ls; NL]) umap end) - end ; - + end; + let new_cost_bounds = new cost_bounds_t ~bottom:cost_bounds#isBottom @@ -1385,26 +1388,26 @@ let subst_local_vars end let add_pos_jterm pc jterm (bounds: cost_bounds_t) = - + (if !dbg then pr__debug [STR "JCHCostBounds.add_jterm "; jterm_to_pretty jterm; NL; - bounds#toPretty; NL]) ; - - pos_jterm_table#set jterm bounds ; + bounds#toPretty; NL]); + + pos_jterm_table#set jterm bounds; let bounds_final = subst_pos_bounds_ pc bounds false true in pos_jterm_table_final#set jterm bounds_final let add_pos_jterm_final pc jterm (bounds: cost_bounds_t) = let bounds_final = subst_pos_bounds_ pc bounds false true in - pos_jterm_table_final#set jterm bounds_final ; + pos_jterm_table_final#set jterm bounds_final; bounds_final let make_small_divs cost_bounds = - + (if !dbg then - pr__debug [STR "make_small_divs "; NL; cost_bounds#toPretty; NL]) ; - - let res = + pr__debug [STR "make_small_divs "; NL; cost_bounds#toPretty; NL]); + + let res = let (lbs, ubs, inf_lb, inf_ub) = get_bounds cost_bounds in let new_lbs = List.map (fun c -> c#make_small_div) lbs#toList in let new_ubs = List.map (fun c -> c#make_small_div) ubs#toList in @@ -1415,19 +1418,19 @@ let make_small_divs cost_bounds = ~infub:inf_ub ~lbounds:new_lbs ~ubounds:new_ubs in - + (if !dbg then - pr__debug [STR "make_small_divs res "; NL; res#toPretty; NL]) ; - + pr__debug [STR "make_small_divs res "; NL; res#toPretty; NL]); + res - + let find_const_lb (for_lbs: bool) cost_bounds = - + (if !dbg then - pr_debug [STR "find_const_lb "; pp_bool for_lbs ; NL; - cost_bounds#toPretty; NL]) ; - + pr_debug [STR "find_const_lb "; pp_bool for_lbs; NL; + cost_bounds#toPretty; NL]); + let (lbs, ubs, _, _) = get_bounds cost_bounds in let bs = if for_lbs then lbs else ubs in let const_lb = ref None in @@ -1438,52 +1441,52 @@ let find_const_lb (for_lbs: bool) cost_bounds = const_lb := Some (n, d) | (Some (n, d), _) -> const_lb := Some (n, d) | (None, _) -> const_lb := None in - List.iter check_lb bs#toList ; + List.iter check_lb bs#toList; match !const_lb with | Some (n, d) -> n#modulo d - | None -> numerical_zero + | None -> numerical_zero let mk_from_poly index_map poly inf_ub = - + (if !dbg then - pr__debug [STR "mk_from_poly "; NL]) ; - + pr__debug [STR "mk_from_poly "; NL]); + if poly#is_bottom then bottom_cost_bounds else begin let constrs = poly#get_constraints in let poly_index_map = poly#get_index_map in - + (if !dbg then pr__debug [STR "poly_index_map = "; - pp_assoc_list_ints poly_index_map; NL]) ; - + pp_assoc_list_ints poly_index_map; NL]); + (if !dbg then pr__debug [STR "index_map = "; pp_list_int (List.map fst index_map); - STR " "; pp_list (List.map snd index_map); NL]) ; - + STR " "; pp_list (List.map snd index_map); NL]); + let eq_constrs = List.filter (fun c -> c#is_const_equality) constrs in let eq_inds = ref [] in let new_index_map = ref index_map in let add_eq (constr: JCHLinearConstraint.linear_constraint_t) = - + (if !dbg then - pr__debug [STR "add_eq "; constr#toPretty; NL]) ; - + pr__debug [STR "add_eq "; constr#toPretty; NL]); + let (pairs, _) = constr#get_pairs_const in let (ind, _) = List.hd pairs in if ind != 0 then begin - + (if !dbg then - pr__debug [STR "ind = "; INT ind; NL]) ; - - eq_inds := ind :: !eq_inds ; + pr__debug [STR "ind = "; INT ind; NL]); + + eq_inds := ind :: !eq_inds; new_index_map := List.filter (fun (i, _) -> i != ind) !new_index_map end in - List.iter add_eq eq_constrs ; + List.iter add_eq eq_constrs; let res_poly = poly#project_out !eq_inds in let constrs = res_poly#get_constraints in let bounds = @@ -1497,7 +1500,7 @@ let mk_from_poly index_map poly inf_ub = ~inflb:false ~infub:true ~lbounds:lbs - ~ubounds:[] + ~ubounds:[] else new cost_bounds_t ~bottom:false @@ -1510,35 +1513,35 @@ let mk_from_poly index_map poly inf_ub = (* join strategy *) let rec join_stages (lbs1, ubs1, stage1) (lbs2, ubs2, stage2) new_inf_ub = - + (if !dbg then pr__debug [STR "join_stages "; INT stage1; STR " "; INT stage2; NL; - pp_list ubs1; NL; pp_list ubs1; NL]) ; - + pp_list ubs1; NL; pp_list ubs1; NL]); + let index_map = make_index_map [lbs1; ubs1; lbs2; ubs2] in let make_lin_constrs map = let var_constrs = ref [] in - let make_lin_constr (i, term) = - if List.for_all (fun jt -> is_pos_jterm jt) term#listOfKeys then + let make_lin_constr (i, term) = + if List.for_all (fun jt -> is_pos_jterm jt) term#listOfKeys then var_constrs := (new JCHLinearConstraint.linear_constraint_t false [(i, unit_big_int)] zero_big_int) :: !var_constrs in begin - List.iter make_lin_constr map ; + List.iter make_lin_constr map; !var_constrs end in - - (* make polys first. If this runs into trouble, then some constraints + + (* make polys first. If this runs into trouble, then some constraints * are changed or eliminated *) let var_constrs = make_lin_constrs index_map in - let (poly1, _, new_lbs1, new_ubs1, new_stage1) = + let (_poly1, _, new_lbs1, new_ubs1, new_stage1) = mk_poly stage1 lbs1 ubs1 var_constrs in - let (poly2, _, new_lbs2, new_ubs2, new_stage2) = + let (_poly2, _, new_lbs2, new_ubs2, new_stage2) = mk_poly stage2 lbs2 ubs2 var_constrs in - (* Start from the beginning, with fewer constraints and variables. mk_poly + (* Start from the beginning, with fewer constraints and variables. mk_poly * is guaranteed to work for both constrs1 ans constrs2 *) let new_index_map = make_index_map [new_lbs1; new_ubs1; new_lbs2; new_ubs2] in @@ -1547,26 +1550,26 @@ let rec join_stages (lbs1, ubs1, stage1) (lbs2, ubs2, stage2) new_inf_ub = let constrs1 = List.rev_append (get_linear_constraint_list index_map lbs1 ubs1) new_var_constrs in - + (if !dbg then - pr__debug [STR "constrs1 = "; pp_list constrs1; NL]) ; - + pr__debug [STR "constrs1 = "; pp_list constrs1; NL]); + let constrs2 = List.rev_append (get_linear_constraint_list index_map lbs2 ubs2) new_var_constrs in - + (if !dbg then - pr__debug [STR "constrs2 = "; pp_list constrs2; NL]) ; + pr__debug [STR "constrs2 = "; pp_list constrs2; NL]); let poly1 = JCHPoly.mk_poly_from_constraints true constrs1 in let poly2 = JCHPoly.mk_poly_from_constraints true constrs2 in try let join_poly = poly1#join poly2 in mk_from_poly new_index_map join_poly new_inf_ub - with _ -> + with _ -> if stage1 = stage2 then if stage1 = 3 then - mk_from_poly new_index_map JCHPoly.top_poly new_inf_ub + mk_from_poly new_index_map JCHPoly.top_poly new_inf_ub else join_stages (new_lbs1, new_ubs1, new_stage1) @@ -1585,11 +1588,11 @@ let rec join_stages (lbs1, ubs1, stage1) (lbs2, ubs2, stage2) new_inf_ub = (* a join that does not depend on the assumptions for the JCHCostBounds.join *) let full_join cost_bounds1 cost_bounds2 = - + (if !dbg then pr__debug [STR "full_join "; cost_bounds1#toPretty; NL; - cost_bounds2#toPretty; NL]) ; - + cost_bounds2#toPretty; NL]); + let (lbs1, ubs1, inf_lb1, inf_ub1) = get_bounds cost_bounds1 in let (lbs2, ubs2, inf_lb2, inf_ub2) = get_bounds cost_bounds2 in match (cost_bounds1#isBottom, @@ -1604,7 +1607,7 @@ let rec join_stages (lbs1, ubs1, stage1) (lbs2, ubs2, stage2) new_inf_ub = | (false, false, _, true, _, _) -> top_cost_bounds | (false, false, false, false, true, _) | (false, false, false, false, _, true) -> inf_lb_cost_bounds - | (false, false, false, false, fals, false) -> + | (false, false, false, false, false, false) -> let new_inf_ub = inf_ub1 || inf_ub2 in let (lbs1, ubs1, lbs2, ubs2) = @@ -1614,25 +1617,25 @@ let rec join_stages (lbs1, ubs1, stage1) (lbs2, ubs2, stage2) new_inf_ub = let is_simple bs = let is_simple_b b = b#has_pos_coeffs && b#has_pos_jterms in List.length bs = 1 && is_simple_b (List.hd bs) in - + if is_simple lbs1 && is_simple lbs2 && is_simple ubs1 && is_simple ubs2 then cost_bounds1#join cost_bounds2 - else + else begin let join_cost = - join_stages (lbs1, ubs1, 0) (lbs2, ubs2, 0) new_inf_ub in + join_stages (lbs1, ubs1, 0) (lbs2, ubs2, 0) new_inf_ub in pr__debug [STR "full_join "; cost_bounds1#toPretty; STR " "; cost_bounds2#toPretty; NL; - STR "full_join res = "; join_cost#toPretty; NL] ; + STR "full_join res = "; join_cost#toPretty; NL]; join_cost end let costbounds_to_string (cbounds:cost_bounds_t):string = let _ = cbounds#kind in - let (lbs, ubs, inflbs, infubs) = get_st_bounds () in + let (lbs, ubs, _inflbs, _infubs) = get_st_bounds () in let cbcollection_to_string (cb_collection:JCHCostBound.CostBoundCollections.set_t):string = match cb_collection#singleton with @@ -1640,4 +1643,4 @@ let costbounds_to_string (cbounds:cost_bounds_t):string = | Some cbound -> cost_bound_to_string cbound in let (lbs_string, ubs_string) = (cbcollection_to_string lbs, cbcollection_to_string ubs) in - "(" ^ lbs_string ^ " , " ^ ubs_string ^ ")" + "(" ^ lbs_string ^ " , " ^ ubs_string ^ ")" diff --git a/CodeHawk/CHJ/jchcost/jCHCostBounds.mli b/CodeHawk/CHJ/jchcost/jCHCostBounds.mli index 8e3bec94..eadb67bd 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBounds.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostBounds.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -84,20 +84,20 @@ val get_bounds: -> CostBoundCollections.set_t * CostBoundCollections.set_t * bool - * bool + * bool + +val add_cost_bounds : cost_bounds_t -> cost_bounds_t -> cost_bounds_t -val add_cost_bounds : cost_bounds_t -> cost_bounds_t -> cost_bounds_t - val mult_cost_bounds : cost_bounds_t -> cost_bounds_t -> cost_bounds_t val div_cost_bounds : cost_bounds_t -> cost_bounds_t -> cost_bounds_t val write_xml_bounds: ?tag:string -> cost_bounds_t -> xml_element_int -> unit - + val write_xml_atlas_bounds: xml_element_int -> method_signature_int -> cost_bounds_t -> unit -val bounds_from_jterms : +val bounds_from_jterms : bool -> jterm_t list -> jterm_t list -> cost_bounds_t val read_xml_bounds : ?tag:string -> xml_element_int -> cost_bounds_t @@ -112,12 +112,12 @@ val subst_pos_bounds_final : int -> cost_bounds_t -> cost_bounds_t val subst_local_vars : int - -> cost_bounds_t + -> cost_bounds_t -> (jterm_t * cost_bound_t list) list -> (jterm_t * cost_bound_t list) list -> cost_bounds_t val add_pos_jterm : int -> jterm_t -> cost_bounds_t -> unit - + val add_pos_jterm_final : int -> jterm_t -> cost_bounds_t -> cost_bounds_t val get_jterms : cost_bounds_t -> jterm_t list diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.ml b/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.ml index c447b93b..de8eb6b9 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.ml @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -34,24 +34,20 @@ open CHNonRelationalDomainValues (* chutil *) open CHLogger -open CHPrettyUtil -open CHXmlDocument (* jchlib *) open JCHBasicTypes open JCHBasicTypesAPI open JCHDictionary -open JCHJTerm (* jchpre *) open JCHCostBoundsModel open JCHPreAPI open JCHUserData -open JCHXmlUtil (* jchsys *) open JCHPrintUtils - + (* jchcost *) open JCHCostBounds @@ -70,13 +66,13 @@ let issinkvar (name:string) = let get_sink_edge (s:symbol_t) = match s#getAttributes with - | [ decpc ; predpc ; "exit" ] -> + | [decpc; predpc; "exit"] -> (int_of_string decpc, int_of_string predpc, (-1)) - | [ decpc ; predpc ; obspc ] -> + | [decpc; predpc; obspc] -> (int_of_string decpc, int_of_string predpc, int_of_string obspc) - | _ -> raise (JCH_failure (LBLOCK [ STR "Invalid sink name: " ; s#toPretty ] )) + | _ -> raise (JCH_failure (LBLOCK [STR "Invalid sink name: "; s#toPretty] )) -let get_bounds (v:non_relational_domain_value_t) : cost_bounds_t = +let get_bounds (v:non_relational_domain_value_t) : cost_bounds_t = match v#getValue with | EXTERNAL_VALUE b -> b | TOP_VAL -> top_cost_bounds @@ -113,30 +109,31 @@ let adjustbounds cmsix costmodel bv lh = let getloopsinkvalues cmsix v costmodel loopstructure (pc:int):cost_bounds_t = let loopheads = loopstructure#get_pc_loopheads pc in - let add acc lh = + let add acc lh = let loopexitvalue = getloopexitvalue v lh in let xvalue = adjustbounds cmsix costmodel loopexitvalue lh in add_cost_bounds acc xvalue in List.fold_left add (cost_bounds_from_num numerical_zero) loopheads -let get_sinks cmsix costmodel loopstructure = +let _get_sinks cmsix costmodel loopstructure = H.iter (fun (decpc,predpc,obspc) inv -> let domain = inv#getDomain "cost_bounds" in if domain#isBottom then - pr__debug [ INT decpc ; STR " - " ; INT obspc ; STR ": bottom" ; NL ] + pr__debug [INT decpc; STR " - "; INT obspc; STR ": bottom"; NL] else let vars = domain#observer#getObservedVariables in let varObserver = domain#observer#getNonRelationalVariableObserver in let svars = List.filter (fun v -> issinkvar v#getName#getBaseName) vars in List.iter (fun v -> - let loopxinv = getloopsinkvalues cmsix v costmodel loopstructure obspc in + let loopxinv = getloopsinkvalues cmsix v costmodel loopstructure obspc in let tgtinv = get_bounds (varObserver v) in let inv = add_cost_bounds tgtinv loopxinv in begin - costmodel#set_sidechannelcost cmsix decpc predpc obspc inv ; - pr__debug [ STR "Sink " ; v#toPretty ; STR ": " ; - INT decpc ; STR " - " ; INT obspc ; STR ": " ; - inv#toPretty ; NL ] + costmodel#set_sidechannelcost cmsix decpc predpc obspc inv; + pr__debug [ + STR "Sink "; v#toPretty; STR ": "; + INT decpc; STR " - "; INT obspc; STR ": "; + inv#toPretty; NL] end) svars) sinkinvariants @@ -146,7 +143,7 @@ let get_methodexit_bounds () = let varObserver = domain#observer#getNonRelationalVariableObserver in let cvars = List.filter (fun v -> v#getName#getBaseName = "costvar") vars in match cvars with - | [ cvar ] -> + | [cvar] -> let cost = get_bounds (varObserver cvar) in if !dbg then pr__debug [ @@ -167,29 +164,29 @@ let get_methodexit_bounds () = let default_opsemantics - domain + _domain cmsix hpc_opt:CHIterator.op_semantics_t = - fun ~invariant ~stable ~fwd_direction ~context ~operation -> + fun ~invariant ~stable ~fwd_direction ~context:_ ~operation -> match operation.op_name#getBaseName with | "invariant" -> - if stable then + if stable then begin match operation.op_name#getAttributes with - | [ "methodexit" ] -> + | ["methodexit"] -> if !dbg then - pr__debug [STR "op methodexit"; NL; invariant#toPretty; NL] ; + pr__debug [STR "op methodexit"; NL; invariant#toPretty; NL]; if invariant#isBottom then (* the method does not ever reach the exit *) begin let cvar = JCHCostUtils.get_cost_var () in let set_to_inf_op = - {op_name = new symbol_t ~atts:["0"] "set_to_inf" ; + {op_name = new symbol_t ~atts:["0"] "set_to_inf"; op_args = [("dst", cvar, WRITE)] } in let invariant = invariant#mkEmpty#analyzeFwd (OPERATION set_to_inf_op) in - H.add invariants ("methodexit",(-1)) invariant ; + H.add invariants ("methodexit",(-1)) invariant; chlog#add "methods that do not reach exit" (LBLOCK [STR "m_"; INT cmsix; STR ": "; @@ -199,22 +196,22 @@ let default_opsemantics (* substitute out sym_lp and sym_call, and simplify the cost *) let cvar = JCHCostUtils.get_cost_var () in let subst_op = - {op_name = new symbol_t ~atts:[] "subst_at_exit" ; + {op_name = new symbol_t ~atts:[] "subst_at_exit"; op_args = [("dst", cvar, WRITE)] } in let invariant = invariant#clone#analyzeFwd (OPERATION subst_op) in H.add invariants ("methodexit",(-1)) invariant - | [ "loopexit" ; pc ] -> - if !dbg then pr__debug [STR "op loopexit"; NL] ; - H.add invariants ("loopexit", int_of_string pc) invariant + | ["loopexit"; pc] -> + if !dbg then pr__debug [STR "op loopexit"; NL]; + H.add invariants ("loopexit", int_of_string pc) invariant | _ -> () - end ; + end; invariant | "sink" -> if stable then begin let sinkid = get_sink_edge operation.op_name in H.add sinkinvariants sinkid invariant - end ; + end; invariant | "add_loop_cost" -> let is_other_loop = @@ -228,7 +225,7 @@ let default_opsemantics else invariant | "block_cost" -> let pc = int_of_string (List.hd operation.op_name#getAttributes) in - JCHCostBounds.set_instr_pc pc ; + JCHCostBounds.set_instr_pc pc; invariant#analyzeFwd (OPERATION operation) | "set_to_0" | "add_block_cost" -> invariant#analyzeFwd (OPERATION operation) @@ -244,8 +241,8 @@ let analyze_procedure_with_cost_bounds (proc: procedure_int) (system:system_int) = if !dbg then pr__debug [STR "analyze_procedure_with_cost_bounds "; INT cmsix; STR " "; - proc#toPretty; NL] ; - JCHCostBoundsDomainNoArrays.current_proc_is_loop := Option.is_some hpc_opt ; + proc#toPretty; NL]; + JCHCostBoundsDomainNoArrays.current_proc_is_loop := Option.is_some hpc_opt; let analysis_setup = CHAnalysisSetup.mk_analysis_setup () in let get_loop_cost_user pc = if userdata#has_loopbound cmsix pc then @@ -262,9 +259,9 @@ let analyze_procedure_with_cost_bounds ~get_loop_cost ~get_loop_cost_user ~get_block_cost - ~record_final_cost) ; - analysis_setup#setOpSemantics (default_opsemantics "cost_bounds" cmsix hpc_opt) ; - analysis_setup#analyze_procedure ~do_loop_counters:false system proc + ~record_final_cost); + analysis_setup#setOpSemantics (default_opsemantics "cost_bounds" cmsix hpc_opt); + analysis_setup#analyze_procedure ~do_loop_counters:false system proc end let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = @@ -274,10 +271,10 @@ let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = let _ = H.clear sinkinvariants in let cms = mInfo#get_class_method_signature in let cmsix = cms#index in - JCHCostBoundsDomainNoArrays.dbg := !dbg; - JCHCostBoundsModel.dbg := !dbg ; + JCHCostBoundsDomainNoArrays.dbg := !dbg; + JCHCostBoundsModel.dbg := !dbg; pr__debug [NL; NL; NL; NL; STR "analyze_cost_bounds "; - INT cmsix; STR " "; mInfo#get_class_method_signature#toPretty; NL] ; + INT cmsix; STR " "; mInfo#get_class_method_signature#toPretty; NL]; if !dbg then pr__debug [STR "bytecode: "; NL; mInfo#get_bytecode#toPretty; NL]; JCHCostBounds.set_cmsix cmsix; @@ -290,14 +287,14 @@ let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = let (p, lps) = costabstractor#to_chifproc in let res = (Some p, List.map (fun lp -> Some lp) lps, "") in res - with JCHCostUtils.JCH_cost_out_of_time str -> (None, [], str) in + with JCHCostUtils.JCH_cost_out_of_time str -> (None, [], str) in let analyze_proc hpc_opt p_opt = - let cost = + let cost = match p_opt with | Some p -> begin let csystem = LF.mkSystem (new symbol_t "costmodel") in - csystem#addProcedure p ; + csystem#addProcedure p; try analyze_procedure_with_cost_bounds cmsix @@ -307,7 +304,7 @@ let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = (costmodel#add_to_coststore_final cmsix) userdata p - csystem ; + csystem; get_methodexit_bounds () with JCHCostUtils.JCH_cost_out_of_time str -> begin @@ -316,9 +313,9 @@ let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = (LBLOCK [STR "m_"; INT cmsix; STR ": "; (JCHDictionary.retrieve_cms cmsix)#toPretty]); pr_debug [STR str; NL]; - let jterm = + let jterm = match hpc_opt with - | Some hpc -> + | Some hpc -> JSymbolicConstant ((TBasic Int), (Some (mkNumerical 100)), @@ -350,19 +347,19 @@ let analyze_bounds_cost (costmodel:costmodel_t) (mInfo:method_info_int) = end in match hpc_opt with | Some hpc -> - pr__debug [ NL; STR "loop@"; INT hpc; STR " cost: "; NL; - cost#toPretty] ; + pr__debug [NL; STR "loop@"; INT hpc; STR " cost: "; NL; + cost#toPretty]; costmodel#set_loop_cost cmsix hpc cost | _ -> - pr__debug [ NL; STR "method cost for "; - mInfo#get_class_method_signature#toPretty ; - STR " (" ; INT cmsix ; STR ") is " ; NL ; - cost#toPretty] ; + pr__debug [NL; STR "method cost for "; + mInfo#get_class_method_signature#toPretty; + STR " ("; INT cmsix; STR ") is "; NL; + cost#toPretty]; costmodel#set_methodcost cmsix cost in List.iter (fun pair_opt -> match pair_opt with | Some (hpc, loop_proc) -> analyze_proc (Some hpc) (Some loop_proc) - | None -> analyze_proc None proc_opt) loop_procs ; + | None -> analyze_proc None proc_opt) loop_procs; analyze_proc None proc_opt end @@ -379,8 +376,7 @@ let create_bounds_cost_model use_symbolic_defaults = JCHCallgraphBase.callgraph_base#bottomup_iter (fun m -> if m#has_bytecode then analyze_bounds_cost costmodel m); JCHCostUtils.record_not_pos_jterms (); - costmodel#print_cost_stores () ; - List.iter costmodel#save_xml_class JCHApplication.app#get_classes ; + costmodel#print_cost_stores (); + List.iter costmodel#save_xml_class JCHApplication.app#get_classes; List.iter costmodel#save_xml_atlas_class JCHApplication.app#get_classes end - diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.mli b/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.mli index e8f2c5ba..b10a608f 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsAnalysis.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -29,6 +29,3 @@ val dbg : bool ref val create_bounds_cost_model : bool -> unit - - - diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.ml b/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.ml index a2646065..c6753ec3 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -60,29 +61,29 @@ class cost_bounds_domain_no_arrays_t ~(get_block_cost: int -> cost_bounds_t) ~(record_final_cost: cost_bounds_t -> unit) = object (self: 'a) - - inherit CHNonRelationalDomainNoArrays.non_relational_domain_t as super - + + inherit CHNonRelationalDomainNoArrays.non_relational_domain_t + method private getValue' v : cost_bounds_t = match (self#getValue v)#getValue with | EXTERNAL_VALUE b -> b | TOP_VAL -> top_cost_bounds | BOTTOM_VAL -> bottom_cost_bounds | _ -> raise (CHFailure (STR "Cost bounds expected")) - + method private setValue' t v x = self#setValue t v (new non_relational_domain_value_t (EXTERNAL_VALUE x)) - + method private importValue v = - match v#getValue with - | EXTERNAL_VALUE _ -> v + match v#getValue with + | EXTERNAL_VALUE _ -> v | TOP_VAL -> topNonRelationalDomainValue | BOTTOM_VAL -> bottomNonRelationalDomainValue | _ -> raise (JCH_failure (STR "JCHCostBoundsDomainNoArrays.importValue expected external_value_int")) - + method private analyzeFwd' (cmd: (code_int, cfg_int) command_t) = if !dbg then pr__debug [STR "CostBounds.analyzeFwd "; command_to_pretty 0 cmd; NL; @@ -93,7 +94,7 @@ object (self: 'a) let table' = table#clone in let default () = if !dbg then - pr__debug [STR " after analyzeFwd, table': "; NL; table'#toPretty; NL] ; + pr__debug [STR " after analyzeFwd, table': "; NL; table'#toPretty; NL] ; {< table = table' >} in match cmd with @@ -123,8 +124,8 @@ object (self: 'a) let cost_bounds = make_small_divs (self#getValue' dst) in let new_cost_bounds = if is_const_range cost_bounds then - subst_pos_bounds (-1) cost_bounds false - else + subst_pos_bounds (-1) cost_bounds false + else begin let no_lps_cost_bounds = subst_pos_bounds (-1) cost_bounds true in @@ -137,7 +138,7 @@ object (self: 'a) let cost_bounds_final = subst_pos_bounds_final (-1) new_cost_bounds in record_final_cost cost_bounds_final ; - self#setValue' table' dst new_cost_bounds + self#setValue' table' dst new_cost_bounds end ; JCHCostUtils.check_cost_analysis_time (" while analyzing " ^ (string_of_int cmsix)) ; @@ -156,7 +157,7 @@ object (self: 'a) let hpc = int_of_string (List.hd op_name#getAttributes) in let v = JCHSystemUtils.get_arg_var "dst" op_args in let v_b = self#getValue' v in - + let cost_one_iteration = let cost = get_loop_cost hpc in if is_const_range cost then cost @@ -168,19 +169,19 @@ object (self: 'a) let lp_jterm = make_sym_lp cmsix hpc (find_const_lb true cost_no_lps) in add_pos_jterm hpc lp_jterm cost_no_lps; - bounds_from_jterms false [lp_jterm] [lp_jterm] + bounds_from_jterms false [lp_jterm] [lp_jterm] end in if !dbg then pr__debug [STR "cost_one_iteration = "; NL; cost_one_iteration#toPretty; NL] ; - + let nb_iterations = self#get_loop_iterations hpc in pr__debug [STR "loop@"; INT hpc; STR " nb iterations: "; NL; nb_iterations#toPretty; NL] ; - + let cost = mult_cost_bounds nb_iterations cost_one_iteration in if !dbg then pr__debug [STR "after mult_cost_bounds "; NL]; - + let v_b' = add_cost_bounds v_b cost in self#setValue' table' v v_b'; default () @@ -190,7 +191,7 @@ object (self: 'a) let cost = get_block_cost pc in self#setValue' table' v cost ; default () - | _ -> + | _ -> default () end | _ -> @@ -198,15 +199,15 @@ object (self: 'a) INT (JCHCostBounds.get_instr_pc ()); STR " "; command_to_pretty 0 cmd; NL]; default () - + method private get_loop_iterations hpc = - let (iteration_lbs, iteration_ubs) = + let (iteration_lbs, iteration_ubs) = match get_loop_cost_user hpc with | Some bound -> if !dbg then pr__debug [STR "user provided iteration"; NL] ; let (it_lbs, it_ubs, _, _) = get_bounds bound in (List.map (fun b -> b#to_jterm) it_lbs#toList, - List.map (fun b -> b#to_jterm) it_ubs#toList) + List.map (fun b -> b#to_jterm) it_ubs#toList) | _ -> JCHNumericAnalysis.get_iteration_bounds cmsix hpc in if !dbg then @@ -218,7 +219,7 @@ object (self: 'a) List.partition is_const iteration_lbs in let (const_iteration_ubs, non_const_iteration_ubs) = List.partition is_const iteration_ubs in - let (large_const_iteration_ubs, small_const_iteration_ubs) = + let (_large_const_iteration_ubs, small_const_iteration_ubs) = match get_loop_cost_user hpc with | Some _ -> ([], const_iteration_ubs) | _ -> @@ -226,7 +227,7 @@ object (self: 'a) let const_lbound = ref (Some numerical_zero) in let const_ubound = ref None in - let check_const is_lb const_bound jt = + let check_const is_lb const_bound jt = match (!const_bound, jt) with | (None, JConstant m) -> const_bound := Some m | (Some n, JConstant m) -> @@ -234,19 +235,19 @@ object (self: 'a) | _ -> () in List.iter (check_const true const_lbound) const_iteration_lbs ; List.iter (check_const false const_ubound) const_iteration_ubs ; - + let iteration_lbs = const_iteration_lbs @ non_const_iteration_lbs in - let iteration_ubs = small_const_iteration_ubs @ non_const_iteration_ubs in - + let iteration_ubs = small_const_iteration_ubs @ non_const_iteration_ubs in + if !dbg then - pr__debug [STR "iteration_bounds "; INT hpc; STR ": [ "; + pr__debug [STR "iteration_bounds "; INT hpc; STR ": [ "; pp_list_jterm iteration_lbs ; STR "; "; pp_list_jterm iteration_ubs; STR "]"; NL] ; - + let sym_lc = make_sym_lc cmsix hpc (Option.get !const_lbound) !const_ubound in let sym_lbs_opt = ref None in let sym_ubs_opt = ref None in - + let lbounds = if non_const_iteration_lbs = [] then [JConstant (Option.get !const_lbound)] @@ -255,8 +256,8 @@ object (self: 'a) sym_lbs_opt := Some iteration_lbs ; [sym_lc] end in - - let ubounds = + + let ubounds = if small_const_iteration_ubs != [] && non_const_iteration_ubs = [] then [JConstant (Option.get !const_ubound)] else @@ -268,37 +269,37 @@ object (self: 'a) if !dbg then pr__debug [STR "lbounds = "; pp_list_jterm lbounds; NL; STR "ubounds = "; pp_list_jterm ubounds; NL]; - + (match (!sym_lbs_opt, !sym_ubs_opt) with | (Some sym_lbs, Some sym_ubs) -> let bounds = bounds_from_jterms false sym_lbs sym_ubs in add_pos_jterm hpc sym_lc bounds | (Some sym_lbs, None) -> let bounds = bounds_from_jterms false sym_lbs [] in - add_pos_jterm hpc sym_lc bounds + add_pos_jterm hpc sym_lc bounds | (None, Some sym_ubs) -> let bounds = bounds_from_jterms false [] sym_ubs in add_pos_jterm hpc sym_lc bounds | _ -> () ) ; - bounds_from_jterms false lbounds ubounds + bounds_from_jterms false lbounds ubounds - method private analyzeBwd' (cmd: (code_int, cfg_int) command_t) = + method private analyzeBwd' (_cmd: (code_int, cfg_int) command_t) = if bottom then self#mkBottom else let table' = table#clone in {< table = table' >} - method special (cmd: string) (args: domain_cmd_arg_t list) : 'a = + method special (cmd: string) (_args: domain_cmd_arg_t list) : 'a = match cmd with | "set_cost_bounds" -> - let cvar = get_cost_var () in + let cvar = get_cost_var () in set_st_cost_bounds (self#getValue' cvar) ; {< >} | _ -> {< >} - + end let get_cost_bounds (cost_bounds_dom: CHDomain.domain_int) = diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.mli b/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.mli index 35f30700..f8db6c51 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsDomainNoArrays.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -37,7 +38,7 @@ val string_dom_name : string val current_proc_is_loop : bool ref -class cost_bounds_domain_no_arrays_t : +class cost_bounds_domain_no_arrays_t : cmsix:int -> get_loop_cost:(int -> cost_bounds_t) -> get_loop_cost_user:(int -> cost_bounds_t option) @@ -46,5 +47,3 @@ class cost_bounds_domain_no_arrays_t : -> domain_int val get_cost_bounds : domain_int -> cost_bounds_t - - diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.ml b/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.ml index e87bfa8f..ccac4c62 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.ml @@ -3,9 +3,9 @@ Author: Henny Sipma and Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2021 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -27,17 +27,15 @@ ============================================================================= *) (* chlib *) -open CHIntervals -open CHLanguage open CHNumerical open CHPretty open CHUtils (* chutil *) -open CHLogger +open CHLogger open CHLoopStructure -open CHPrettyUtil -open CHXmlDocument +open CHPrettyUtil +open CHXmlDocument (* jchlib *) open JCHBasicTypes @@ -50,19 +48,13 @@ open JCHJTerm (* jchpre *) open JCHApplication open JCHCallgraphBase -open JCHCodegraph -open JCHFunctionSummary -open JCHFunctionSummaryLibrary open JCHPreAPI open JCHPreFileIO -open JCHStackSlotValue -open JCHSystemSettings open JCHUserData open JCHPrintUtils - + (* jchcost *) -open JCHCostAPI open JCHOpcodeCosts open JCHCostUtils open JCHCostBound @@ -73,7 +65,7 @@ module LF = CHOnlineCodeSet.LanguageFactory module Q = Queue let dbg = ref false - + let use_symbolic_defaults = ref false let set_symbolic_defaults b = use_symbolic_defaults := b @@ -81,16 +73,16 @@ let default_function_lbound = cost_bound_from_num true (mkNumerical 100) let default_function_ubound = cost_bound_from_num false (mkNumerical 100) let default_funcall_cost name = - let range = - if !use_symbolic_defaults then + let range = + if !use_symbolic_defaults then JSymbolicConstant ((TBasic Int),(Some (mkNumerical 100)), None, name) else (JConstant (mkNumerical 100)) in - mk_jterm_jterm_range range + mk_jterm_jterm_range range let default_libcall_cost name = - let range = - if !use_symbolic_defaults then + let range = + if !use_symbolic_defaults then JSymbolicConstant ((TBasic Int), (Some (mkNumerical 100)), None, name) else (JConstant (mkNumerical 100)) in @@ -117,8 +109,8 @@ let get_precanned_time_cost (cms:class_method_signature_int) = else raise (JCH_failure (LBLOCK [ STR "Method " ; cms#toPretty ; STR " does not have a precanned cost" ])) - - + + class timecost_diagnostics_t = object (self) @@ -173,7 +165,7 @@ object (self) set "s" cms#class_method_signature_string ; n end) l - + method private write_xml_missing (node:xml_element_int) = let l = H.fold (fun k v a -> (k,v) :: a) missingcost [] in let l = List.sort Stdlib.compare l in @@ -234,7 +226,7 @@ let save_timecost_diagnostics () = timecost_diagnostics#write_xml node ; save_timecost_diagnostics node end - + class sidechannelcheck_t (cmsix:int) (decisionpc:int) (observationpc:int) = @@ -264,7 +256,7 @@ object (self:_) let lst = ref [] in let _ = H.iter (fun k v -> lst := (k,v) :: !lst) costs in List.sort (fun (pc1,_) (pc2,_) -> Stdlib.compare pc1 pc2) !lst - + method set_path_cost (predecessorpc:int) (cost: cost_bounds_t) = H.replace costs predecessorpc cost @@ -293,7 +285,7 @@ object (self:_) method toPretty = let pairs = ref [] in - let _ = H.iter (fun k v -> pairs := (k,v):: !pairs) costs in + let _ = H.iter (fun k v -> pairs := (k,v):: !pairs) costs in LBLOCK [ STR "decision-pc : " ; INT decisionpc ; STR "observation-pc: " ; INT observationpc ; pretty_print_list @@ -301,10 +293,10 @@ object (self:_) LBLOCK [ INT k ; STR ": " ; v#toPretty ; NL ]) "" "" "" ; NL ] end - + module IntListCollections = CHCollections.Make (struct - type t = int list + type t = int list let compare is1 is2 = let rec comp is1 is2 = match (is1, is2) with @@ -323,16 +315,16 @@ object (self:_) val methodcoststore = H.create 3 (* (int, cost_bounds_t) H.t *) - + val blockcoststore = H.create 3 (* (int, (int, cost_bounds_t) H.t) H.t ; only used for reporting *) - + val loopstructures = H.create 3 (* (int, loop_structure_int) H.t *) - + val loopcoststore = H.create 3 (* (int, (int, cost_bounds_t) H.t) H.t; cmsix -> looop head -> cost of loop *) - + val sidechannelchecks = (* (int, ((int, int), sidechannelcheck_t) H.t) H.t *) let t = H.create 3 in @@ -359,7 +351,7 @@ object (self:_) method add_to_coststore_final cmsix cost = coststore_final#set [cmsix] cost - method write_xml_cost ?(tag="ibcost") (node:xml_element_int) (b:cost_bounds_t) = + method write_xml_cost ?(tag="ibcost") (node:xml_element_int) (b:cost_bounds_t) = write_xml_bounds ~tag b node method read_xml_cost ?(tag="ibcost") (node:xml_element_int) = @@ -418,7 +410,7 @@ object (self:_) method get_loop_cost (cmsix:int) (pc:int) : cost_bounds_t = let t = H.find loopcoststore cmsix in - H.find t pc + H.find t pc method get_block_cost (cmsix: int) (pc: int) : cost_bounds_t = let t = H.find blockcoststore cmsix in @@ -430,7 +422,7 @@ object (self:_) if !dbg then pr__debug [STR "compute_blockcost "; INT firstpc; STR " "; INT lastpc; NL] ; - let res = + let res = let cms = retrieve_cms cmsix in let mInfo = app#get_method cms in let cost = @@ -439,44 +431,44 @@ object (self:_) let code = mInfo#get_bytecode#get_code in let cost: cost_bounds_t ref = ref (self#get_instr_cost cmsix firstpc (code#at firstpc)) in - + (if !dbg then pr__debug [STR "compbute_blockcost cost = "; !cost#toPretty; NL]) ; - + let i = ref firstpc in while !i < lastpc do match code#next !i with | Some j -> - + (if !dbg then pr__debug [STR "add instr cost at "; INT j; NL]) ; - + let opcode = code#at j in i := j ; cost := add_cost_bounds !cost (self#get_instr_cost cmsix j opcode); JCHCostUtils.check_cost_analysis_time (" while computing block costs for " ^ (string_of_int cmsix)) ; - + (if !dbg then pr__debug [STR "after add_cost, cost = "; !cost#toPretty; NL]) ; - + | _ -> () done ; !cost end else self#mk_bottom in - + begin self#set_block_cost cmsix firstpc cost ; cost end in - + (if !dbg then pr__debug [STR "compute_blockcost "; INT firstpc; STR " "; INT lastpc; STR " res = "; res#toPretty; NL]) ; - res - + res + method compute_block_cost (cmsix:int) (firstpc:int) (lastpc:int): cost_bounds_t = if userdata#has_blockcost cmsix firstpc then @@ -487,27 +479,27 @@ object (self:_) method private get_opcode_cost (opcode:opcode_t):jterm_range_int = mk_intconstant_jterm_range (mkNumerical (get_opcode_cost opcode)) - (* cost_bound are bounds for the cost of a call as a function of callee + (* cost_bound are bounds for the cost of a call as a function of callee * arguments, fields, and symbolic constants. - * This method uses the default_map and the argument bounds from the - * numeric analysis to find a bound that depends on the parameters of + * This method uses the default_map and the argument bounds from the + * numeric analysis to find a bound that depends on the parameters of * the caller function, fields, and symbolic constants *) method private change_methodcall_cost (cost_bounds: cost_bounds_t) (caller_cmsix: int) (pc: int) (default_map: (int * int) list): cost_bounds_t = - + (if !dbg then pr__debug [STR "change_methodcall_cost "; INT caller_cmsix; STR " "; INT pc; NL; STR " "; cost_bounds#toPretty; NL; pp_assoc_list_ints default_map; NL]) ; - + let (arg_lbounds, arg_ubounds) = JCHNumericAnalysis.get_method_arg_bounds caller_cmsix pc in - + (if !dbg then begin pr__debug [STR "JCHNumericAnalysis "; INT caller_cmsix; STR"@"; @@ -522,20 +514,20 @@ object (self:_) arg_ubounds end) ; - (* make the constants close to max_int max_long into + (* make the constants close to max_int max_long into * max_int(max_long) + or i small integer *) let max_int_lb = max_int_num#sub margin_num in let max_int_ub = max_int_num#add margin_num in - + let max_long_lb = max_int_num#sub margin_num in let max_long_ub = max_int_num#add margin_num in let change_bounds b = match b with - | JConstant i when i#geq max_int_lb && i#leq max_int_ub -> + | JConstant i when i#geq max_int_lb && i#leq max_int_ub -> let diff = i#sub max_int_num in JArithmeticExpr (JPlus, sym_max_int, JConstant diff) - | JConstant i when i#geq max_long_lb && i#leq max_long_ub -> + | JConstant i when i#geq max_long_lb && i#leq max_long_ub -> let diff = i#sub max_long_num in JArithmeticExpr (JPlus, sym_max_long, JConstant diff) | _ -> b in @@ -559,7 +551,7 @@ object (self:_) (* add default costs for size (args) *) let add_size_default is_lb bounds jt = match jt with - | JSize _ -> + | JSize _ -> if (List.exists (fun (jt', _) -> jterm_compare jt' jt = 0) bounds) then bounds else @@ -579,7 +571,7 @@ object (self:_) pr__debug [NL; STR "after default values, arg_lbounds: "; NL]; List.iter (fun (jt, ls) -> pr__debug [jterm_to_pretty jt; STR ": "; pp_list_jterm ls; NL]) - arg_lbounds; + arg_lbounds; pr__debug [STR "after default values, arg_ubounds: "; NL]; List.iter (fun (jt, ls) -> pr__debug [jterm_to_pretty jt; STR ": "; pp_list_jterm ls; NL]) @@ -592,7 +584,7 @@ object (self:_) let arg_lbounds = let ls = ref [] in let add_jterm jterm = - + (if !dbg then pr__debug [NL; STR "JCHCostBoundsModel.add_jterm "; jterm_to_pretty jterm; NL]) ; @@ -600,7 +592,7 @@ object (self:_) try let res = snd (List.find (fun (jt, _) -> compare jt jterm = 0) arg_lbounds) in - + (if !dbg then pr__debug [STR "found in arg_lbounds "; NL]) ; res @@ -645,7 +637,7 @@ object (self:_) pr__debug [jterm_to_pretty jt; STR ": "; pp_list_jterm ls; NL]) arg_ubounds end ; - (* use default values if there are no argument bounds and if there are no + (* use default values if there are no argument bounds and if there are no * default values use the default function bounds *) let (cost_bounds, arg_lbounds, arg_ubounds) = let (lbs, ubs, inf_lb, inf_ub) = get_bounds cost_bounds in @@ -661,9 +653,9 @@ object (self:_) chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]) ; - + pr__debug [STR "cost loss of precision "; pp] ; - + (new cost_bounds_t ~bottom:cost_bounds#isBottom ~simplify:false @@ -682,14 +674,14 @@ object (self:_) (retrieve_cms caller_cmsix)#class_method_signature_string in let pp = LBLOCK [ STR method_name; STR " @ "; INT pc; - STR " method call with problematic lower bounds "; NL; + STR " method call with problematic lower bounds "; NL; STR " lower bounds "; pretty_print_list lbs#toList (fun b -> STR b#to_string) "{" "; " "}"; NL] in chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]) ; - + pr__debug [STR "cost loss of precision "; pp] ; - + (new cost_bounds_t ~bottom:cost_bounds#isBottom ~simplify:false @@ -703,23 +695,23 @@ object (self:_) begin if !dbg then pr__debug [STR "there are lower bounds but no upper bounds"; NL] ; - - let const = + + let const = let lb_n = find_const_lb true cost_bounds in let ub_n = find_const_lb false cost_bounds in if lb_n#gt ub_n then lb_n else ub_n in let const_ub = cost_bound_from_num false (const#add (mkNumerical 100)) in - + let method_name = (retrieve_cms caller_cmsix)#class_method_signature_string in let pp = LBLOCK [ STR method_name; STR " @ "; INT pc; - STR " method call with problematic upper bounds "; NL; + STR " method call with problematic upper bounds "; NL; STR " upper bounds "; pretty_print_list ubs#toList (fun b -> STR b#to_string) "{" "; " "}"; NL] in chlog#add "cost loss of precision" (LBLOCK [STR (pretty_to_string pp)]) ; - + pr__debug [STR "cost loss of precision "; pp] ; (new cost_bounds_t @@ -749,12 +741,12 @@ object (self:_) let mk_local_var is_lb (var_jterm, bounds) = - + (if !dbg then pr__debug [STR "mk_local_var "; pp_bool is_lb; STR " "; jterm_to_pretty var_jterm; NL; STR " "; (JTermCollections.set_of_list bounds)#toPretty; NL]); - + (var_jterm, List.map (JCHCostBound.bound_from_jterm is_lb) bounds) in let (arg_lbounds, arg_ubounds) = (List.map (mk_local_var true) arg_lbounds, @@ -764,7 +756,7 @@ object (self:_) begin pr__debug [STR "after mk_local_var, arg_lbounds: "; NL]; List.iter (fun (jt, cs) -> - pr__debug [jterm_to_pretty jt; STR ": "; pp_list cs; NL]) arg_lbounds; + pr__debug [jterm_to_pretty jt; STR ": "; pp_list cs; NL]) arg_lbounds; pr__debug [STR "after mk_local_var, arg_ubounds: "; NL]; List.iter (fun (jt, cs) -> pr__debug [jterm_to_pretty jt; STR ": "; pp_list cs; NL]) arg_ubounds @@ -772,7 +764,7 @@ object (self:_) let new_cost_bounds = JCHCostBounds.subst_local_vars pc cost_bounds arg_lbounds arg_ubounds in - + (if !dbg then pr__debug [ STR "changel_methodcall_cost res = "; new_cost_bounds#toPretty; NL]); @@ -788,17 +780,17 @@ object (self:_) get_precanned_time_cost callee else summary#get_time_cost in - + (if !dbg then pr__debug [STR "library method summary cost = "; cost#toPretty; NL]) ; - - let (is_top, cost) = + + let (is_top, cost) = if cost#is_top then - + begin (if !dbg then pr__debug [STR "summary cost is top"; NL]); - + timecost_diagnostics#record_missing callee ; (true, default_libcall_cost ("libcall_default_Top")) end @@ -809,26 +801,26 @@ object (self:_) (false, cost) end in (is_top, cost_bounds_from_jterm_range cost,[]) - - method private get_methodcall_cost + + method private get_methodcall_cost (caller:class_method_signature_int) (pc:int) (callee:class_method_signature_int) : cost_bounds_t = - + (if !dbg then pr_debug [STR "get_methodcall_cost "; INT caller#index; STR " "; INT pc; STR " "; INT callee#index; NL; caller#toPretty; NL; callee#toPretty; NL]); - + let res = - let change method_cost default_map = + let change method_cost default_map = let new_cost = self#change_methodcall_cost method_cost caller#index pc default_map in - + (if !dbg then pr__debug [STR "change new_cost = "; new_cost#toPretty; NL]) ; - + if new_cost#isBottom then new_cost else if new_cost#isTop then @@ -845,25 +837,25 @@ object (self:_) STR ": ";callee#toPretty]); new_cost end in - + if userdata#has_methodcost callee#index then begin let method_cost = userdata#get_methodcost callee#index in - + (if !dbg then pr__debug [STR "get_methodcall_cost: user data method_cost "; method_cost#toPretty; NL]) ; - + change (cost_bounds_from_jterm_range method_cost) [] end else if H.mem methodcoststore callee#index then begin let method_cost = H.find methodcoststore callee#index in - + (if !dbg then pr__debug [STR "get_methodcall_cost: analyzed method_cost "; NL; method_cost#toPretty; NL]); - + change method_cost [] end else if (app#has_method callee && (app#get_method callee)#is_stubbed) then @@ -872,55 +864,55 @@ object (self:_) let mInfo = app#get_method caller in let (is_top, cost, default_map) = self#get_library_method_timecost mInfo pc callee summary in - + let _ = if !dbg then pr__debug [STR "get_methodcall_cost: summary method_cost: "; NL; cost#toPretty; NL] in - + if is_top then cost else change cost default_map - end + end else begin let cost = cost_bounds_from_jterm_range (default_funcall_cost "funcall_default_no_summary") in - + pr__debug [STR "get_methodcall_cost: default_functioncall_cost (no method summary) for "; INT caller#index; STR " "; INT pc; STR " "; INT callee#index; NL; caller#toPretty; NL; - callee#toPretty; NL]; - + callee#toPretty; NL]; + chlog#add "default function call cost" (LBLOCK [ caller#toPretty ; STR " @pc:" ; INT pc ; STR " - " ; callee#toPretty ; STR ": " ; cost#toPretty ]) ; cost end in - + (if !dbg then pr__debug [STR " get_methodcall_cost res = "; res#toPretty; NL]) ; - - res + + res method private get_instr_cost (cmsix:int) (pc:int) (opcode:opcode_t): cost_bounds_t = - + (if !dbg then pr__debug [STR "_______________________"; NL; STR "get_instr_time_cost "; INT pc; NL]) ; - - let res = + + let res = if userdata#has_instructioncost cmsix pc then begin - + (if !dbg then pr_debug [STR "userdata#has_instructioncost "; NL]) ; - + let cost = userdata#get_instructioncost cmsix pc in cost_bounds_from_jterm_range cost end @@ -931,50 +923,50 @@ object (self:_) | OpInvokeSpecial _ | OpInvokeStatic _ | OpInvokeInterface _ -> - let cost_callee = + let cost_callee = let caller = retrieve_cms cmsix in let callees = match userdata#get_callees cmsix pc with | [] -> callgraph_base#get_pc_callees cmsix pc | l -> l in - + (if !dbg then pr__debug [STR "callees "; pp_list callees; NL]) ; - + if (List.length callees) = 0 then begin let cms = retrieve_cms cmsix in - + (if !dbg then pr__debug [STR "no callees at pc = "; INT pc ; - STR " "; cms#toPretty ; STR ": " ; + STR " "; cms#toPretty ; STR ": " ; opcode_to_pretty opcode; NL]) ; - + chlog#add "no callees" - (LBLOCK [ STR "pc = " ; INT pc ; STR " "; cms#toPretty ; STR ": " ; + (LBLOCK [ STR "pc = " ; INT pc ; STR " "; cms#toPretty ; STR ": " ; opcode_to_pretty opcode ] ); cost_bounds_from_jterm_range (default_funcall_cost ("default_funcall_no_callees_")) end - else + else begin let sorted_inds = List.sort compare (List.map (fun c -> c#index) callees) in - + (if (List.length sorted_inds) > (IntCollections.set_of_list sorted_inds)#size then - + pr__debug [STR "found duplicate callees: "; NL; pp_list callees; NL]) ; - - let call_cost = + + let call_cost = begin let add_cost acc callee = - + (if !dbg then pr__debug [NL; STR "add_cost "; callee#toPretty; NL]) ; - + if acc#isTop then top_cost_bounds else @@ -987,12 +979,12 @@ object (self:_) List.fold_left add_cost self#mk_bottom callees in call_cost end in - + let const_lb = find_const_lb true call_cost in - + (if !dbg then pr__debug [STR "call_cost = "; call_cost#toPretty; NL]) ; - + if is_const_range call_cost then call_cost else @@ -1006,7 +998,7 @@ object (self:_) end else begin - let lb = + let lb = let const_lb = find_const_lb true call_cost in if const_lb#lt numerical_zero then numerical_zero else const_lb in @@ -1015,31 +1007,31 @@ object (self:_) add_pos_jterm_final pc sym_cost call_cost in coststore_final#set sorted_inds call_cost_final ; bounds_from_jterms false [sym_cost] [sym_cost] - end + end end end in let cost_op = cost_bounds_from_jterm_range (self#get_opcode_cost opcode) in add_cost_bounds cost_op cost_callee | _ -> - cost_bounds_from_jterm_range (self#get_opcode_cost opcode) + cost_bounds_from_jterm_range (self#get_opcode_cost opcode) end in - + (if !dbg then pr__debug [STR "get_instr_cost res = "; res#toPretty; NL]) ; - + res - + method print_cost_stores () = - pr__debug [NL; NL; STR "final costs: "; NL; coststore_final#toPretty; NL] - + pr__debug [NL; NL; STR "final costs: "; NL; coststore_final#toPretty; NL] + method save_xml_class (cInfo:class_info_int) = if cInfo#is_stubbed || cInfo#is_missing then () else let _ = pr_debug [ STR " -- " ; cInfo#get_class_name#toPretty ; NL ] in - + let cn = cInfo#get_class_name in let node = xmlElement "class" in begin @@ -1048,7 +1040,7 @@ object (self:_) node#setAttribute "package" cn#package_name ; save_xml_cost_analysis_results cn node "class" end - + method save_xml_atlas_class (cInfo:class_info_int) = if cInfo#is_stubbed || cInfo#is_missing then () @@ -1062,7 +1054,7 @@ object (self:_) set "package" cn#package_name ; save_xml_atlas_cost_analysis_results cn node "class" end - + method private write_xml_method_cost_results node cms = let mInfo = app#get_method cms in let cmsix = cms#index in @@ -1095,7 +1087,7 @@ object (self:_) if not (hpcs = []) then begin let lsNode = xmlElement "loops" in - let get_cost_one_iteration hpc = + let get_cost_one_iteration hpc = H.find mcost hpc in let get_max_iterations hpc = if userdata#has_loopbound cmsix hpc then @@ -1106,7 +1098,7 @@ object (self:_) let (lbs_jterms, ubs_jterms) = JCHNumericAnalysis.get_iteration_bounds cmsix hpc in bounds_from_jterms false lbs_jterms ubs_jterms in - + let add_loop hpc = let lNode = xmlElement "loop" in lNode#setIntAttribute "hpc" hpc; @@ -1116,7 +1108,7 @@ object (self:_) lsNode#appendChildren (List.map add_loop hpcs) ; node#appendChildren [lsNode] end) ; - + (if H.mem sidechannelchecks cmsix then let ssNode = xmlElement "sidechannel-checks" in let mchecks = H.find sidechannelchecks cmsix in @@ -1135,8 +1127,8 @@ object (self:_) node#setIntAttribute "cmsix" cmsix ; (if mInfo#is_abstract then node#setAttribute "abstract" "yes") ; end - - method private write_xml_class_cost_results node cInfo = + + method private write_xml_class_cost_results node cInfo = let mmNode = xmlElement "methods" in begin mmNode#appendChildren @@ -1149,13 +1141,13 @@ object (self:_) end) cInfo#get_methods_defined) ; node#appendChildren [ mmNode ] end - + method private write_xml_atlas_cost (node:xml_element_int) (ms:method_signature_int) (b:cost_bounds_t) = write_xml_atlas_bounds node ms b - + method private write_xml_atlas_method_cost_results (node:xml_element_int) (cms:class_method_signature_int) = let set = node#setAttribute in @@ -1204,13 +1196,13 @@ object (self:_) bNodes ) | false -> pr_debug [ STR "No blocks" ; NL ]) | false -> pr_debug [ STR "No blocks node" ; NL ] ) ; - + (if node#hasNamedAttribute "imcost" then let mCost = self#read_xml_cost ~tag:"imcost" node in (self#set_methodcost cms mCost) ) ; end - - method private read_xml_class_cost_results node (cInfo:class_info_int) = + + method private read_xml_class_cost_results node (_cInfo:class_info_int) = let mmNode = node#getTaggedChild "methods" in let mNodes = mmNode#getTaggedChildren "method" in (List.iter self#read_xml_method_cost_results mNodes) @@ -1228,4 +1220,3 @@ object (self:_) self#read_xml_class_cost_results node cInfo end end - diff --git a/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.mli b/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.mli index de47234c..155bca31 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostBoundsModel.mli @@ -3,8 +3,9 @@ Author: Henny Sipma and Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -39,7 +40,7 @@ open JCHPreAPI (* jchcost *) open JCHCostBounds - + val dbg : bool ref val get_timecost_diagnostics : unit -> pretty_t @@ -87,4 +88,3 @@ class costmodel_t : sidechannelcheck_t list -> end val set_symbolic_defaults : bool -> unit - diff --git a/CodeHawk/CHJ/jchcost/jCHCostModelUtil.ml b/CodeHawk/CHJ/jchcost/jCHCostModelUtil.ml index 725ec41d..9d6706d1 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostModelUtil.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostModelUtil.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcost/jCHCostModelUtil.mli b/CodeHawk/CHJ/jchcost/jCHCostModelUtil.mli index e2a41a73..3398107c 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostModelUtil.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostModelUtil.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcost/jCHCostUtils.ml b/CodeHawk/CHJ/jchcost/jCHCostUtils.ml index d3ca5c3f..602885f4 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostUtils.ml +++ b/CodeHawk/CHJ/jchcost/jCHCostUtils.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -26,30 +27,26 @@ ============================================================================= *) (* chlib *) -open CHLanguage open CHNumerical -open CHPretty +open CHPretty open CHUtils (* chutil *) open CHLogger -open CHPrettyUtil (* jchlib *) open JCHBasicTypes open JCHBasicTypesAPI open JCHJTerm -(* jchsys *) -open JCHPrintUtils let max_num = mkNumerical 100000 -let margin_num = mkNumerical 10 +let margin_num = mkNumerical 10 let max_int_num = mkNumerical 2147483647 -let max_long_num = mkNumericalFromString "9223372036854775807" +let max_long_num = mkNumericalFromString "9223372036854775807" let sym_max_int = JSymbolicConstant - (TBasic Long, Some max_int_num, Some max_int_num, "max_int") + (TBasic Long, Some max_int_num, Some max_int_num, "max_int") let sym_max_long = JSymbolicConstant (TBasic Long, Some max_long_num, Some max_long_num, "max_long") @@ -111,13 +108,13 @@ let rec is_sym_lc_or_call_term (jterm:jterm_t) = s = "call_" || s = "lc_m_" else false - | _ -> false + | _ -> false let rec is_local_var (check_length:bool) (jterm:jterm_t) = match jterm with | JLocalVar _ -> true - | JSize jt -> if check_length then is_local_var true jt else false - | _ -> false + | JSize jt -> if check_length then is_local_var true jt else false + | _ -> false let cost_var = ref None let set_cost_var v = cost_var := Some v @@ -125,7 +122,7 @@ let get_cost_var () = Option.get !cost_var let compare_num (n1:numerical_t) (n2:numerical_t) = n1#compare n2 - + let compare_tables (compare_keys:('a -> 'a -> int)) (compare_elements:('b -> 'c -> int)) @@ -148,7 +145,7 @@ let compare_tables | [] -> 0 in comp sorted_keys -module JTermCollections = CHCollections.Make +module JTermCollections = CHCollections.Make (struct type t = jterm_t let compare j1 j2 = jterm_compare j1 j2 @@ -162,19 +159,19 @@ module JTermTableCollections = CHCollections.Make let toPretty t = t#toPretty end) -let is_length (jterm:jterm_t) = +let is_length (jterm:jterm_t) = match jterm with | JSize _ -> true | _ -> false let is_field (jterm:jterm_t) = match jterm with - | JStaticFieldValue _ + | JStaticFieldValue _ | JObjectFieldValue _ -> true | _ -> false let not_pos_jterms = new IntCollections.table_t - + let add_not_pos_jterm (cmix:int) (jterm:jterm_t) = let key = if is_field jterm then (-1) else cmix in match not_pos_jterms#get key with @@ -191,7 +188,7 @@ let record_not_pos_jterms () = (LBLOCK[STR "fields "; set#toPretty; NL]) | _ -> ()) ; let record_set (key, set) = - if key != (-1) then + if key != (-1) then chlog#add "not known to be positive " (LBLOCK[STR "method "; INT key; set#toPretty; NL]) in @@ -199,7 +196,7 @@ let record_not_pos_jterms () = let is_const (jt:jterm_t) = match jt with - | JConstant n -> true + | JConstant _ -> true | _ -> false let is_large_const (jt:jterm_t) = @@ -207,13 +204,13 @@ let is_large_const (jt:jterm_t) = | JConstant n when n#gt max_num -> true | _ -> false -let is_pos_jterm (jt:jterm_t) = +let is_pos_jterm (jt:jterm_t) = match jt with - | JConstant n + | JConstant n | JSymbolicConstant (_, Some n, _, _) -> - n#geq numerical_zero + n#geq numerical_zero | JSize _ -> true - | _ -> JCHNumericAnalysis.is_pos_field jt + | _ -> JCHNumericAnalysis.is_pos_field jt let pp_list_jterm (jts:jterm_t list) = pretty_print_list jts jterm_to_pretty "{" "; " "}" @@ -225,9 +222,9 @@ let rec no_local_vars (jterm:jterm_t) = | _ -> true let no_calls_or_lcs (lcs_to_keep:JTermCollections.set_t) (jterm:jterm_t) = - match jterm with + match jterm with | JSymbolicConstant _ -> - if is_sym_call jterm then false + if is_sym_call jterm then false else if is_sym_lc jterm then if lcs_to_keep#has jterm then false else true @@ -236,12 +233,12 @@ let no_calls_or_lcs (lcs_to_keep:JTermCollections.set_t) (jterm:jterm_t) = let no_cost_calls_or_lcs (lcs_to_keep:JTermCollections.set_t) (jterm:jterm_t) = - match jterm with + match jterm with | JSymbolicConstant _ -> if is_sym_cost jterm then false else if is_sym_call jterm then - false + false else if is_sym_lc jterm then if lcs_to_keep#has jterm then false @@ -253,9 +250,9 @@ let no_cost_calls_or_lcs let no_loop_costs (jterm:jterm_t) = not (is_sym_lp jterm) - -let remove_pc (jterm:jterm_t) = - match jterm with + +let _remove_pc (jterm:jterm_t) = + match jterm with | JSymbolicConstant (t, lb, ub, name) -> if (String.length name) > 5 && (String.sub name 0 5) = "call_" then begin @@ -269,11 +266,11 @@ let remove_pc (jterm:jterm_t) = let max_cost_analysis_time = ref 1. let set_max_cost_analysis_time m = max_cost_analysis_time := m - + exception JCH_cost_out_of_time of string - + let cost_time_limit = ref 1. -let start_cost_analysis () = +let start_cost_analysis () = cost_time_limit := Sys.time () +. !max_cost_analysis_time let check_cost_analysis_time (str:string) = @@ -282,5 +279,3 @@ let check_cost_analysis_time (str:string) = let str = "reached cost analysis time limit " ^ str in raise (JCH_cost_out_of_time str) end - - diff --git a/CodeHawk/CHJ/jchcost/jCHCostUtils.mli b/CodeHawk/CHJ/jchcost/jCHCostUtils.mli index 112636c4..9f538e6e 100644 --- a/CodeHawk/CHJ/jchcost/jCHCostUtils.mli +++ b/CodeHawk/CHJ/jchcost/jCHCostUtils.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -44,7 +45,7 @@ val sym_max_long: jterm_t val make_sym_lc : int -> int -> numerical_t -> numerical_t option -> jterm_t - + val is_sym_lc: jterm_t -> bool val make_sym_lp: int -> int -> numerical_t -> jterm_t val is_sym_lp: jterm_t -> bool @@ -55,10 +56,10 @@ val make_sym_cost : int list -> numerical_t -> int -> jterm_t val set_cost_var : variable_t -> unit val get_cost_var : unit -> variable_t - + val compare_num : numerical_t -> numerical_t -> int - -val compare_tables : + +val compare_tables : ('a -> 'a -> int) -> ('b -> 'c -> int) -> < get: 'a -> 'b option; keys: < union : 'd -> < toList : 'a list; .. >; .. >; .. > @@ -170,8 +171,8 @@ module JTermTableCollections : val is_length: jterm_t -> bool val is_field: jterm_t -> bool val is_sym_lc_or_call_term: jterm_t -> bool -val is_local_var: bool -> jterm_t -> bool - +val is_local_var: bool -> jterm_t -> bool + val add_not_pos_jterm: int -> jterm_t -> unit val record_not_pos_jterms : unit -> unit val is_pos_jterm: jterm_t -> bool diff --git a/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.ml b/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.ml index fde08f59..8adf2b09 100644 --- a/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.ml +++ b/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.mli b/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.mli index 4bdadbd3..3fc79447 100644 --- a/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.mli +++ b/CodeHawk/CHJ/jchcost/jCHLoopCostAbstractor.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.ml b/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.ml index a392444d..ab5c230e 100644 --- a/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.ml +++ b/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -26,44 +27,34 @@ ============================================================================= *) (* chlib *) -open CHAtlas -open CHBounds -open CHIntervals open CHLanguage -open CHNumerical -open CHOnlineCodeSet open CHPretty -open CHSCC -open CHUtils (* chutil *) -open CHLogger open CHLoopStructure open CHPrettyUtil (* jchlib *) -open JCHBasicTypes -open JCHBasicTypesAPI open JCHDictionary (* jchpre *) open JCHCodegraph open JCHCostBoundsModel -open JCHPreAPI + module H = Hashtbl module LF = CHOnlineCodeSet.LanguageFactory let dbg = ref false - + let make_label pc = new symbol_t (string_of_int pc) let getloopstructure (bblocks:(int * int * int list) list) = - let succ = List.concat + let succ = List.concat (List.map (fun (pc,_,succ) -> List.map (fun s -> (pc,s)) succ) bblocks) in get_loop_structure 0 succ -let loopstruct_to_pretty (loopstruct: loop_structure_int) = +let _loopstruct_to_pretty (loopstruct: loop_structure_int) = let pp_loop lh = LBLOCK [STR "loop "; INT lh; STR " "; pp_list_int (loopstruct#get_loop lh); NL] in @@ -82,11 +73,11 @@ object (self) let res = getloopstructure basicblocks in costmodel#set_loopstructure cmsix res; res - + method private isinloop (loophead:int) (pc:int) = loopstructure#is_inloop_with_loophead pc loophead - method private getloop (loophead:int) = loopstructure#get_loop loophead + method private getloop (loophead:int) = loopstructure#get_loop loophead method private get_nosuccessor_pcs = List.map @@ -105,10 +96,10 @@ object (self) let node = make_label obspc in let preds = self#getpredecessors obspc in let preds = - List.map (fun p -> + List.map (fun p -> let atts = [ string_of_int decpc ; string_of_int p ; string_of_int obspc ] in - let invop = OPERATION ( { op_name = new symbol_t ~atts "sink" ; + let invop = OPERATION ( { op_name = new symbol_t ~atts "sink" ; op_args = [] }) in (make_label p,[invop])) preds in graph#sink_transform ~node ~preds @@ -124,7 +115,7 @@ object (self) (make_label p,[invop])) preds in graph#sink_transform ~node ~preds - method private request_num_var (name:symbol_t) = + method private request_num_var (name:symbol_t) = let v = scope#mkVariable name NUM_VAR_TYPE in begin H.add vartable name#getBaseName v ; @@ -137,10 +128,12 @@ object (self) method iter (f:(int * int * int list) -> unit) = List.iter f self#get_blocks - method private get_costcommand bvar cvar pcstart pcend = + method private get_costcommand bvar _cvar pcstart pcend = let _ = costmodel#compute_block_cost cmsix pcstart pcend in - let op_sym = new symbol_t ~atts:[string_of_int pcstart; string_of_int pcend] "block_cost" in - OPERATION ({op_name = op_sym; op_args = [("dst", bvar, WRITE)]}) + let op_sym = + new symbol_t + ~atts:[string_of_int pcstart; string_of_int pcend] "block_cost" in + OPERATION ({op_name = op_sym; op_args = [("dst", bvar, WRITE)]}) method to_chifproc = let cms = retrieve_cms cmsix in @@ -149,9 +142,9 @@ object (self) JCHCostUtils.set_cost_var cvar ; let bvar = self#request_num_var (new symbol_t "bcost") in - (* add a side-channel cost variable for each pair of decision-pc and observation-pc - that gets initialized to zero at the decision-pc and gets incremented with the - block cost at every other pc. *) + (* add a side-channel cost variable for each pair of decision-pc and + observation-pc that gets initialized to zero at the decision-pc and + gets incremented with the block cost at every other pc. *) let scvars = List.map (fun (decpc,obspc) -> let name = "sink_" ^ (string_of_int decpc) ^ "_" ^ @@ -176,13 +169,13 @@ object (self) string_of_int pcend] "add_block_cost" ; op_args = [("dst_src", cvar, READ_WRITE); ("src", bvar, READ)] }) in - (* assign zero to side channel variable at the decision pc, otherwise + (* assign zero to side channel variable at the decision pc, otherwise * increment with the blockcost *) let scasgs = List.map (fun (decpc,_,scvar) -> if decpc = pcstart then OPERATION ({op_name = new symbol_t ~atts:["0"] "set_to_0" ; - op_args = [("dst", scvar, WRITE)] }) + op_args = [("dst", scvar, WRITE)] }) else OPERATION ({op_name = @@ -190,13 +183,15 @@ object (self) ~atts:[string_of_int pcstart; string_of_int pcend] "add_block_cost" ; op_args = - [("dst_src", scvar, READ_WRITE); ("src", bvar, READ)] })) scvars in + [("dst_src", scvar, READ_WRITE); ("src", bvar, READ)]})) scvars in let node_cmds = if loopstructure#is_loophead pcstart then begin - let op = OPERATION - ({ op_name = new symbol_t ~atts:[string_of_int pcstart] "add_loop_cost"; - op_args = [("dst", cvar, WRITE)]}) in + let op = + OPERATION + ({op_name = + new symbol_t ~atts:[string_of_int pcstart] "add_loop_cost"; + op_args = [("dst", cvar, WRITE)]}) in let scops = List.map (fun (_,_,scvar) -> OPERATION @@ -208,7 +203,7 @@ object (self) end else cost_command :: asg :: scasgs in graph#add_node (make_label pcstart) node_cmds ; - (if pcstart = 0 then + (if pcstart = 0 then graph#add_edge (new symbol_t "entry") (make_label pcstart)) ; match successors with | [] -> graph#add_edge (make_label pcstart) (new symbol_t "exit") @@ -224,12 +219,13 @@ object (self) else if obspc = (-1) then self#do_exit_sink_transform decpc else - ()) scvars in + ()) scvars in let cfg = graph#to_cfg (new symbol_t "entry") (new symbol_t "exit") in let body = LF.mkCode [ CFG (procname, cfg) ] in - let chif_proc = LF.mkProcedure procname ~signature:[] ~bindings:[] ~scope ~body in + let chif_proc = + LF.mkProcedure procname ~signature:[] ~bindings:[] ~scope ~body in let chif_proc = JCHLoopCostAbstractor.remove_loops chif_proc loopstructure in - + (* sort the loops so that inner loops are analyzed before outer loops *) let sorted_loop_heads = let compare_heads h1 h2 = @@ -243,17 +239,15 @@ object (self) res in try (JCHLoopCostAbstractor.remove_dead_end_states chif_proc loopstructure, - List.map make_loop_proc sorted_loop_heads) + List.map make_loop_proc sorted_loop_heads) with _ -> - (* remove_dead_end_states does not work for servers *) + (* remove_dead_end_states does not work for servers *) (chif_proc, List.map make_loop_proc sorted_loop_heads) - - method toPretty = - LBLOCK (List.map (fun (pc,_,succ) -> - LBLOCK [ INT pc ; pretty_print_list succ (fun i -> INT i) "" ", " "]" ; NL ]) + + method toPretty = + LBLOCK (List.map (fun (pc,_,succ) -> + LBLOCK [ INT pc ; pretty_print_list succ (fun i -> INT i) "" ", " "]" ; NL ]) basicblocks) end - - diff --git a/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.mli b/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.mli index add4f471..a89414e5 100644 --- a/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.mli +++ b/CodeHawk/CHJ/jchcost/jCHMethodCostBoundsAbstractor.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -45,4 +46,3 @@ class method_cost_abstractor_t : method toPretty : pretty_t method to_chifproc : procedure_int * (int * procedure_int) list end - diff --git a/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.ml b/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.ml index c30e0f82..c623ee58 100644 --- a/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.ml +++ b/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.ml @@ -3,8 +3,9 @@ Author: Andrew McGraw and Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE diff --git a/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.mli b/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.mli index 164e61d8..5ee213c1 100644 --- a/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.mli +++ b/CodeHawk/CHJ/jchcost/jCHOpcodeCosts.mli @@ -5,6 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/dune b/CodeHawk/CHJ/jchfeatures/dune index f4aa5fb3..67608093 100644 --- a/CodeHawk/CHJ/jchfeatures/dune +++ b/CodeHawk/CHJ/jchfeatures/dune @@ -3,7 +3,3 @@ (libraries chlib chutil extlib jchlib jchpre) (public_name codehawk.jchfeatures) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.ml b/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.ml index 0f5b3d7b..0ee4969d 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.ml +++ b/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.mli b/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.mli index 96ef0886..b4b0c31d 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHExprFeatureExtraction.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.ml b/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.ml index b82612b5..bb2ddc4a 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.ml +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.mli b/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.mli index f72b6aa1..7135c440 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureDictionary.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.ml b/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.ml index b8b3efbb..1ff776fa 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.ml +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.mli b/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.mli index 4ef09c72..058a04b0 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureExtraction.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.ml b/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.ml index cfb33a3c..557dd8c6 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.ml +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.mli b/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.mli index e280f018..e96afe11 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHFeatureSumTypeSerializer.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHFeaturesAPI.mli b/CodeHawk/CHJ/jchfeatures/jCHFeaturesAPI.mli index f33d93da..8e5aff51 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHFeaturesAPI.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHFeaturesAPI.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.ml b/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.ml index eabd0cc9..2bc08a63 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.ml +++ b/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.mli b/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.mli index 13f033c9..667cff2c 100644 --- a/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.mli +++ b/CodeHawk/CHJ/jchfeatures/jCHMethodExprs.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchlib/dune b/CodeHawk/CHJ/jchlib/dune index abd5a860..02662f65 100644 --- a/CodeHawk/CHJ/jchlib/dune +++ b/CodeHawk/CHJ/jchlib/dune @@ -3,7 +3,3 @@ (libraries chlib chutil extlib str zarith zip) (public_name codehawk.jchlib) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchmuse/dune b/CodeHawk/CHJ/jchmuse/dune index c2d7a9f0..0105262d 100644 --- a/CodeHawk/CHJ/jchmuse/dune +++ b/CodeHawk/CHJ/jchmuse/dune @@ -25,7 +25,3 @@ (modules jCHXCollectPatterns) (package exes) (public_name chj_patterns)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchmuse/jCHXClassPoly.ml b/CodeHawk/CHJ/jchmuse/jCHXClassPoly.ml index 8b49a97c..83159c7a 100644 --- a/CodeHawk/CHJ/jchmuse/jCHXClassPoly.ml +++ b/CodeHawk/CHJ/jchmuse/jCHXClassPoly.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchmuse/jCHXCollectPatterns.ml b/CodeHawk/CHJ/jchmuse/jCHXCollectPatterns.ml index 625a8bf2..38ec064a 100644 --- a/CodeHawk/CHJ/jchmuse/jCHXCollectPatterns.ml +++ b/CodeHawk/CHJ/jchmuse/jCHXCollectPatterns.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchmuse/jCHXExtractExprFeatures.ml b/CodeHawk/CHJ/jchmuse/jCHXExtractExprFeatures.ml index 4b1282f7..0a9409fc 100644 --- a/CodeHawk/CHJ/jchmuse/jCHXExtractExprFeatures.ml +++ b/CodeHawk/CHJ/jchmuse/jCHXExtractExprFeatures.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchmuse/jCHXExtractFeatures.ml b/CodeHawk/CHJ/jchmuse/jCHXExtractFeatures.ml index e7f49ecc..6d799930 100644 --- a/CodeHawk/CHJ/jchmuse/jCHXExtractFeatures.ml +++ b/CodeHawk/CHJ/jchmuse/jCHXExtractFeatures.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2023 Henny B. Sipma - Copyright (c) 2024 Aarno Labs LLC + Copyright (c) 2024-2025 Aarno Labs LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/dune b/CodeHawk/CHJ/jchpoly/dune index 4e803960..3bb38860 100644 --- a/CodeHawk/CHJ/jchpoly/dune +++ b/CodeHawk/CHJ/jchpoly/dune @@ -3,7 +3,3 @@ (libraries chlib chutil jchlib jchpre jchsys zarith) (public_name codehawk.jchpoly) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.ml b/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.ml index 46d5f5e6..04227a28 100755 --- a/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.ml +++ b/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -30,9 +31,7 @@ open Big_int_Z (* chlib *) open CHAtlas open CHIntervals -open CHLanguage -open CHNonRelationalDomainValues -open CHNonRelationalDomainNoArrays +open CHLanguage open CHNumerical open CHPretty open CHUtils @@ -54,9 +53,9 @@ open JCHGlobals open JCHPrintUtils let current_proc_name = ref proc_name_sym -let current_jproc_info = ref None -let set_current_proc_name proc_name = - current_proc_name := proc_name ; +let current_jproc_info = ref None +let set_current_proc_name proc_name = + current_proc_name := proc_name; current_jproc_info := Some (JCHSystem.jsystem#get_jproc_info !current_proc_name) let get_current_proc_name () = !current_proc_name let get_current_jproc_info () = Option.get (!current_jproc_info) @@ -69,61 +68,62 @@ let jch_op_semantics ~(invariant: atlas_t) ~(stable: bool) ~(fwd_direction: bool) - ~context ~(operation: operation_t) = - let setWriteVarsToTop = + ~context:_ + ~(operation: operation_t) = + let setWriteVarsToTop = let write_vars = JCHSystemUtils.get_write_vars operation.op_args in if write_vars = [] then invariant else invariant#analyzeFwd (ABSTRACT_VARS write_vars) in match operation.op_name#getBaseName with - | "loop_cond" + | "loop_cond" | "check_loop" | "save_interval" | "v" -> invariant - | "exit" -> - if fwd_direction && stable then + | "exit" -> + if fwd_direction && stable then set_exit_invariant invariant - else - () ; + else + (); invariant | "i" - | "ii" -> + | "ii" -> let mInfo = app#get_method (retrieve_cms !current_proc_name#getSeqNumber) in let pc = operation.op_name#getSeqNumber in begin match mInfo#get_opcode pc with - | OpBreakpoint (* used for debugging only *) - | OpIfNull _ - | OpIfNonNull _ - | OpIfCmpAEq _ + | OpBreakpoint (* used for debugging only *) + | OpIfNull _ + | OpIfNonNull _ + | OpIfCmpAEq _ | OpIfCmpANe _ (* The 3 above are just branches *) - | OpCheckCast _ -> (* checks that a ref is of a certain type, - return same variable or throws exception. NOT SURE *) - invariant + | OpCheckCast _ -> (* checks that a ref is of a certain type, + return same variable or throws exception. NOT SURE *) + invariant | _ -> setWriteVarsToTop end | "e" -> invariant | "exn-exit" -> invariant | "method-init" -> invariant - | _ -> + | _ -> pr__debug [STR "unknown operation in op_semantics "; - operation_to_pretty operation; NL; - pp_list_str operation.op_name#getSymbol; NL] ; + operation_to_pretty operation; NL; + pp_list_str operation.op_name#getSymbol; NL]; setWriteVarsToTop - + exception JCH_num_analysis_failure of string -class numeric_run_params_t = +class numeric_run_params_t = object val analysis_level = ref 1 (* larger level -> more precise analysis *) val use_types = ref true (* if true then use type intervals *) - (* if true then use only intervals for all analysis form the beginning *) + (* if true then use only intervals for all analysis form the beginning *) val system_use_intervals = ref false - (* if true then use only intervals if system_use_intervals is true or - * when the analysis of the proc is too long, etc. *) + (* if true then use only intervals if system_use_intervals is true or + * when the analysis of the proc is too long, etc. *) val use_intervals = ref false val use_loop_counters = ref true @@ -131,19 +131,19 @@ class numeric_run_params_t = val use_overflow = ref true (* used in JCHIntervalArray; - * 80 seemed too large: on xerces, - * swap space went up to 21GB *) - val interval_array_size = 50 + * 80 seemed too large: on xerces, + * swap space went up to 21GB *) + val interval_array_size = 50 val max_number_rays = ref 400 - (* largest coefficient allowed in a constraint *) + (* largest coefficient allowed in a constraint *) val max_poly_coefficient = ref (big_int_of_int 1000) - (* maximum number of constraints encountered in the analysis *) + (* maximum number of constraints encountered in the analysis *) val max_number_constraints = ref 0 - (* maximum number of constraints allowed *) + (* maximum number of constraints allowed *) val max_number_constraints_allowed = ref 20 val max_number_vars_in_constrant_allowed = ref 3 @@ -153,86 +153,86 @@ class numeric_run_params_t = val use_time_limits = ref false val st_time = ref 0.0 val max_numeric_analysis_time = ref 500.0 - val drop_constraint_analysis_time = ref 100.0 + val drop_constraint_analysis_time = ref 100.0 val time_limit = ref 0.0 val drop_constraint_analysis_time_limit = ref 0.0 - (* 0: fine; 1: failed - continue with intervals; - * 2: retry with intervals; - * 3: abort - various problems; - * 10: abort - out of time *) + (* 0: fine; 1: failed - continue with intervals; + * 2: retry with intervals; + * 3: abort - various problems; + * 10: abort - out of time *) val analysis_status = ref 0 - val analysis_failure_reason = ref "" + val analysis_failure_reason = ref "" val max_swap = ref 1500 (* 20000 *) val min_swap_freed = 500 (* 10000 *) - val swap_increase = 500 + val swap_increase = 500 val swap_used = ref 0 val initial_swap = ref 0 val create_model = ref false method set_analysis_level (n:int) = analysis_level := n - + method analysis_level = !analysis_level method set_use_types (b:bool) = use_types := b method use_types = !use_types - method set_system_use_intervals (b:bool) = - system_use_intervals := b ; + method set_system_use_intervals (b:bool) = + system_use_intervals := b; use_intervals := b method get_system_use_intervals = !system_use_intervals method set_use_intervals (b:bool) = begin - use_intervals := b ; + use_intervals := b; if b then pr__debug [STR "set use_intervals to true"; NL] end method use_intervals = !use_intervals method set_use_lengths (b:bool) = use_lengths := b - + method use_lengths = !use_lengths method set_use_loop_counters (b:bool) = use_loop_counters := b - + method use_loop_counters = !use_loop_counters method set_use_overflow (b:bool) = use_overflow := b - + method use_overflow = !use_overflow - method interval_array_size = interval_array_size + method interval_array_size = interval_array_size method set_max_number_rays (n:int) = max_number_rays := n - + method max_number_rays = !max_number_rays method set_max_poly_coefficient (n:int) = max_poly_coefficient := big_int_of_int n - + method max_poly_coefficient = !max_poly_coefficient - - method is_good_coefficient n = + + method is_good_coefficient n = le_big_int n !max_poly_coefficient && le_big_int (minus_big_int !max_poly_coefficient) n - method record_number_constraints (n:int) = - max_number_constraints := max n !max_number_constraints + method record_number_constraints (n:int) = + max_number_constraints := max n !max_number_constraints method max_number_constraints = !max_number_constraints method set_max_number_constraints_allowed (n:int) = max_number_constraints_allowed := n - + method max_number_constraints_allowed = !max_number_constraints_allowed method set_max_number_vars_in_constraint_allowed (n:int) = max_number_vars_in_constrant_allowed := n - + method max_number_vars_in_constraint_allowed = !max_number_vars_in_constrant_allowed @@ -243,59 +243,63 @@ class numeric_run_params_t = end method set_number_joins (n:int) = number_joins := n - + method number_joins = !number_joins method start_numeric_analysis_time = begin - st_time := Sys.time () ; - time_limit := !st_time +. !max_numeric_analysis_time ; + st_time := Sys.time (); + time_limit := !st_time +. !max_numeric_analysis_time; drop_constraint_analysis_time_limit := !st_time +. !drop_constraint_analysis_time end method set_use_time_limits (b:bool) = use_time_limits := b - method set_constraint_analysis_time_limit (n:int) = + method set_constraint_analysis_time_limit (n:int) = drop_constraint_analysis_time := float n method set_numeric_analysis_time_limit (n:int) = begin - pr__debug [STR "set_numeric_analysis_time_limit "; INT n; NL] ; + pr__debug [STR "set_numeric_analysis_time_limit "; INT n; NL]; max_numeric_analysis_time := float n end - method reached_constraint_analysis_time_limit = + method reached_constraint_analysis_time_limit = Sys.time () > !drop_constraint_analysis_time_limit - method reached_numeric_analysis_time_limit = + method reached_numeric_analysis_time_limit = Sys.time () > !time_limit - - method check_time_limit = + + method check_time_limit = if not !use_time_limits then 0 else if Sys.time () > !time_limit then - if !use_intervals then + if !use_intervals then begin analysis_status := 10; analysis_failure_reason := "reached analysis time limit"; 10 end - else + else begin analysis_status := 1; - analysis_failure_reason := "reached analysis time limit with constraints"; + analysis_failure_reason := + "reached analysis time limit with constraints"; use_intervals := true; - pr_debug [STR "set use_intervals to true"; NL] ; - time_limit := Sys.time() +. !drop_constraint_analysis_time ; (* give some more time *) + pr_debug [STR "set use_intervals to true"; NL]; + time_limit := + Sys.time() + +. !drop_constraint_analysis_time; (* give some more time *) 1 end - else if Sys.time () > !drop_constraint_analysis_time_limit && not !use_intervals then + else if Sys.time () > !drop_constraint_analysis_time_limit + && not !use_intervals then begin analysis_status := 1; analysis_failure_reason := "reached constraint analysis time limit"; use_intervals := true; - pr_debug [STR "set use_intervals to true"; NL] ; + pr_debug [STR "set use_intervals to true"; NL]; 1 end else @@ -303,10 +307,10 @@ class numeric_run_params_t = method analysis_failed (status:int) (str:string) = begin - analysis_status := status ; - analysis_failure_reason := str ; - pr__debug [STR "analysis_failed "; INT status; STR (" " ^ str); NL] ; - (if status = 1 then use_intervals := true) ; + analysis_status := status; + analysis_failure_reason := str; + pr__debug [STR "analysis_failed "; INT status; STR (" " ^ str); NL]; + (if status = 1 then use_intervals := true); JCH_num_analysis_failure str end @@ -323,16 +327,16 @@ class numeric_run_params_t = let numeric_params = new numeric_run_params_t -let has_untranslated_caller (proc_name:symbol_t) = +let has_untranslated_caller (proc_name:symbol_t) = let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let method_info = jproc_info#get_method_info in let callers = method_info#get_callers in - let untranslated cmsg = + let untranslated cmsg = let mInfo = app#get_method cmsg in - match mInfo#get_implementation with + match mInfo#get_implementation with | UntranslatedConcreteMethod _ -> true | _ -> false in - List.exists untranslated callers + List.exists untranslated callers let get_slot_interval (slot:logical_stack_slot_int) = match slot#get_value#to_interval with @@ -340,33 +344,33 @@ let get_slot_interval (slot:logical_stack_slot_int) = | _ -> topInterval (* It could be a collection *) -let is_collection (jproc_info: JCHProcInfo.jproc_info_t) (var:variable_t) = +let is_collection (jproc_info: JCHProcInfo.jproc_info_t) (var:variable_t) = let jvar_info = jproc_info#get_jvar_info var in JCHTypeUtils.can_be_collection jvar_info#get_types - + (* It is for sure an array *) -let is_array (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = - try +let is_array (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = + try let var_info = jproc_info#get_jvar_info var in let types = var_info#get_types in - List.for_all JCHTypeUtils.is_array types + List.for_all JCHTypeUtils.is_array types with _ -> false let is_collection_or_array - (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = + (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = is_collection jproc_info var || is_array jproc_info var (* is number or wrapper or array of numbers - * Experiment: include all arrays as we need to keep track of the + * Experiment: include all arrays as we need to keep track of the * length of arrays in the numeric_info_t *) -let is_numeric (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = +let is_numeric (jproc_info:JCHProcInfo.jproc_info_t) (var:variable_t) = try let var_info = jproc_info#get_jvar_info var in - var_info#is_numeric || is_array jproc_info var - with _ -> false + var_info#is_numeric || is_array jproc_info var + with _ -> false -let float_to_interval (f:float) = - let big_int_of_float (f:float) = +let float_to_interval (f:float) = + let big_int_of_float (f:float) = let s = string_of_float f in let s' = try @@ -375,7 +379,7 @@ let float_to_interval (f:float) = | _ -> raise (JCH_failure - (LBLOCK [ STR "JCHAnalysisUtils:float_to_interval: " ; + (LBLOCK [ STR "JCHAnalysisUtils:float_to_interval: "; STR s ])) in big_int_of_string s' in let max = new numerical_t (big_int_of_float (ceil f)) in @@ -383,79 +387,79 @@ let float_to_interval (f:float) = (min, max, mkInterval min max) let get_length_vars - (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = + (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = let vars_with_lengths = ref [] in let lengths = ref [] in let length_to_var = new VariableCollections.table_t in - let add_var var = + let add_var var = try let len = Option.get (jproc_info#get_length var) in begin - lengths := len :: !lengths ; - vars_with_lengths := var :: !vars_with_lengths ; + lengths := len :: !lengths; + vars_with_lengths := var :: !vars_with_lengths; length_to_var#set len var end with _ -> () in begin - List.iter add_var vars ; + List.iter add_var vars; (List.rev !lengths , List.rev !vars_with_lengths, length_to_var) end let include_length_vars - (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = + (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = let lengths = ref [] in - let add_var var = + let add_var var = try - lengths := (Option.get (jproc_info#get_length var)) :: !lengths + lengths := (Option.get (jproc_info#get_length var)) :: !lengths with _ -> () in begin - List.iter add_var vars ; + List.iter add_var vars; vars @ (List.rev !lengths) end - + let include_all_length_vars (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) (vs:variable_t list) - (length_to_array: variable_t VariableCollections.table_t) = - let v_arrays = length_to_array#listOfValues in + (length_to_array: variable_t VariableCollections.table_t) = + let v_arrays = length_to_array#listOfValues in let lengths = ref [] in let lengths_not_included = ref [] in let pairs = List.combine vars vs in let missing_length_indices = ref [] in let length_index = ref (List.length vars) in - let add_var (var, v) = - if List.mem v v_arrays then - match jproc_info#get_length var with - | Some len -> lengths := len :: !lengths + let add_var (var, v) = + if List.mem v v_arrays then + match jproc_info#get_length var with + | Some len -> lengths := len :: !lengths | _ -> begin lengths_not_included := - (JCHSystemUtils.make_length var) :: !lengths_not_included ; - missing_length_indices := !length_index :: !missing_length_indices ; + (JCHSystemUtils.make_length var) :: !lengths_not_included; + missing_length_indices := !length_index :: !missing_length_indices; incr length_index end in begin - List.iter add_var pairs ; + List.iter add_var pairs; (vars @ (List.rev !lengths), !lengths_not_included, !missing_length_indices) end (* CHIntervals.div is not integer division *) -let integer_div (int1:interval_t) (int2:interval_t) = +let integer_div (int1:interval_t) (int2:interval_t) = if int1#isBottom || int2#isBottom then bottomInterval else if int2#contains numerical_zero then topInterval - else + else begin let (a1, b1) = (int1#getMin, int1#getMax) in let (a2, b2) = (int2#getMin, int2#getMax) in - let l = [a1#div_floor a2; a1#div_floor b2; b1#div_floor a2; b1#div_floor b2] in + let l = [ + a1#div_floor a2; a1#div_floor b2; b1#div_floor a2; b1#div_floor b2] in let min = CHBounds.min_in_bounds l in let max = CHBounds.max_in_bounds l in if max#lt min then - bottomInterval + bottomInterval else - new interval_t min max - end - + new interval_t min max + end diff --git a/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.mli b/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.mli index 7531ac28..bbf47e36 100644 --- a/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.mli +++ b/CodeHawk/CHJ/jchpoly/jCHAnalysisUtils.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHArrayUtils.ml b/CodeHawk/CHJ/jchpoly/jCHArrayUtils.ml index 4e463661..e35cedbe 100644 --- a/CodeHawk/CHJ/jchpoly/jCHArrayUtils.ml +++ b/CodeHawk/CHJ/jchpoly/jCHArrayUtils.ml @@ -1,962 +1,986 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -open Big_int_Z - -(* chlib *) -open CHCommon -open CHLanguage -open CHPretty - -(* chutil *) -open CHPrettyUtil - -(* jchsys *) -open JCHPrintUtils - -let dbg = ref false - -let find_gcd (m:big_int) (n:big_int) = - let gcd = ref unit_big_int in - let rec find_gcd_rec mn mx = (* mn <= mx *) - if eq_big_int mn zero_big_int then - abs_big_int !gcd - else - begin - gcd := mn ; - find_gcd_rec (mod_big_int mx mn) mn - end in - if eq_big_int m n then - abs_big_int m - else if lt_big_int m n then - find_gcd_rec m n - else - find_gcd_rec n m;; - -let rec find_first_non_zero_a (a: big_int array) = - let iopt = ref None in - try - for i = 0 to pred (Array.length a) do - if not (eq_big_int a.(i) zero_big_int) then - begin - iopt := Some i; - raise Exit - end - done ; - !iopt - with - | Exit -> !iopt - -let rec find_abs_min_non_zero_a (a:big_int array) = - match find_first_non_zero_a a with - | Some i -> - let min_i = ref i and - min_ai = ref (abs_big_int a.(i)) in - for i = 0 to pred (Array.length a) do - if not (eq_big_int a.(i) zero_big_int) - && (lt_big_int (abs_big_int a.(i)) !min_ai) then - begin - min_i := i ; - min_ai := abs_big_int a.(i) - end - done ; - Some (!min_i, !min_ai) - | None -> None - -let for_all_ind_a p a first_index last_index = - try - for i = first_index to last_index do - if not (p i a.(i)) then - raise Exit - done ; - true - with Exit -> false - -let for_all_a p a = - for_all_ind_a p a 0 (pred (Array.length a)) - -let exists_a p a = - try - for i = 0 to pred (Array.length a) do - if p i a.(i) then - raise Exit - done ; - false - with Exit -> true - -let equal_a a1 a2 = - for_all_a - (fun i ai -> eq_big_int ai a2.(i)) - a1 - - -let find_gcd_a (a: big_int array) = - let rec find_gcd_rec (array: big_int array) = - match find_abs_min_non_zero_a array with - | Some (min_i, min_vl) -> - if for_all_a (fun j aj -> - j = min_i || eq_big_int aj zero_big_int) array then - min_vl - else - let takeMod i ai = - if i = min_i then - ai - else - mod_big_int ai min_vl in - let newa = Array.mapi takeMod array in - find_gcd_rec newa - | None -> unit_big_int in - find_gcd_rec a - -let find_mult_a a = - let res = ref unit_big_int in - for i = 0 to pred (Array.length a) do - res := mult_big_int !res a.(i) - done ; - !res - -let find_lcm_a a = - div_big_int (find_mult_a a) (find_gcd_a a) - -let normalize_a a = - let len = Array.length a in - let gcd = find_gcd_a a in - if gt_big_int gcd unit_big_int then - begin - for i = 0 to pred len do - a.(i) <- div_big_int a.(i) gcd - done - end - -(* linear combination of a1 and a2 such that r[i] = 0 *) -let combine a1 a2 i = - let len = Array.length a1 in - let r = Array.make len zero_big_int in - let gcd = find_gcd a1.(i) a2.(i) in - let m1 = div_big_int a1.(i) gcd in - let m2 = div_big_int a2.(i) gcd in - begin - for i = 0 to pred len do - r.(i) <- sub_big_int (mult_big_int m2 a1.(i)) (mult_big_int m1 a2.(i)) - done ; - normalize_a r ; - r - end - -let normalize_pos_a a = - let len = Array.length a in - let gcd = find_gcd_a a in - if gt_big_int gcd unit_big_int then - begin - let divisor = ref zero_big_int in - for i = 0 to pred len do - if not (eq_big_int a.(i) zero_big_int) then - begin - if eq_big_int !divisor zero_big_int then - divisor := if gt_big_int a.(i) zero_big_int then gcd else minus_big_int gcd ; - a.(i) <- div_big_int a.(i) !divisor - end - done - end - -let normalize_pos_m m = - let nrows = Array.length m in - for r = 0 to pred nrows do - normalize_pos_a m.(r) - done - -let copy_m m = - let nrows = Array.length m in - if nrows = 0 then - Array.copy m - else - let ncols = Array.length m.(0) in - let mc = Array.make_matrix nrows ncols zero_big_int in - begin - for i = 0 to pred nrows do - mc.(i) <- Array.copy m.(i) - done ; - mc - end - -let swap_rows_m m i j = - let tmp = m.(i) in - begin - m.(i) <- m.(j); - m.(j) <- tmp - end - -(* for a reduced triangular matrix *) -let remove_0_rows_m m = - let nrows = Array.length m in - let ncols = Array.length m.(0) in - let new_nrows = ref (pred nrows) in - begin - try - for i = pred nrows downto 0 do - for j = 0 to pred ncols do - if not (eq_big_int m.(i).(j) zero_big_int) then begin - new_nrows := succ i ; - raise Exit - end - done - done - with Exit -> () - end ; - if !new_nrows = nrows then - m - else - Array.sub m 0 !new_nrows - -let equal_m m1 m2 = - match (Array.length m1, Array.length m2) with - | (0, 0) -> true - | (nrows1, nrows2) -> - try - if nrows1 = nrows2 then - let ncols1 = Array.length m1.(0) in - if ncols1 = Array.length m2.(0) then begin - for i = 0 to pred nrows1 do - for j = 0 to pred ncols1 do - if not (eq_big_int m1.(i).(j) m2.(i).(j)) then - raise Exit - done - done ; - true - end - else false - else false - with Exit -> false - -(* Assumes reduced triangular form - * Assumes matrix is not empty and has solutions - * In the case of join, cols_used should have the cols used by both *) -let find_indep_sols_m m sol_size cols_used = - let ncols = Array.length m.(0) in - let last_c = pred ncols in - let last_coeff = pred last_c in - let nums = Array.make_matrix sol_size last_c zero_big_int in - let dens = Array.make_matrix sol_size last_c unit_big_int in - let setNewVals r c i = - let a = m.(r) in - let solnums = nums.(i) in - let soldens = dens.(i) in - let cden = - let mlt = ref unit_big_int in - for j = succ c to last_coeff do - mlt := mult_big_int !mlt soldens.(j) - done ; - !mlt in - let res = - let rs = ref zero_big_int in - for j = succ c to last_coeff do - rs := add_big_int !rs (mult_big_int (mult_big_int a.(j) (div_big_int cden soldens.(j))) solnums.(j)) - done ; - !rs in - let solden = mult_big_int a.(c) cden in - let solnum = minus_big_int (add_big_int (mult_big_int a.(last_c) cden) res) in - let gcd = find_gcd solden solnum in - let div = if gt_big_int solden zero_big_int then gcd else minus_big_int gcd in - if not (eq_big_int solnum zero_big_int) then - begin - solnums.(c) <- div_big_int solnum div; - soldens.(c) <- div_big_int solden div - end in - (* set the 'free' vars *) - let r = ref 0 in - for j = 0 to last_coeff do - if cols_used.(j) = -1 then - begin - nums.(!r).(j) <- unit_big_int ; - incr r - end - done ; - (* set the lead variables *) - for j = last_coeff downto 0 do - let r = cols_used.(j) in - if r > -1 then - for i = 0 to pred sol_size do - setNewVals r j i - done - done ; - (nums, dens) - -(* Sets -2 if the column is all 0; - * r if row r has a lead coeff at the column, - * -1 otherwise *) -let find_cols_used_m m = - let nrows = Array.length m in - let last_c = pred (Array.length m.(0)) in - let used = Array.make last_c (-2) in - let ncols_used = ref 0 in - for i = 0 to pred nrows do - let row_all_0 = ref true in - for j = i to pred last_c do - if not (eq_big_int m.(i).(j) zero_big_int) then - if !row_all_0 then begin - if used.(j) = -2 then - incr ncols_used ; - row_all_0 := false ; - used.(j) <- i ; - end - else if used.(j) = -2 then begin - used.(j) <- -1 ; - incr ncols_used - end - done ; - done ; - used - -let get_common_col_used_a cols_used1 cols_used2 = - let ncols = Array.length cols_used1 in - let ncols_used = ref 0 in - for j = 0 to pred ncols do - match (cols_used1.(j), cols_used2.(j)) with - | (-2, -2) -> () - | (-2, _) -> - cols_used1.(j) <- -1 ; - incr ncols_used - | (_, -2) -> - cols_used2.(j) <- -1 ; - incr ncols_used - | _ -> - incr ncols_used - done ; - if ncols < Array.length cols_used2 && cols_used2.(ncols) <> -2 then - incr ncols_used ; - !ncols_used - -let find_eq_from_sol_a (nums, dens) = - let size = Array.length nums in - let lcm = find_lcm_a dens in - let eq = Array.make (succ size) zero_big_int in - let first = ref true in - let slcm = ref unit_big_int in - for i = 0 to pred size do - if not (eq_big_int nums.(i) zero_big_int) then begin - if !first then begin - first := false ; - slcm := if gt_big_int nums.(i) zero_big_int then lcm else minus_big_int lcm - end ; - eq.(i) <- mult_big_int nums.(i) (div_big_int !slcm dens.(i)) - end - done ; - eq.(size) <- !slcm ; - eq - -let find_eqs_from_sols_m (nums, dens) = - let nrows = Array.length nums in - let ncols = Array.length nums.(0) in - let eqs = Array.make_matrix nrows (succ ncols) zero_big_int in - for i = 0 to pred nrows do - eqs.(i) <- find_eq_from_sol_a (nums.(i), dens.(i)) - done ; - eqs - -let implies_eq m a = - let nrows = Array.length m in - if nrows = 0 then - true - else - let ncols = Array.length m.(0) in - let a' = Array.copy a in - let r = ref 0 in - try - for j = 0 to pred ncols do - let lv2 = a'.(j) in - if not (eq_big_int lv2 zero_big_int) then - while eq_big_int m.(!r).(j) zero_big_int && !r < nrows do - incr r; - done ; - if !r = nrows then - raise Exit - else - let lv1 = m.(!r).(j) in - for k = 0 to pred ncols do - a'.(k) <- sub_big_int (mult_big_int lv1 a'.(k)) (mult_big_int lv2 m.(!r).(k)) - done - done ; - true - with Exit -> - false - -let exchange_m m i1 i2 = - let aux = m.(i1) in - m.(i1) <- m.(i2) ; - m.(i2) <- aux - -let max_n_rays = JCHAnalysisUtils.numeric_params#max_number_rays - -(* After "A Note on Chernikova's Algorithm" by H. Le Verge - * dim is the number of variables = number of columns including - * one for constants *) -let chernikova_m - (bid_rays: big_int array array) - (uni_rays: big_int array array) - n_bid_rays - n_unid_rays - inequality = - let dim = !n_bid_rays in - let ncols = Array.length bid_rays.(0) in - let common_zero = Array.make ncols 0 in - for k = dim to pred ncols do - (* Find a bidirectional ray which does not saturate current constraint *) - let index_non_zero = ref (-1) in - (try - for i = 0 to pred !n_bid_rays do - if not (eq_big_int bid_rays.(i).(k) zero_big_int) then - begin - index_non_zero := i ; - raise Exit - end ; - done ; - with Exit -> ()) ; - if !index_non_zero <> -1 then - begin - (* Discard index_non_zero bidirectional ray *) - decr n_bid_rays ; - if !n_bid_rays <> !index_non_zero then - begin - let p = bid_rays.(!n_bid_rays) in - bid_rays.(!n_bid_rays) <- bid_rays.(!index_non_zero) ; - bid_rays.(!index_non_zero) <- p - end ; - (* Compute the new linearity space *) - for i = 0 to pred !n_bid_rays do - if not (eq_big_int bid_rays.(i).(k) zero_big_int) then - begin - bid_rays.(i) <- combine bid_rays.(i) bid_rays.(!n_bid_rays) k ; - end - done ; - (* Add the positive part of index_non_zero bidirectional ray - * to the set of unidirectional rays *) - if !n_unid_rays = max_n_rays then - raise (JCHAnalysisUtils.numeric_params#analysis_failed - 2 "too many rays"); - if lt_big_int bid_rays.(!n_bid_rays).(k) zero_big_int then - begin - for j = 0 to pred ncols do - uni_rays.(!n_unid_rays).(j) <- minus_big_int bid_rays.(!n_bid_rays).(j) ; - done - end - else - begin - for j = 0 to pred ncols do - uni_rays.(!n_unid_rays).(j) <- bid_rays.(!n_bid_rays).(j) ; - done - end ; - (* Compute the new pointed cone *) - for i = 0 to pred !n_unid_rays do - if not (eq_big_int uni_rays.(i).(k) zero_big_int) then - uni_rays.(i) <- combine uni_rays.(i) uni_rays.(!n_unid_rays) k ; - done ; - if inequality.(k) = 1 then incr n_unid_rays ; - end - else - begin - (* Sort rays : 0 <= i < equal_bound : saturates the constraint *) - (* equal_bound <= i < sup_bouns : verify he constraint *) - (* sup_bound <= i < bound : does not verify *) - let equal_bound = ref 0 in - let sup_bound = ref 0 in - let inf_bound = ref !n_unid_rays in - while !inf_bound > !sup_bound do - if eq_big_int uni_rays.(!sup_bound).(k) zero_big_int then - begin - exchange_m uni_rays !equal_bound !sup_bound ; - incr equal_bound ; - incr sup_bound - end - else if lt_big_int uni_rays.(!sup_bound).(k) zero_big_int then - begin - decr inf_bound ; - exchange_m uni_rays !inf_bound !sup_bound ; - end - else incr sup_bound - done ; - (* Computes only the new pointed cone *) - let bound = ref !n_unid_rays in - for i = !equal_bound to pred !sup_bound do - for j = !sup_bound to pred !bound do - (* Computes the set of common saturated constraints *) - let n_common_constraints = ref 0 in - for l = dim to pred k do - if eq_big_int uni_rays.(i).(l) zero_big_int && eq_big_int uni_rays.(j).(l) zero_big_int then - begin - common_zero.(!n_common_constraints) <- l ; - incr n_common_constraints - end - done ; - if (!n_common_constraints + !n_bid_rays >= dim - 2) then - begin - (* Check whether a ray m saturates the same set of constraints *) - let redundant = ref false in - (try - for m = 0 to pred !bound do - let l = ref 0 in - if m <> i && m <> j then - begin - (try - while !l < !n_common_constraints do - if not (eq_big_int uni_rays.(m).(common_zero.(!l)) zero_big_int) then raise Exit ; - incr l - done - with Exit -> ()) ; - if !l = !n_common_constraints then - begin - (* The combination of ray i and j will generate a non-extremal ray *) - redundant := true ; - raise Exit - end ; - end - done - with Exit -> ()) ; - if not !redundant then - begin - if !n_unid_rays = max_n_rays then - begin - raise (JCHAnalysisUtils.numeric_params#analysis_failed 2 "too many rays") - end ; - (* Compute the new ray *) - uni_rays.(!n_unid_rays) <- combine uni_rays.(j) uni_rays.(i) k ; - incr n_unid_rays ; - end - end - done - done ; - (* Eliminates all non-extremal rays *) - let j = ref (if inequality.(k) = 1 then !sup_bound else !equal_bound) in - let i = ref !n_unid_rays in - while !j < !bound && !i > !bound do - decr i ; - exchange_m uni_rays !i !j ; - incr j - done ; - if !j = !bound then n_unid_rays := !i - else n_unid_rays := !j ; - end - done - - -let find_ineq_sols_m add_1_geq_0 eq_m ineq_m = - let eq_nrows = Array.length eq_m in - let ineq_nrows = Array.length ineq_m in - let nrows = eq_nrows + ineq_nrows in - let ncols = - if eq_nrows = 0 then Array.length ineq_m.(0) - else - let nc1 = Array.length eq_m.(0) in - if ineq_nrows = 0 then nc1 - else if nc1 <> Array.length ineq_m.(0) then - begin - raise - (JCHAnalysisUtils.numeric_params#analysis_failed - 2 "programming error: find_ineq_sols_m, eq and ineq have different number of columns") - end - else nc1 in - let dim = ncols in - let new_ncols = - if add_1_geq_0 then dim + eq_nrows + ineq_nrows + 1 - else dim + eq_nrows + ineq_nrows in - let new_m = Array.make_matrix dim new_ncols zero_big_int in - - for i = 0 to pred dim do - new_m.(i).(i) <- unit_big_int - done ; - let new_i = ref dim in - - (try - for i = 0 to pred eq_nrows do - for j = 0 to pred ncols do - new_m.(j).(!new_i) <- eq_m.(i).(j) - done ; - incr new_i ; - done ; - with Exit -> pr__debug [pp_matrix_big_int new_m; NL; NL] ) ; - - for i = 0 to pred ineq_nrows do - for j = 0 to pred ncols do - new_m.(j).(!new_i) <- ineq_m.(i).(j) - done ; - incr new_i - done ; - let uni_rays = Array.make_matrix max_n_rays new_ncols zero_big_int in - let inequality = Array.make new_ncols 0 in - for i = dim + eq_nrows to pred (dim + nrows) do - inequality.(i) <- 1 - done ; - if add_1_geq_0 then - begin - new_m.(pred dim).(pred new_ncols) <- unit_big_int ; - inequality.(pred new_ncols) <- 1 ; - end ; - let n_bid_rays = ref dim in - let n_unid_rays = ref 0 in - chernikova_m new_m uni_rays n_bid_rays n_unid_rays inequality ; - let restr_bid_rays = Array.make_matrix !n_bid_rays ncols zero_big_int in - for i = 0 to pred !n_bid_rays do - Array.blit new_m.(i) 0 restr_bid_rays.(i) 0 ncols - done ; - let restr_uni_rays = Array.make_matrix !n_unid_rays ncols zero_big_int in - let has_vertex = ref false in - for i = 0 to pred !n_unid_rays do - Array.blit uni_rays.(i) 0 restr_uni_rays.(i) 0 ncols ; - if not (eq_big_int uni_rays.(i).(pred ncols) zero_big_int) then has_vertex := true; - done ; - (restr_bid_rays, restr_uni_rays, !has_vertex) - - -let add_row_m m a init_element = - let nrows = Array.length m in - let ncols = Array.length a in - let new_m = Array.make_matrix (succ nrows) ncols init_element in - begin - Array.blit m 0 new_m 0 nrows ; - new_m.(nrows) <- a ; - new_m - end - -let add_rows_m m alist init_element = - if alist = [] then - m - else - let nrows = Array.length m in - let length = List.length alist in - let ncols = Array.length (List.hd alist) in - let new_nrows = nrows + length in - let new_m = Array.make_matrix new_nrows ncols init_element in - Array.blit m 0 new_m 0 nrows ; - let i = ref nrows in - let rec add_rows alist = - match alist with - | a :: rest_alist -> - new_m.(!i) <- a; - incr i ; - add_rows rest_alist - | _ -> () in - begin - add_rows alist; - new_m - end - -let remove_row_m m r = - let nrows = Array.length m in - let new_m = Array.make_matrix (pred nrows) (Array.length m.(0)) zero_big_int in - begin - Array.blit m 0 new_m 0 r ; - Array.blit m (succ r) new_m r (nrows - r - 1) ; - new_m - end - -let remove_rows_m m rs = - let number_removed = List.length rs in - if number_removed = 0 then - m - else if Array.length m = 0 then - m - else - begin - let sorted_rs = List.sort compare rs in - let nrows = Array.length m in - let ncols = Array.length m.(0) in - if number_removed = nrows then Array.make_matrix 0 ncols (zero_big_int) - else - begin - let new_m = Array.make_matrix (nrows - number_removed) ncols zero_big_int in - let new_i = ref 0 in - let removed_rows = ref sorted_rs in - let removed_row = ref (List.hd sorted_rs) in - for i = 0 to pred nrows do - if i = !removed_row then - begin - removed_rows := List.tl !removed_rows ; - match !removed_rows with - | r :: _ -> - removed_row := r ; - | _ -> () - end - else - begin - new_m.(!new_i) <- m.(i) ; - incr new_i - end - done ; - new_m - end - end - -let remove_trivial_rows ineq_m = - let nrows = Array.length ineq_m in - if nrows = 0 then - ineq_m - else - begin - let nvars = pred (Array.length ineq_m.(0)) in - let trivial_rows = ref [] in - for i = 0 to pred nrows do - let a = ineq_m.(i) in - try - for j = 0 to pred nvars do - if not (eq_big_int a.(j) zero_big_int) then - raise Exit - done ; - if not (eq_big_int a.(nvars) zero_big_int) then - trivial_rows := i :: !trivial_rows - with Exit -> () - done ; - let reduced_ineq_m = remove_rows_m ineq_m !trivial_rows in - reduced_ineq_m - end - -let check_for_bottom eq_m ineq_m = - let check_eq eq = - let nvars = pred (Array.length eq) in - try - for j = 0 to pred nvars do - if not (eq_big_int eq.(j) zero_big_int) then - raise Exit - done ; - eq_big_int eq.(nvars) zero_big_int - with Exit -> true in - let check_ineq ineq = - let nvars = pred (Array.length ineq) in - try - for j = 0 to pred nvars do - if not (eq_big_int ineq.(j) zero_big_int) then - raise Exit - done ; - ge_big_int ineq.(nvars) zero_big_int - with Exit -> true in - - try - for i = 0 to pred (Array.length eq_m) do - if not (check_eq eq_m.(i)) then raise Exit - done ; - for i = 0 to pred (Array.length ineq_m) do - if not (check_ineq ineq_m.(i)) then raise Exit - done ; - true - with Exit -> false - - - -let minimize_m eq_m ineq_m = - let (eq'_m, ineq'_m, has_vertex) = find_ineq_sols_m true eq_m ineq_m in - let _ = check_for_bottom eq'_m ineq'_m in - if Array.length eq'_m = 0 && Array.length ineq'_m = 0 || not has_vertex then - None - else - begin - let (new_eq_m, new_ineq_m, _) = find_ineq_sols_m false eq'_m ineq'_m in - if check_for_bottom new_eq_m new_ineq_m then - begin - (* remove 1 >= 0 *) - let nrows = Array.length new_ineq_m in - if nrows = 0 then Some (new_eq_m, new_ineq_m) - else - begin - let reduced_ineq_m = remove_trivial_rows new_ineq_m in - Some (new_eq_m, reduced_ineq_m) - end - end - else None - end - - -let implies_constraint eq_m ineq_m constr is_eq = - let implies_eq eq_m ineq_m eq = - let const_col = Array.length eq - 1 in - let const = eq.(const_col) in - let leq_constr = Array.copy eq in - leq_constr.(const_col) <- sub_big_int const unit_big_int ; - let leq_ineq_m = add_row_m ineq_m leq_constr zero_big_int in - - match minimize_m eq_m leq_ineq_m with - | None -> - begin - let geq_constr = Array.map minus_big_int eq in - geq_constr.(const_col) <- sub_big_int geq_constr.(const_col) unit_big_int ; - let geq_ineq_m = add_row_m ineq_m geq_constr zero_big_int in - match minimize_m eq_m geq_ineq_m with - | None -> (true, None) - | Some (eqs, ineqs) -> (false, Some (eqs, ineqs)) - end - | Some (eqs, ineqs) -> (false, Some (eqs, ineqs)) in - - let implies_ineq eq_m ineq_m ineq = - let const_col = Array.length ineq - 1 in - let opp_constr = Array.map minus_big_int ineq in - opp_constr.(const_col) <- sub_big_int opp_constr.(const_col) unit_big_int ; - let new_ineq_m = add_row_m ineq_m opp_constr zero_big_int in - match minimize_m eq_m new_ineq_m with - | None -> (true, None) - | Some (eqs, ineqs) -> - (false, Some (eqs, ineqs)) in - - if is_eq then implies_eq eq_m ineq_m constr - else implies_ineq eq_m ineq_m constr - -let implies_constraint_error eq_m ineq_m constr is_eq = - let implies_ineq_err eq_m ineq_m ineq = - - let small_ineq_m = ref ineq_m in - let m = ref ineq_m in - let n = ref (Array.length !small_ineq_m) in - - try - while !n > 0 do - decr n; - m := Array.make_matrix !n (Array.length ineq) zero_big_int ; - for i = 0 to !n-1 do - begin - if i > 0 then - Array.blit !small_ineq_m 0 !m 0 i ; - if i < !n - 1 then - Array.blit !small_ineq_m (i + 1) !m i (!n - i) ; - if not (fst (implies_constraint eq_m !small_ineq_m ineq false)) then - raise Exit - end - done ; - done - with Exit -> - begin - pr__debug [STR "FOUND smallest n = "; INT (!n + 1); NL] ; - pr__debug [STR "m: "; NL; pp_matrix_big_int !m; NL] - end in - - let implies_eq_err eq_m ineq_m eq = - implies_ineq_err eq_m ineq_m eq; - let leq_constr = Array.map minus_big_int eq in - implies_ineq_err eq_m ineq_m leq_constr in - - if is_eq then - implies_eq_err eq_m ineq_m constr - else - implies_ineq_err eq_m ineq_m constr - -let add_col_a a c n = - let ncols = Array.length a in - let new_a = Array.make (succ ncols) n in - Array.blit a 0 new_a 0 c; - Array.blit a c new_a (succ c) (ncols - c) ; - new_a - -let add_col_m m c n = - let new_m = Array.copy m in - for i = 0 to pred (Array.length m) do - new_m.(i) <- add_col_a m.(i) c n - done ; - new_m - -let remove_col_a a c = - let ncols = Array.length a in - let new_a = Array.make (pred ncols) zero_big_int in - Array.blit a 0 new_a 0 c; - Array.blit a (succ c) new_a c (ncols - c - 1) ; - new_a - -let remove_col_m m c = - let new_m = Array.copy m in - for i = 0 to pred (Array.length m) do - new_m.(i) <- remove_col_a m.(i) c - done ; - new_m - -(* cs have to be ordered from largest to smallest *) -let remove_cols_m m cs = - List.fold_left remove_col_m m cs - -(* It does not look at the constant column *) -let get_used_cols_a a = - let used_cols = ref [] in - for i = 0 to (Array.length a) - 2 do - if not (eq_big_int a.(i) zero_big_int) then used_cols := i :: !used_cols - done ; - !used_cols - -let pp_with_vars_m m (vars: variable_t list) (rel: string) : pretty_t = - if (Array.length m) = 0 then STR "T" - else - let ncols = Array.length m.(0) in - let output_list (row: big_int array) (res, i, first) v = - let n = row.(i) in - if eq_big_int n zero_big_int then - (res, succ i, first) - else if eq_big_int n unit_big_int then - begin - if i = pred ncols then - (STR " + 1" :: res, succ i, false) - else if first then - (v#toPretty :: res, succ i, false) - else - ((LBLOCK [STR " + "; v#toPretty]) :: res, succ i, false) - end - else if eq_big_int n (minus_big_int unit_big_int) then - begin - if i = pred ncols then - (STR " - 1" :: res, succ i, false) - else if first then - ((LBLOCK [STR "-"; v#toPretty]) :: res, succ i, false) - else - ((LBLOCK [STR " - ";v#toPretty]) :: res, succ i, false) - end - else - begin - if i = pred ncols then - if gt_big_int n zero_big_int then - ((LBLOCK [STR " + "; STR (string_of_big_int n)]) :: res, succ i, false) - else - ((LBLOCK [STR " - "; STR (string_of_big_int (abs_big_int n))]) :: res, succ i, false) - else if first then - ((LBLOCK [STR (string_of_big_int n); v#toPretty]) :: res, succ i, false) - else - if gt_big_int n zero_big_int then - ((LBLOCK [STR " + "; STR (string_of_big_int n); v#toPretty]) :: res, succ i, false) - else - ((LBLOCK [STR " - "; - STR (string_of_big_int (abs_big_int n)); v#toPretty]) :: res, succ i, false) - end in - let add_const res row = - let n = row.(pred ncols) in - if eq_big_int n unit_big_int then STR " + 1" :: res - else if eq_big_int n (minus_big_int unit_big_int) then STR " - 1" :: res - else if gt_big_int n zero_big_int then (LBLOCK [STR " + "; STR (string_of_big_int n)]) :: res - else (LBLOCK [STR " - "; STR (string_of_big_int (abs_big_int n))]) :: res in - let output_row row = - let (res, _, _) = List.fold_left (output_list row) ([], 0, true) vars in - let res = add_const res row in - List.rev ((LBLOCK [STR (" " ^ rel ^ " 0"); NL]) :: res) in - LBLOCK (List.flatten (List.map output_row (Array.to_list m))) - - -let has_row m a = - try - for i = 0 to pred (Array.length m) do - if equal_a m.(i) a then raise Exit - done ; - false - with Exit -> true +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +open Big_int_Z + +(* chlib *) +open CHLanguage +open CHPretty + +(* chutil *) +open CHPrettyUtil + +(* jchsys *) +open JCHPrintUtils + +let dbg = ref false + +let find_gcd (m:big_int) (n:big_int) = + let gcd = ref unit_big_int in + let rec find_gcd_rec mn mx = (* mn <= mx *) + if eq_big_int mn zero_big_int then + abs_big_int !gcd + else + begin + gcd := mn; + find_gcd_rec (mod_big_int mx mn) mn + end in + if eq_big_int m n then + abs_big_int m + else if lt_big_int m n then + find_gcd_rec m n + else + find_gcd_rec n m;; + +let find_first_non_zero_a (a: big_int array) = + let iopt = ref None in + try + for i = 0 to pred (Array.length a) do + if not (eq_big_int a.(i) zero_big_int) then + begin + iopt := Some i; + raise Exit + end + done; + !iopt + with + | Exit -> !iopt + +let find_abs_min_non_zero_a (a:big_int array) = + match find_first_non_zero_a a with + | Some i -> + let min_i = ref i and + min_ai = ref (abs_big_int a.(i)) in + for i = 0 to pred (Array.length a) do + if not (eq_big_int a.(i) zero_big_int) + && (lt_big_int (abs_big_int a.(i)) !min_ai) then + begin + min_i := i; + min_ai := abs_big_int a.(i) + end + done; + Some (!min_i, !min_ai) + | None -> None + +let for_all_ind_a p a first_index last_index = + try + for i = first_index to last_index do + if not (p i a.(i)) then + raise Exit + done; + true + with Exit -> false + +let for_all_a p a = + for_all_ind_a p a 0 (pred (Array.length a)) + +let exists_a p a = + try + for i = 0 to pred (Array.length a) do + if p i a.(i) then + raise Exit + done; + false + with Exit -> true + +let equal_a a1 a2 = + for_all_a + (fun i ai -> eq_big_int ai a2.(i)) + a1 + + +let find_gcd_a (a: big_int array) = + let rec find_gcd_rec (array: big_int array) = + match find_abs_min_non_zero_a array with + | Some (min_i, min_vl) -> + if for_all_a (fun j aj -> + j = min_i || eq_big_int aj zero_big_int) array then + min_vl + else + let takeMod i ai = + if i = min_i then + ai + else + mod_big_int ai min_vl in + let newa = Array.mapi takeMod array in + find_gcd_rec newa + | None -> unit_big_int in + find_gcd_rec a + +let find_mult_a a = + let res = ref unit_big_int in + for i = 0 to pred (Array.length a) do + res := mult_big_int !res a.(i) + done; + !res + +let find_lcm_a a = + div_big_int (find_mult_a a) (find_gcd_a a) + +let normalize_a a = + let len = Array.length a in + let gcd = find_gcd_a a in + if gt_big_int gcd unit_big_int then + begin + for i = 0 to pred len do + a.(i) <- div_big_int a.(i) gcd + done + end + +(* linear combination of a1 and a2 such that r[i] = 0 *) +let combine a1 a2 i = + let len = Array.length a1 in + let r = Array.make len zero_big_int in + let gcd = find_gcd a1.(i) a2.(i) in + let m1 = div_big_int a1.(i) gcd in + let m2 = div_big_int a2.(i) gcd in + begin + for i = 0 to pred len do + r.(i) <- sub_big_int (mult_big_int m2 a1.(i)) (mult_big_int m1 a2.(i)) + done; + normalize_a r; + r + end + +let normalize_pos_a a = + let len = Array.length a in + let gcd = find_gcd_a a in + if gt_big_int gcd unit_big_int then + begin + let divisor = ref zero_big_int in + for i = 0 to pred len do + if not (eq_big_int a.(i) zero_big_int) then + begin + if eq_big_int !divisor zero_big_int then + divisor := + if gt_big_int a.(i) zero_big_int then gcd else minus_big_int gcd; + a.(i) <- div_big_int a.(i) !divisor + end + done + end + +let _normalize_pos_m m = + let nrows = Array.length m in + for r = 0 to pred nrows do + normalize_pos_a m.(r) + done + +let copy_m m = + let nrows = Array.length m in + if nrows = 0 then + Array.copy m + else + let ncols = Array.length m.(0) in + let mc = Array.make_matrix nrows ncols zero_big_int in + begin + for i = 0 to pred nrows do + mc.(i) <- Array.copy m.(i) + done; + mc + end + +let swap_rows_m m i j = + let tmp = m.(i) in + begin + m.(i) <- m.(j); + m.(j) <- tmp + end + +(* for a reduced triangular matrix *) +let remove_0_rows_m m = + let nrows = Array.length m in + let ncols = Array.length m.(0) in + let new_nrows = ref (pred nrows) in + begin + try + for i = pred nrows downto 0 do + for j = 0 to pred ncols do + if not (eq_big_int m.(i).(j) zero_big_int) then begin + new_nrows := succ i; + raise Exit + end + done + done + with Exit -> () + end; + if !new_nrows = nrows then + m + else + Array.sub m 0 !new_nrows + +let equal_m m1 m2 = + match (Array.length m1, Array.length m2) with + | (0, 0) -> true + | (nrows1, nrows2) -> + try + if nrows1 = nrows2 then + let ncols1 = Array.length m1.(0) in + if ncols1 = Array.length m2.(0) then begin + for i = 0 to pred nrows1 do + for j = 0 to pred ncols1 do + if not (eq_big_int m1.(i).(j) m2.(i).(j)) then + raise Exit + done + done; + true + end + else false + else false + with Exit -> false + +(* Assumes reduced triangular form + * Assumes matrix is not empty and has solutions + * In the case of join, cols_used should have the cols used by both *) +let find_indep_sols_m m sol_size cols_used = + let ncols = Array.length m.(0) in + let last_c = pred ncols in + let last_coeff = pred last_c in + let nums = Array.make_matrix sol_size last_c zero_big_int in + let dens = Array.make_matrix sol_size last_c unit_big_int in + let setNewVals r c i = + let a = m.(r) in + let solnums = nums.(i) in + let soldens = dens.(i) in + let cden = + let mlt = ref unit_big_int in + for j = succ c to last_coeff do + mlt := mult_big_int !mlt soldens.(j) + done; + !mlt in + let res = + let rs = ref zero_big_int in + for j = succ c to last_coeff do + rs := + add_big_int + !rs + (mult_big_int + (mult_big_int a.(j) (div_big_int cden soldens.(j))) solnums.(j)) + done; + !rs in + let solden = mult_big_int a.(c) cden in + let solnum = minus_big_int (add_big_int (mult_big_int a.(last_c) cden) res) in + let gcd = find_gcd solden solnum in + let div = if gt_big_int solden zero_big_int then gcd else minus_big_int gcd in + if not (eq_big_int solnum zero_big_int) then + begin + solnums.(c) <- div_big_int solnum div; + soldens.(c) <- div_big_int solden div + end in + (* set the 'free' vars *) + let r = ref 0 in + for j = 0 to last_coeff do + if cols_used.(j) = -1 then + begin + nums.(!r).(j) <- unit_big_int; + incr r + end + done; + (* set the lead variables *) + for j = last_coeff downto 0 do + let r = cols_used.(j) in + if r > -1 then + for i = 0 to pred sol_size do + setNewVals r j i + done + done; + (nums, dens) + +(* Sets -2 if the column is all 0; + * r if row r has a lead coeff at the column, + * -1 otherwise *) +let find_cols_used_m m = + let nrows = Array.length m in + let last_c = pred (Array.length m.(0)) in + let used = Array.make last_c (-2) in + let ncols_used = ref 0 in + for i = 0 to pred nrows do + let row_all_0 = ref true in + for j = i to pred last_c do + if not (eq_big_int m.(i).(j) zero_big_int) then + if !row_all_0 then begin + if used.(j) = -2 then + incr ncols_used; + row_all_0 := false; + used.(j) <- i; + end + else if used.(j) = -2 then begin + used.(j) <- -1; + incr ncols_used + end + done; + done; + used + +let get_common_col_used_a cols_used1 cols_used2 = + let ncols = Array.length cols_used1 in + let ncols_used = ref 0 in + for j = 0 to pred ncols do + match (cols_used1.(j), cols_used2.(j)) with + | (-2, -2) -> () + | (-2, _) -> + cols_used1.(j) <- -1; + incr ncols_used + | (_, -2) -> + cols_used2.(j) <- -1; + incr ncols_used + | _ -> + incr ncols_used + done; + if ncols < Array.length cols_used2 && cols_used2.(ncols) <> -2 then + incr ncols_used; + !ncols_used + +let find_eq_from_sol_a (nums, dens) = + let size = Array.length nums in + let lcm = find_lcm_a dens in + let eq = Array.make (succ size) zero_big_int in + let first = ref true in + let slcm = ref unit_big_int in + for i = 0 to pred size do + if not (eq_big_int nums.(i) zero_big_int) then begin + if !first then begin + first := false; + slcm := if gt_big_int nums.(i) zero_big_int then lcm else minus_big_int lcm + end; + eq.(i) <- mult_big_int nums.(i) (div_big_int !slcm dens.(i)) + end + done; + eq.(size) <- !slcm; + eq + +let find_eqs_from_sols_m (nums, dens) = + let nrows = Array.length nums in + let ncols = Array.length nums.(0) in + let eqs = Array.make_matrix nrows (succ ncols) zero_big_int in + for i = 0 to pred nrows do + eqs.(i) <- find_eq_from_sol_a (nums.(i), dens.(i)) + done; + eqs + +let implies_eq m a = + let nrows = Array.length m in + if nrows = 0 then + true + else + let ncols = Array.length m.(0) in + let a' = Array.copy a in + let r = ref 0 in + try + for j = 0 to pred ncols do + let lv2 = a'.(j) in + if not (eq_big_int lv2 zero_big_int) then + while eq_big_int m.(!r).(j) zero_big_int && !r < nrows do + incr r; + done; + if !r = nrows then + raise Exit + else + let lv1 = m.(!r).(j) in + for k = 0 to pred ncols do + a'.(k) <- + sub_big_int (mult_big_int lv1 a'.(k)) (mult_big_int lv2 m.(!r).(k)) + done + done; + true + with Exit -> + false + +let exchange_m m i1 i2 = + let aux = m.(i1) in + m.(i1) <- m.(i2); + m.(i2) <- aux + +let max_n_rays = JCHAnalysisUtils.numeric_params#max_number_rays + +(* After "A Note on Chernikova's Algorithm" by H. Le Verge + * dim is the number of variables = number of columns including + * one for constants *) +let chernikova_m + (bid_rays: big_int array array) + (uni_rays: big_int array array) + n_bid_rays + n_unid_rays + inequality = + let dim = !n_bid_rays in + let ncols = Array.length bid_rays.(0) in + let common_zero = Array.make ncols 0 in + for k = dim to pred ncols do + (* Find a bidirectional ray which does not saturate current constraint *) + let index_non_zero = ref (-1) in + (try + for i = 0 to pred !n_bid_rays do + if not (eq_big_int bid_rays.(i).(k) zero_big_int) then + begin + index_non_zero := i; + raise Exit + end; + done; + with Exit -> ()); + if !index_non_zero <> -1 then + begin + (* Discard index_non_zero bidirectional ray *) + decr n_bid_rays; + if !n_bid_rays <> !index_non_zero then + begin + let p = bid_rays.(!n_bid_rays) in + bid_rays.(!n_bid_rays) <- bid_rays.(!index_non_zero); + bid_rays.(!index_non_zero) <- p + end; + (* Compute the new linearity space *) + for i = 0 to pred !n_bid_rays do + if not (eq_big_int bid_rays.(i).(k) zero_big_int) then + begin + bid_rays.(i) <- combine bid_rays.(i) bid_rays.(!n_bid_rays) k; + end + done; + (* Add the positive part of index_non_zero bidirectional ray + * to the set of unidirectional rays *) + if !n_unid_rays = max_n_rays then + raise (JCHAnalysisUtils.numeric_params#analysis_failed + 2 "too many rays"); + if lt_big_int bid_rays.(!n_bid_rays).(k) zero_big_int then + begin + for j = 0 to pred ncols do + uni_rays.(!n_unid_rays).(j) <- + minus_big_int bid_rays.(!n_bid_rays).(j); + done + end + else + begin + for j = 0 to pred ncols do + uni_rays.(!n_unid_rays).(j) <- bid_rays.(!n_bid_rays).(j); + done + end; + (* Compute the new pointed cone *) + for i = 0 to pred !n_unid_rays do + if not (eq_big_int uni_rays.(i).(k) zero_big_int) then + uni_rays.(i) <- combine uni_rays.(i) uni_rays.(!n_unid_rays) k; + done; + if inequality.(k) = 1 then incr n_unid_rays; + end + else + begin + (* Sort rays : 0 <= i < equal_bound : saturates the constraint *) + (* equal_bound <= i < sup_bouns : verify he constraint *) + (* sup_bound <= i < bound : does not verify *) + let equal_bound = ref 0 in + let sup_bound = ref 0 in + let inf_bound = ref !n_unid_rays in + while !inf_bound > !sup_bound do + if eq_big_int uni_rays.(!sup_bound).(k) zero_big_int then + begin + exchange_m uni_rays !equal_bound !sup_bound; + incr equal_bound; + incr sup_bound + end + else if lt_big_int uni_rays.(!sup_bound).(k) zero_big_int then + begin + decr inf_bound; + exchange_m uni_rays !inf_bound !sup_bound; + end + else incr sup_bound + done; + (* Computes only the new pointed cone *) + let bound = ref !n_unid_rays in + for i = !equal_bound to pred !sup_bound do + for j = !sup_bound to pred !bound do + (* Computes the set of common saturated constraints *) + let n_common_constraints = ref 0 in + for l = dim to pred k do + if eq_big_int uni_rays.(i).(l) zero_big_int + && eq_big_int uni_rays.(j).(l) zero_big_int then + begin + common_zero.(!n_common_constraints) <- l; + incr n_common_constraints + end + done; + if (!n_common_constraints + !n_bid_rays >= dim - 2) then + begin + (* Check whether a ray m saturates the same set of constraints *) + let redundant = ref false in + (try + for m = 0 to pred !bound do + let l = ref 0 in + if m <> i && m <> j then + begin + (try + while !l < !n_common_constraints do + if not (eq_big_int uni_rays.(m).(common_zero.(!l)) + zero_big_int) + then + raise Exit; + incr l + done + with Exit -> ()); + if !l = !n_common_constraints then + begin + (* The combination of ray i and j will generate a + non-extremal ray *) + redundant := true; + raise Exit + end; + end + done + with Exit -> ()); + if not !redundant then + begin + if !n_unid_rays = max_n_rays then + begin + raise + (JCHAnalysisUtils.numeric_params#analysis_failed + 2 "too many rays") + end; + (* Compute the new ray *) + uni_rays.(!n_unid_rays) <- combine uni_rays.(j) uni_rays.(i) k; + incr n_unid_rays; + end + end + done + done; + (* Eliminates all non-extremal rays *) + let j = ref (if inequality.(k) = 1 then !sup_bound else !equal_bound) in + let i = ref !n_unid_rays in + while !j < !bound && !i > !bound do + decr i; + exchange_m uni_rays !i !j; + incr j + done; + if !j = !bound then n_unid_rays := !i + else n_unid_rays := !j; + end + done + + +let find_ineq_sols_m add_1_geq_0 eq_m ineq_m = + let eq_nrows = Array.length eq_m in + let ineq_nrows = Array.length ineq_m in + let nrows = eq_nrows + ineq_nrows in + let ncols = + if eq_nrows = 0 then Array.length ineq_m.(0) + else + let nc1 = Array.length eq_m.(0) in + if ineq_nrows = 0 then nc1 + else if nc1 <> Array.length ineq_m.(0) then + begin + raise + (JCHAnalysisUtils.numeric_params#analysis_failed + 2 "programming error: find_ineq_sols_m, eq and ineq have different number of columns") + end + else nc1 in + let dim = ncols in + let new_ncols = + if add_1_geq_0 then dim + eq_nrows + ineq_nrows + 1 + else dim + eq_nrows + ineq_nrows in + let new_m = Array.make_matrix dim new_ncols zero_big_int in + + for i = 0 to pred dim do + new_m.(i).(i) <- unit_big_int + done; + let new_i = ref dim in + + (try + for i = 0 to pred eq_nrows do + for j = 0 to pred ncols do + new_m.(j).(!new_i) <- eq_m.(i).(j) + done; + incr new_i; + done; + with Exit -> pr__debug [pp_matrix_big_int new_m; NL; NL] ); + + for i = 0 to pred ineq_nrows do + for j = 0 to pred ncols do + new_m.(j).(!new_i) <- ineq_m.(i).(j) + done; + incr new_i + done; + let uni_rays = Array.make_matrix max_n_rays new_ncols zero_big_int in + let inequality = Array.make new_ncols 0 in + for i = dim + eq_nrows to pred (dim + nrows) do + inequality.(i) <- 1 + done; + if add_1_geq_0 then + begin + new_m.(pred dim).(pred new_ncols) <- unit_big_int; + inequality.(pred new_ncols) <- 1; + end; + let n_bid_rays = ref dim in + let n_unid_rays = ref 0 in + chernikova_m new_m uni_rays n_bid_rays n_unid_rays inequality; + let restr_bid_rays = Array.make_matrix !n_bid_rays ncols zero_big_int in + for i = 0 to pred !n_bid_rays do + Array.blit new_m.(i) 0 restr_bid_rays.(i) 0 ncols + done; + let restr_uni_rays = Array.make_matrix !n_unid_rays ncols zero_big_int in + let has_vertex = ref false in + for i = 0 to pred !n_unid_rays do + Array.blit uni_rays.(i) 0 restr_uni_rays.(i) 0 ncols; + if not (eq_big_int uni_rays.(i).(pred ncols) zero_big_int) then + has_vertex := true; + done; + (restr_bid_rays, restr_uni_rays, !has_vertex) + + +let add_row_m m a init_element = + let nrows = Array.length m in + let ncols = Array.length a in + let new_m = Array.make_matrix (succ nrows) ncols init_element in + begin + Array.blit m 0 new_m 0 nrows; + new_m.(nrows) <- a; + new_m + end + +let add_rows_m m alist init_element = + if alist = [] then + m + else + let nrows = Array.length m in + let length = List.length alist in + let ncols = Array.length (List.hd alist) in + let new_nrows = nrows + length in + let new_m = Array.make_matrix new_nrows ncols init_element in + Array.blit m 0 new_m 0 nrows; + let i = ref nrows in + let rec add_rows alist = + match alist with + | a :: rest_alist -> + new_m.(!i) <- a; + incr i; + add_rows rest_alist + | _ -> () in + begin + add_rows alist; + new_m + end + +let remove_row_m m r = + let nrows = Array.length m in + let new_m = Array.make_matrix (pred nrows) (Array.length m.(0)) zero_big_int in + begin + Array.blit m 0 new_m 0 r; + Array.blit m (succ r) new_m r (nrows - r - 1); + new_m + end + +let remove_rows_m m rs = + let number_removed = List.length rs in + if number_removed = 0 then + m + else if Array.length m = 0 then + m + else + begin + let sorted_rs = List.sort compare rs in + let nrows = Array.length m in + let ncols = Array.length m.(0) in + if number_removed = nrows then Array.make_matrix 0 ncols (zero_big_int) + else + begin + let new_m = + Array.make_matrix (nrows - number_removed) ncols zero_big_int in + let new_i = ref 0 in + let removed_rows = ref sorted_rs in + let removed_row = ref (List.hd sorted_rs) in + for i = 0 to pred nrows do + if i = !removed_row then + begin + removed_rows := List.tl !removed_rows; + match !removed_rows with + | r :: _ -> + removed_row := r; + | _ -> () + end + else + begin + new_m.(!new_i) <- m.(i); + incr new_i + end + done; + new_m + end + end + +let remove_trivial_rows ineq_m = + let nrows = Array.length ineq_m in + if nrows = 0 then + ineq_m + else + begin + let nvars = pred (Array.length ineq_m.(0)) in + let trivial_rows = ref [] in + for i = 0 to pred nrows do + let a = ineq_m.(i) in + try + for j = 0 to pred nvars do + if not (eq_big_int a.(j) zero_big_int) then + raise Exit + done; + if not (eq_big_int a.(nvars) zero_big_int) then + trivial_rows := i :: !trivial_rows + with Exit -> () + done; + let reduced_ineq_m = remove_rows_m ineq_m !trivial_rows in + reduced_ineq_m + end + +let check_for_bottom eq_m ineq_m = + let check_eq eq = + let nvars = pred (Array.length eq) in + try + for j = 0 to pred nvars do + if not (eq_big_int eq.(j) zero_big_int) then + raise Exit + done; + eq_big_int eq.(nvars) zero_big_int + with Exit -> true in + let check_ineq ineq = + let nvars = pred (Array.length ineq) in + try + for j = 0 to pred nvars do + if not (eq_big_int ineq.(j) zero_big_int) then + raise Exit + done; + ge_big_int ineq.(nvars) zero_big_int + with Exit -> true in + + try + for i = 0 to pred (Array.length eq_m) do + if not (check_eq eq_m.(i)) then raise Exit + done; + for i = 0 to pred (Array.length ineq_m) do + if not (check_ineq ineq_m.(i)) then raise Exit + done; + true + with Exit -> false + + + +let minimize_m eq_m ineq_m = + let (eq'_m, ineq'_m, has_vertex) = find_ineq_sols_m true eq_m ineq_m in + let _ = check_for_bottom eq'_m ineq'_m in + if Array.length eq'_m = 0 && Array.length ineq'_m = 0 || not has_vertex then + None + else + begin + let (new_eq_m, new_ineq_m, _) = find_ineq_sols_m false eq'_m ineq'_m in + if check_for_bottom new_eq_m new_ineq_m then + begin + (* remove 1 >= 0 *) + let nrows = Array.length new_ineq_m in + if nrows = 0 then Some (new_eq_m, new_ineq_m) + else + begin + let reduced_ineq_m = remove_trivial_rows new_ineq_m in + Some (new_eq_m, reduced_ineq_m) + end + end + else None + end + + +let implies_constraint eq_m ineq_m constr is_eq = + let implies_eq eq_m ineq_m eq = + let const_col = Array.length eq - 1 in + let const = eq.(const_col) in + let leq_constr = Array.copy eq in + leq_constr.(const_col) <- sub_big_int const unit_big_int; + let leq_ineq_m = add_row_m ineq_m leq_constr zero_big_int in + + match minimize_m eq_m leq_ineq_m with + | None -> + begin + let geq_constr = Array.map minus_big_int eq in + geq_constr.(const_col) <- + sub_big_int geq_constr.(const_col) unit_big_int; + let geq_ineq_m = add_row_m ineq_m geq_constr zero_big_int in + match minimize_m eq_m geq_ineq_m with + | None -> (true, None) + | Some (eqs, ineqs) -> (false, Some (eqs, ineqs)) + end + | Some (eqs, ineqs) -> (false, Some (eqs, ineqs)) in + + let implies_ineq eq_m ineq_m ineq = + let const_col = Array.length ineq - 1 in + let opp_constr = Array.map minus_big_int ineq in + opp_constr.(const_col) <- sub_big_int opp_constr.(const_col) unit_big_int; + let new_ineq_m = add_row_m ineq_m opp_constr zero_big_int in + match minimize_m eq_m new_ineq_m with + | None -> (true, None) + | Some (eqs, ineqs) -> + (false, Some (eqs, ineqs)) in + + if is_eq then implies_eq eq_m ineq_m constr + else implies_ineq eq_m ineq_m constr + +let implies_constraint_error eq_m ineq_m constr is_eq = + let implies_ineq_err eq_m ineq_m ineq = + + let small_ineq_m = ref ineq_m in + let m = ref ineq_m in + let n = ref (Array.length !small_ineq_m) in + + try + while !n > 0 do + decr n; + m := Array.make_matrix !n (Array.length ineq) zero_big_int; + for i = 0 to !n-1 do + begin + if i > 0 then + Array.blit !small_ineq_m 0 !m 0 i; + if i < !n - 1 then + Array.blit !small_ineq_m (i + 1) !m i (!n - i); + if not (fst (implies_constraint eq_m !small_ineq_m ineq false)) then + raise Exit + end + done; + done + with Exit -> + begin + pr__debug [STR "FOUND smallest n = "; INT (!n + 1); NL]; + pr__debug [STR "m: "; NL; pp_matrix_big_int !m; NL] + end in + + let implies_eq_err eq_m ineq_m eq = + implies_ineq_err eq_m ineq_m eq; + let leq_constr = Array.map minus_big_int eq in + implies_ineq_err eq_m ineq_m leq_constr in + + if is_eq then + implies_eq_err eq_m ineq_m constr + else + implies_ineq_err eq_m ineq_m constr + +let add_col_a a c n = + let ncols = Array.length a in + let new_a = Array.make (succ ncols) n in + Array.blit a 0 new_a 0 c; + Array.blit a c new_a (succ c) (ncols - c); + new_a + +let add_col_m m c n = + let new_m = Array.copy m in + for i = 0 to pred (Array.length m) do + new_m.(i) <- add_col_a m.(i) c n + done; + new_m + +let remove_col_a a c = + let ncols = Array.length a in + let new_a = Array.make (pred ncols) zero_big_int in + Array.blit a 0 new_a 0 c; + Array.blit a (succ c) new_a c (ncols - c - 1); + new_a + +let remove_col_m m c = + let new_m = Array.copy m in + for i = 0 to pred (Array.length m) do + new_m.(i) <- remove_col_a m.(i) c + done; + new_m + +(* cs have to be ordered from largest to smallest *) +let remove_cols_m m cs = + List.fold_left remove_col_m m cs + +(* It does not look at the constant column *) +let get_used_cols_a a = + let used_cols = ref [] in + for i = 0 to (Array.length a) - 2 do + if not (eq_big_int a.(i) zero_big_int) then used_cols := i :: !used_cols + done; + !used_cols + +let pp_with_vars_m m (vars: variable_t list) (rel: string) : pretty_t = + if (Array.length m) = 0 then STR "T" + else + let ncols = Array.length m.(0) in + let output_list (row: big_int array) (res, i, first) v = + let n = row.(i) in + if eq_big_int n zero_big_int then + (res, succ i, first) + else if eq_big_int n unit_big_int then + begin + if i = pred ncols then + (STR " + 1" :: res, succ i, false) + else if first then + (v#toPretty :: res, succ i, false) + else + ((LBLOCK [STR " + "; v#toPretty]) :: res, succ i, false) + end + else if eq_big_int n (minus_big_int unit_big_int) then + begin + if i = pred ncols then + (STR " - 1" :: res, succ i, false) + else if first then + ((LBLOCK [STR "-"; v#toPretty]) :: res, succ i, false) + else + ((LBLOCK [STR " - ";v#toPretty]) :: res, succ i, false) + end + else + begin + if i = pred ncols then + if gt_big_int n zero_big_int then + ((LBLOCK [STR " + "; STR (string_of_big_int n)]) :: res, + succ i, false) + else + ((LBLOCK [STR " - "; STR (string_of_big_int (abs_big_int n))]) :: res, + succ i, false) + else if first then + ((LBLOCK [STR (string_of_big_int n); v#toPretty]) :: res, succ i, false) + else + if gt_big_int n zero_big_int then + ((LBLOCK [STR " + "; STR (string_of_big_int n); v#toPretty]) :: res, + succ i, false) + else + ((LBLOCK [STR " - "; + STR (string_of_big_int (abs_big_int n)); + v#toPretty]) :: res, + succ i, false) + end in + let add_const res row = + let n = row.(pred ncols) in + if eq_big_int n unit_big_int then STR " + 1" :: res + else if eq_big_int n (minus_big_int unit_big_int) then STR " - 1" :: res + else if gt_big_int n zero_big_int then + (LBLOCK [STR " + "; STR (string_of_big_int n)]) :: res + else + (LBLOCK [STR " - "; STR (string_of_big_int (abs_big_int n))]) :: res in + let output_row row = + let (res, _, _) = List.fold_left (output_list row) ([], 0, true) vars in + let res = add_const res row in + List.rev ((LBLOCK [STR (" " ^ rel ^ " 0"); NL]) :: res) in + LBLOCK (List.flatten (List.map output_row (Array.to_list m))) + + +let has_row m a = + try + for i = 0 to pred (Array.length m) do + if equal_a m.(i) a then raise Exit + done; + false + with Exit -> true diff --git a/CodeHawk/CHJ/jchpoly/jCHArrayUtils.mli b/CodeHawk/CHJ/jchpoly/jCHArrayUtils.mli index 254143c5..0d0e8756 100644 --- a/CodeHawk/CHJ/jchpoly/jCHArrayUtils.mli +++ b/CodeHawk/CHJ/jchpoly/jCHArrayUtils.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -32,15 +33,15 @@ open CHLanguage open CHPretty val dbg : bool ref - + val remove_0_rows_m : big_int array array -> big_int array array - + val for_all_ind_a: (int -> big_int -> bool) -> big_int array -> int -> int -> bool val for_all_a : (int -> big_int -> bool) -> big_int array -> bool -val exists_a : (int -> 'a -> bool) -> 'a array -> bool -val equal_a : big_int array -> big_int array -> bool +val exists_a : (int -> 'a -> bool) -> 'a array -> bool +val equal_a : big_int array -> big_int array -> bool val find_gcd_a : big_int array -> big_int val find_mult_a : big_int array -> big_int val find_lcm_a : big_int array -> big_int @@ -53,46 +54,46 @@ val find_indep_sols_m : -> int -> int array -> big_int array array * big_int array array - + val find_cols_used_m : big_int array array -> int array val get_common_col_used_a : int array -> int array -> int - + val find_ineq_sols_m : bool -> big_int array array -> big_int array array -> big_int array array * big_int array array * bool - + val remove_trivial_rows : big_int array array -> big_int array array - + val minimize_m : big_int array array -> big_int array array -> (big_int array array * big_int array array) option - + val find_eq_from_sol_a : big_int array * big_int array -> big_int array - + val find_eqs_from_sols_m : big_int array array * big_int array array -> big_int array array - + val implies_eq: big_int array array -> big_int array -> bool - + val implies_constraint : big_int array array -> big_int array array -> big_int array -> bool -> bool * (big_int array array * big_int array array) option - + val implies_constraint_error : big_int array array -> big_int array array -> big_int array -> bool -> unit - + val add_rows_m : big_int array array -> big_int array list -> big_int -> big_int array array - + val remove_row_m : big_int array array -> int -> big_int array array val remove_rows_m : big_int array array -> int list -> big_int array array val add_col_a : big_int array -> int -> big_int -> big_int array @@ -104,5 +105,5 @@ val get_used_cols_a : big_int array -> int list val pp_with_vars_m: big_int array array -> variable_t list ->string -> pretty_t - + val has_row : big_int array array -> big_int array -> bool diff --git a/CodeHawk/CHJ/jchpoly/jCHCollectors.ml b/CodeHawk/CHJ/jchpoly/jCHCollectors.ml old mode 100755 new mode 100644 index d7ccec27..d111918b --- a/CodeHawk/CHJ/jchpoly/jCHCollectors.ml +++ b/CodeHawk/CHJ/jchpoly/jCHCollectors.ml @@ -1,354 +1,341 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -(* chlib *) -open CHLanguage -open CHNumerical -open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil - -(* jchlib *) -open JCHBasicTypes -open JCHBasicTypesAPI -open JCHDictionary - -(* jchpre *) -open JCHApplication -open JCHBytecodeLocation -open JCHPreAPI - -(* jchsys *) -open JCHGlobals -open JCHPrintUtils - -let dbg = ref false - -class loop_var_collector_t proc_name = - object (self: _) - - inherit code_walker_t as super - - val vars = new VariableCollections.set_t - val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - - (* variables that are changed in a loop in a way that could make them - * potentially unsafe bounds even if they are in a finite range *) - method getVars = vars#toList - - method walkVar var = () - - method addOpVars args = - let addWrite (s,v,m) = - match (v#getType, m) with - | (NUM_LOOP_COUNTER_TYPE, READ) - | (NUM_TMP_VAR_TYPE, READ) - | (NUM_VAR_TYPE, READ) -> - () - | _ -> - vars#add v in - List.iter addWrite args - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | ASSIGN_NUM (_, NUM _) - | ASSIGN_SYM (_, SYM _) -> - () - | READ_SYM_ELT (x, _, _) - | READ_NUM_ELT (x, _, _) - | ASSIGN_SYM (x, _) - | ASSIGN_NUM (x, _) - | ASSIGN_ARRAY (x, _) - | ASSIGN_STRUCT (x, _) - | ASSIGN_NUM_ELT (x, _, _) - | ASSIGN_SYM_ELT (x, _, _) -> - vars#add x - | OPERATION op -> - begin - match op.op_name#getBaseName with - | "i" - | "ii" -> - let pc = op.op_name#getSeqNumber in - begin - match mInfo#get_opcode pc with - | OpIfNull _ - | OpIfCmpAEq _ - | OpIfCmpANe _ -> () (* Have READ_WRITE variables which do not change *) - | OpArrayStore _ -> - vars#add (JCHSystemUtils.get_arg_var "array" op.op_args) - | _ -> - self#addOpVars op.op_args - end - | "init_param" -> - self#addOpVars (List.tl op.op_args) - | _ -> - self#addOpVars op.op_args - end - | DOMAIN_OPERATION (_, op) -> - self#addOpVars (List.tl op.op_args) - | _ -> super#walkCmd cmd - - end - -let collect_loop_vars (proc_name:symbol_t) (code:code_int) = - let collector = new loop_var_collector_t proc_name in - begin - collector#walkCode code ; - collector#getVars - end - -class bound_var_collector_t (proc_name:symbol_t) = -object (self: _) - - inherit code_walker_t as super - - val vars = new VariableCollections.set_t - val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - - (* variables that appear in an ASSERT or a branching op *) - method getVars = vars#toList - method walkVar var = () - - method walkOp pc args = - match mInfo#get_opcode pc with - | OpIfEq _ - | OpIfNe _ - | OpIfLt _ - | OpIfGe _ - | OpIfGt _ - | OpIfLe _ - | OpIfCmpEq _ - | OpIfCmpNe _ - | OpIfCmpLt _ - | OpIfCmpGe _ - | OpIfCmpGt _ - | OpIfCmpLe _ - | OpIfNull _ - | OpIfNonNull _ - | OpIfCmpAEq _ - | OpIfCmpANe _ -> - let vs = List.map (fun (_,v,_) -> v) args in - vars#addList vs - | _ -> () - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | OPERATION {op_name = opname; op_args = args} -> - begin - match opname#getBaseName with - | "i" - | "ii" -> let pc = opname#getSeqNumber in self#walkOp pc args - | _ -> super#walkCmd cmd - end - | _ -> super#walkCmd cmd -end - -let collect_bound_vars (proc_name:symbol_t) (code:code_int) = - let collector = new bound_var_collector_t proc_name in - begin - collector#walkCode code ; - collector#getVars - end - -(* Collects information used in JCHLinEqsIntDomainNoArrays to project - * out variables that are not used any more *) -class lin_eqs_info_collector_t - (proc_name:symbol_t) (jproc_info:JCHProcInfo.jproc_info_t) = -object (self: _) - - inherit code_walker_t as super - - val cms = retrieve_cms proc_name#getSeqNumber - val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - - (* pc -> variables that are not used afterwards *) - val pc_to_last_read = new IntCollections.table_t - - val state_name = ref (new symbol_t "state_name") - - (* last read in the current state *) - val var_to_last_read = ref (new VariableCollections.table_t) - - (* the result of an operation *) - val operation_results = ref (new VariableCollections.set_t) - - (* pcs of casts for the result of an operation *) - val op_casts = new IntCollections.set_t - - val divisor_to_dividend_to_quotient = new VariableCollections.table_t - - method get_all_info = - (pc_to_last_read, op_casts, divisor_to_dividend_to_quotient) - - method private get_instruction_info (pc:int) = - let bcloc = get_bytecode_location cms#index pc in - app#get_instruction bcloc - - method walkState (cfg:cfg_int) (state:symbol_t) = - let add_last var pc_set = - let pc = Option.get pc_set#choose in - match pc_to_last_read#get pc with - | Some set -> set#add var - | _ -> pc_to_last_read#set pc (VariableCollections.set_of_list [var]) in - begin - !var_to_last_read#iter add_last ; - state_name := state ; - var_to_last_read := new VariableCollections.table_t ; - operation_results := new VariableCollections.set_t ; - self#walkCode (cfg#getState state)#getCode - end - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | CFG (_, cfg) -> - List.iter (self#walkState cfg) cfg#getStates - | OPERATION {op_name = opname; op_args = args} -> - begin - match opname#getBaseName with - | "i" - | "ii" -> - let pc = opname#getSeqNumber in - begin - let is_last_state jvar_info = - List.exists !state_name#equal jvar_info#get_last_states in - let check var = - let jvar_info = jproc_info#get_jvar_info var in - if not jvar_info#is_parameter - && not jvar_info#is_local_var - && not jvar_info#is_return - && not (JCHSystemUtils.is_constant var) - && is_last_state jvar_info then - if List.for_all (fun pc' -> pc' <> pc) jvar_info#get_origins then - (* We record only the last read in the state *) - !var_to_last_read#set var (IntCollections.set_of_list [pc]) in - List.iter check (vars_in_cmd cmd) ; - - match mInfo#get_opcode pc with - | OpAdd Int2Bool - | OpSub Int2Bool - | OpMult Int2Bool - | OpNeg Int2Bool -> - let dst1 = JCHSystemUtils.get_arg_var "dst1" args in - !operation_results#add dst1 - | OpDiv Int2Bool - | OpRem Int2Bool -> - let dst1 = JCHSystemUtils.get_arg_var "dst1" args in - !operation_results#add dst1 - | OpIInc _ -> - let src_dst = JCHSystemUtils.get_arg_var "src_dst" args in - if JCHSystemUtils.is_loop_counter src_dst then - () - else - !operation_results#add src_dst - | OpI2B - | OpI2C - | OpI2S -> - let src1 = JCHSystemUtils.get_arg_var "src1" args in - if !operation_results#has src1 then - op_casts#add pc - | _ -> () - - end - | _ -> super#walkCmd cmd - end - | ASSIGN_NUM (v, DIV (x, y)) -> - let dividend_to_quotient = - match divisor_to_dividend_to_quotient#get y with - | Some table -> table - | None -> - let table = new VariableCollections.table_t in - begin - divisor_to_dividend_to_quotient#set y table ; - table - end in - dividend_to_quotient#set x v - | _ -> super#walkCmd cmd - end - -let collect_lin_eqs_info - (proc_name:symbol_t) (jproc_info: JCHProcInfo.jproc_info_t) = - let collector = new lin_eqs_info_collector_t proc_name jproc_info in - let proc = jproc_info#get_procedure in - begin - collector#walkCode proc#getBody ; - collector#get_all_info - end - - -(* Collects information used in JCHLinEqsIntDomainNoArrays to project - * out variables that are not used any more *) -class state_pcs_collector_t = -object (self: _) - - inherit code_walker_t as super - - (* state -> pcs in state *) - val state_to_pcs = new SymbolCollections.table_t - - val state_name_opt = ref None - val pcs = ref (new IntCollections.set_t) - - method get_state_to_pcs = state_to_pcs - - method walkState (cfg:cfg_int) (state:symbol_t) = - begin - (match !state_name_opt with - | Some state_name -> - state_to_pcs#set state_name !pcs - | _ -> ()); - state_name_opt := Some state ; - pcs := new IntCollections.set_t; - self#walkCode (cfg#getState state)#getCode - end - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | CFG (_, cfg) -> - List.iter (self#walkState cfg) cfg#getStates - | OPERATION {op_name = opname; op_args = args} -> - begin - match opname#getBaseName with - | "i" - | "ii" -> - !pcs#add opname#getSeqNumber - | _ -> () - end - | _ -> super#walkCmd cmd - end - -let collect_state_pcs (jproc_info: JCHProcInfo.jproc_info_t) = - let collector = new state_pcs_collector_t in - let proc = jproc_info#get_procedure in - begin - collector#walkCode proc#getBody ; - collector#get_state_to_pcs - end - - - +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +(* chlib *) +open CHLanguage +open CHUtils + +(* jchlib *) +open JCHBasicTypesAPI +open JCHDictionary + +(* jchpre *) +open JCHApplication +open JCHBytecodeLocation + + +class loop_var_collector_t proc_name = + object (self: _) + + inherit code_walker_t as super + + val vars = new VariableCollections.set_t + val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) + + (* variables that are changed in a loop in a way that could make them + * potentially unsafe bounds even if they are in a finite range *) + method getVars = vars#toList + + method !walkVar _var = () + + method addOpVars args = + let addWrite (_s, v, m) = + match (v#getType, m) with + | (NUM_LOOP_COUNTER_TYPE, READ) + | (NUM_TMP_VAR_TYPE, READ) + | (NUM_VAR_TYPE, READ) -> + () + | _ -> + vars#add v in + List.iter addWrite args + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | ASSIGN_NUM (_, NUM _) + | ASSIGN_SYM (_, SYM _) -> + () + | READ_SYM_ELT (x, _, _) + | READ_NUM_ELT (x, _, _) + | ASSIGN_SYM (x, _) + | ASSIGN_NUM (x, _) + | ASSIGN_ARRAY (x, _) + | ASSIGN_STRUCT (x, _) + | ASSIGN_NUM_ELT (x, _, _) + | ASSIGN_SYM_ELT (x, _, _) -> + vars#add x + | OPERATION op -> + begin + match op.op_name#getBaseName with + | "i" + | "ii" -> + let pc = op.op_name#getSeqNumber in + begin + match mInfo#get_opcode pc with + | OpIfNull _ + | OpIfCmpAEq _ + | OpIfCmpANe _ -> () (* Have READ_WRITE variables which do not change *) + | OpArrayStore _ -> + vars#add (JCHSystemUtils.get_arg_var "array" op.op_args) + | _ -> + self#addOpVars op.op_args + end + | "init_param" -> + self#addOpVars (List.tl op.op_args) + | _ -> + self#addOpVars op.op_args + end + | DOMAIN_OPERATION (_, op) -> + self#addOpVars (List.tl op.op_args) + | _ -> super#walkCmd cmd + + end + +let collect_loop_vars (proc_name:symbol_t) (code:code_int) = + let collector = new loop_var_collector_t proc_name in + begin + collector#walkCode code; + collector#getVars + end + +class bound_var_collector_t (proc_name:symbol_t) = +object (self: _) + + inherit code_walker_t as super + + val vars = new VariableCollections.set_t + val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) + + (* variables that appear in an ASSERT or a branching op *) + method getVars = vars#toList + method !walkVar _var = () + + method walkOp pc args = + match mInfo#get_opcode pc with + | OpIfEq _ + | OpIfNe _ + | OpIfLt _ + | OpIfGe _ + | OpIfGt _ + | OpIfLe _ + | OpIfCmpEq _ + | OpIfCmpNe _ + | OpIfCmpLt _ + | OpIfCmpGe _ + | OpIfCmpGt _ + | OpIfCmpLe _ + | OpIfNull _ + | OpIfNonNull _ + | OpIfCmpAEq _ + | OpIfCmpANe _ -> + let vs = List.map (fun (_,v,_) -> v) args in + vars#addList vs + | _ -> () + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | OPERATION {op_name = opname; op_args = args} -> + begin + match opname#getBaseName with + | "i" + | "ii" -> let pc = opname#getSeqNumber in self#walkOp pc args + | _ -> super#walkCmd cmd + end + | _ -> super#walkCmd cmd +end + +let collect_bound_vars (proc_name:symbol_t) (code:code_int) = + let collector = new bound_var_collector_t proc_name in + begin + collector#walkCode code; + collector#getVars + end + +(* Collects information used in JCHLinEqsIntDomainNoArrays to project + * out variables that are not used any more *) +class lin_eqs_info_collector_t + (proc_name:symbol_t) (jproc_info:JCHProcInfo.jproc_info_t) = +object (self: _) + + inherit code_walker_t as super + + val cms = retrieve_cms proc_name#getSeqNumber + val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) + + (* pc -> variables that are not used afterwards *) + val pc_to_last_read = new IntCollections.table_t + + val state_name = ref (new symbol_t "state_name") + + (* last read in the current state *) + val var_to_last_read = ref (new VariableCollections.table_t) + + (* the result of an operation *) + val operation_results = ref (new VariableCollections.set_t) + + (* pcs of casts for the result of an operation *) + val op_casts = new IntCollections.set_t + + val divisor_to_dividend_to_quotient = new VariableCollections.table_t + + method get_all_info = + (pc_to_last_read, op_casts, divisor_to_dividend_to_quotient) + + method private get_instruction_info (pc:int) = + let bcloc = get_bytecode_location cms#index pc in + app#get_instruction bcloc + + method walkState (cfg:cfg_int) (state:symbol_t) = + let add_last var pc_set = + let pc = Option.get pc_set#choose in + match pc_to_last_read#get pc with + | Some set -> set#add var + | _ -> pc_to_last_read#set pc (VariableCollections.set_of_list [var]) in + begin + !var_to_last_read#iter add_last; + state_name := state; + var_to_last_read := new VariableCollections.table_t; + operation_results := new VariableCollections.set_t; + self#walkCode (cfg#getState state)#getCode + end + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | CFG (_, cfg) -> + List.iter (self#walkState cfg) cfg#getStates + | OPERATION {op_name = opname; op_args = args} -> + begin + match opname#getBaseName with + | "i" + | "ii" -> + let pc = opname#getSeqNumber in + begin + let is_last_state jvar_info = + List.exists !state_name#equal jvar_info#get_last_states in + let check var = + let jvar_info = jproc_info#get_jvar_info var in + if not jvar_info#is_parameter + && not jvar_info#is_local_var + && not jvar_info#is_return + && not (JCHSystemUtils.is_constant var) + && is_last_state jvar_info then + if List.for_all + (fun pc' -> pc' <> pc) jvar_info#get_origins then + (* We record only the last read in the state *) + !var_to_last_read#set var (IntCollections.set_of_list [pc]) in + List.iter check (vars_in_cmd cmd); + + match mInfo#get_opcode pc with + | OpAdd Int2Bool + | OpSub Int2Bool + | OpMult Int2Bool + | OpNeg Int2Bool -> + let dst1 = JCHSystemUtils.get_arg_var "dst1" args in + !operation_results#add dst1 + | OpDiv Int2Bool + | OpRem Int2Bool -> + let dst1 = JCHSystemUtils.get_arg_var "dst1" args in + !operation_results#add dst1 + | OpIInc _ -> + let src_dst = JCHSystemUtils.get_arg_var "src_dst" args in + if JCHSystemUtils.is_loop_counter src_dst then + () + else + !operation_results#add src_dst + | OpI2B + | OpI2C + | OpI2S -> + let src1 = JCHSystemUtils.get_arg_var "src1" args in + if !operation_results#has src1 then + op_casts#add pc + | _ -> () + + end + | _ -> super#walkCmd cmd + end + | ASSIGN_NUM (v, DIV (x, y)) -> + let dividend_to_quotient = + match divisor_to_dividend_to_quotient#get y with + | Some table -> table + | None -> + let table = new VariableCollections.table_t in + begin + divisor_to_dividend_to_quotient#set y table; + table + end in + dividend_to_quotient#set x v + | _ -> super#walkCmd cmd + end + +let collect_lin_eqs_info + (proc_name:symbol_t) (jproc_info: JCHProcInfo.jproc_info_t) = + let collector = new lin_eqs_info_collector_t proc_name jproc_info in + let proc = jproc_info#get_procedure in + begin + collector#walkCode proc#getBody; + collector#get_all_info + end + + +(* Collects information used in JCHLinEqsIntDomainNoArrays to project + * out variables that are not used any more *) +class state_pcs_collector_t = +object (self: _) + + inherit code_walker_t as super + + (* state -> pcs in state *) + val state_to_pcs = new SymbolCollections.table_t + + val state_name_opt = ref None + val pcs = ref (new IntCollections.set_t) + + method get_state_to_pcs = state_to_pcs + + method walkState (cfg:cfg_int) (state:symbol_t) = + begin + (match !state_name_opt with + | Some state_name -> + state_to_pcs#set state_name !pcs + | _ -> ()); + state_name_opt := Some state; + pcs := new IntCollections.set_t; + self#walkCode (cfg#getState state)#getCode + end + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | CFG (_, cfg) -> + List.iter (self#walkState cfg) cfg#getStates + | OPERATION {op_name = opname; op_args = _args} -> + begin + match opname#getBaseName with + | "i" + | "ii" -> + !pcs#add opname#getSeqNumber + | _ -> () + end + | _ -> super#walkCmd cmd + end + +let collect_state_pcs (jproc_info: JCHProcInfo.jproc_info_t) = + let collector = new state_pcs_collector_t in + let proc = jproc_info#get_procedure in + begin + collector#walkCode proc#getBody; + collector#get_state_to_pcs + end diff --git a/CodeHawk/CHJ/jchpoly/jCHCollectors.mli b/CodeHawk/CHJ/jchpoly/jCHCollectors.mli index b4ffa2cb..7f972f46 100644 --- a/CodeHawk/CHJ/jchpoly/jCHCollectors.mli +++ b/CodeHawk/CHJ/jchpoly/jCHCollectors.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHFields.ml b/CodeHawk/CHJ/jchpoly/jCHFields.ml index 949b41ee..af767be9 100755 --- a/CodeHawk/CHJ/jchpoly/jCHFields.ml +++ b/CodeHawk/CHJ/jchpoly/jCHFields.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -28,7 +29,6 @@ (* chlib *) open CHIntervals open CHLanguage -open CHNonRelationalDomainNoArrays open CHNumerical open CHPretty open CHUtils @@ -48,7 +48,6 @@ open JCHBytecodeLocation open JCHPreAPI (* jchsys *) -open JCHGlobals open JCHPrintUtils module FieldInfoCollections = CHCollections.Make ( @@ -61,31 +60,31 @@ module FieldInfoCollections = CHCollections.Make ( module ClassInfoCollections = CHCollections.Make ( struct type t = class_info_int - let compare c1 c2 = compare c1#get_class_name#index c2#get_class_name#index + let compare c1 c2 = compare c1#get_class_name#index c2#get_class_name#index let toPretty c = c#toPretty end) module ClassNameCollections = CHCollections.Make ( struct type t = class_name_int - let compare n1 n2 = n1#compare n2 (* Why are strings in compare and not just indices ? *) + let compare n1 n2 = n1#compare n2 (* Why are strings in compare and not just indices ? *) let toPretty n = n#toPretty end) -class interval_list_t (ints:interval_t list) = - object (self: 'a) +class interval_list_t (ints:interval_t list) = + object (_: 'a) method ints = ints - method equal (int_list': 'a) = + method equal (int_list': 'a) = let ints' = int_list'#ints in - if List.length ints = List.length ints' then + if List.length ints = List.length ints' then List.for_all (fun (int, int') -> int#equal int') (List.combine ints ints') else - false + false method toPretty = pp_list ints end - + (* It finds initialized fields. * If there are branches it returns an empty set * It also puts in non_consts, the fields with a non constant origin *) @@ -93,72 +92,72 @@ class collect_init_fields_t (not_analyzed:bool) (non_consts:IntCollections.set_t) (static:bool) - (proc_name:symbol_t) = -object (self: _) - - inherit code_walker_t as super + (proc_name:symbol_t) = +object + + inherit code_walker_t as super - val jproc_info_opt = + val jproc_info_opt = if not_analyzed then - None + None else Some (JCHSystem.jsystem#get_jproc_info proc_name) val cms = retrieve_cms proc_name#getSeqNumber val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - val branching = ref false + val branching = ref false val init_fields = new IntCollections.set_t - method get_init_fields = + method get_init_fields = if !branching then new IntCollections.set_t else init_fields - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | CFG (_, cfg) -> + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | CFG (_, cfg) -> let states = cfg#getStates in - let has_one_pred state_name = + let has_one_pred state_name = let state_name_base = state_name#getBaseName in if state_name_base = "exceptional-exit" || state_name_base = "method-exit" then true - else + else let state = cfg#getState state_name in List.length state#getIncomingEdges < 2 in begin (if not (List.for_all has_one_pred states) then - branching := true) ; + branching := true); super#walkCmd cmd end - | OPERATION {op_name = opname; op_args = args} -> + | OPERATION {op_name = opname; op_args = args} -> begin - match opname#getBaseName with + match opname#getBaseName with | "i" - | "ii" -> + | "ii" -> let pc = opname#getSeqNumber in let bcloc = get_bytecode_location cms#index pc in - let instr_info = app#get_instruction bcloc in + let instr_info = app#get_instruction bcloc in begin match mInfo#get_opcode pc with - | OpPutStatic _ -> + | OpPutStatic _ -> let index = instr_info#get_field_target#get_index in (* add to init_fields only if collecting static init_fields *) - if static then init_fields#add index ; + if static then init_fields#add index; let var = JCHSystemUtils.get_arg_var "val" args in if not_analyzed then () - else + else begin let jproc_info = Option.get jproc_info_opt in let var_info = jproc_info#get_jvar_info var in let opcodes = jproc_info#get_bytecode#get_code in - let has_const_orig pc = - match opcodes#at pc with - | OpIntConst _ + let has_const_orig pc = + match opcodes#at pc with + | OpIntConst _ | OpLongConst _ | OpFloatConst _ | OpDoubleConst _ - | OpByteConst _ + | OpByteConst _ | OpShortConst _ | OpStringConst _ -> true | _ -> false in @@ -167,10 +166,10 @@ object (self: _) else non_consts#add index end - | OpPutField _ -> + | OpPutField _ -> if not static then - (* add to init_fields only if collecting non_static init_fields *) - init_fields#add instr_info#get_field_target#get_index + (* add to init_fields only if collecting non_static init_fields *) + init_fields#add instr_info#get_field_target#get_index | _ -> () end | _ -> () @@ -182,10 +181,10 @@ object (self: _) end (* Record the values of the integer fields. - * The methods take valued from the get_fields and put them in the put_fields - * The get_fields are set before the analysis, either in a previous pass or + * The methods take valued from the get_fields and put them in the put_fields + * The get_fields are set before the analysis, either in a previous pass or * to Top, etc *) -class int_field_manager_t = +class int_field_manager_t = object (self: 'a) val first_pass = ref true @@ -194,114 +193,114 @@ class int_field_manager_t = val class_to_init_fields = new ClassInfoCollections.table_t val classes_with_fields = new ClassInfoCollections.set_t - (* field info -> procs that read the field *) - val field_to_procs = new FieldInfoCollections.table_t + (* field info -> procs that read the field *) + val field_to_procs = new FieldInfoCollections.table_t - (* Field to list of intervals. *) - (* The first is the interval for the field the rest are for the dimensions + (* Field to list of intervals. *) + (* The first is the interval for the field the rest are for the dimensions * of the array, in case it is an array *) - val get_table : interval_list_t FieldInfoCollections.table_t ref = + val get_table : interval_list_t FieldInfoCollections.table_t ref = ref new FieldInfoCollections.table_t - - val put_table : interval_list_t FieldInfoCollections.table_t ref = + + val put_table : interval_list_t FieldInfoCollections.table_t ref = ref new FieldInfoCollections.table_t - (* indices of fields that have an origin in some method which is not - * constant *) + (* indices of fields that have an origin in some method which is not + * constant *) val non_consts = new IntCollections.set_t - (* indices of fields in which only constants are stored *) - val consts = new IntCollections.set_t + (* indices of fields in which only constants are stored *) + val consts = new IntCollections.set_t - method is_dt_field (cn:class_name_int) (fs:field_signature_int) = - match fs#descriptor with - | TObject TClass cn1 -> + method is_dt_field (cn:class_name_int) (fs:field_signature_int) = + match fs#descriptor with + | TObject TClass cn1 -> fs#name = "in" && cn1#name = "java.io.InputStream" && cn#name = "java.lang.System" - | _ -> false + | _ -> false - method is_const_field (fInfo:field_info_int) = consts#has fInfo#get_index + method is_const_field (fInfo:field_info_int) = consts#has fInfo#get_index - method private initialize = + method private initialize = let fInfos = JCHApplication.app#get_fields in - let add_field_to_meth field cms = + let add_field_to_meth field cms = let mInfo = JCHApplication.app#get_method cms in let proc_name = mInfo#get_procname in - match field_to_procs#get field with - | Some set -> set#add proc_name + match field_to_procs#get field with + | Some set -> set#add proc_name | None -> field_to_procs#set field (SymbolCollections.set_of_list [proc_name]) in - let add_field fInfo = - let rmeths = fInfo#get_reading_methods in - List.iter (add_field_to_meth fInfo) rmeths in - List.iter add_field fInfos ; + let add_field fInfo = + let rmeths = fInfo#get_reading_methods in + List.iter (add_field_to_meth fInfo) rmeths in + List.iter add_field fInfos; - method private mk_max_intervals (fInfo:field_info_int) = + method private mk_max_intervals (fInfo:field_info_int) = let vtype = fInfo#get_class_signature#field_signature#descriptor in let int = JCHTypeUtils.get_interval_from_type (Some vtype) in - if (JCHTypeUtils.is_array vtype) then + if (JCHTypeUtils.is_array vtype) then [int; JCHTypeUtils.length_interval] else [int] - method project_out (fInfo:field_info_int) = + method project_out (fInfo:field_info_int) = let max_ints = self#mk_max_intervals fInfo in !put_table#set fInfo (new interval_list_t max_ints) - (* if set_dims then the info in the int_list is taken into consideration + (* if set_dims then the info in the int_list is taken into consideration * even if it is missing *) method private add_field_interval (set_dims:bool) (fInfo:field_info_int) - (int_list:interval_list_t) = + (int_list:interval_list_t) = let ints = int_list#ints in - let new_ints = - match !put_table#get fInfo with - | Some i_list -> - let rec join_all new_ints old_ints = - match (new_ints, old_ints) with + let new_ints = + match !put_table#get fInfo with + | Some i_list -> + let rec join_all new_ints old_ints = + match (new_ints, old_ints) with | (_, []) -> new_ints - | ([], _) -> if set_dims then [] else old_ints - | (new_i :: rest_new_ints, old_i :: rest_old_ints) -> + | ([], _) -> if set_dims then [] else old_ints + | (new_i :: rest_new_ints, old_i :: rest_old_ints) -> (new_i#join old_i) :: (join_all rest_new_ints rest_old_ints) in join_all ints i_list#ints - | _ -> ints in - !put_table#set fInfo (new interval_list_t new_ints) ; + | _ -> ints in + !put_table#set fInfo (new interval_list_t new_ints); method put_field - (proc_name:symbol_t) + (_proc_name:symbol_t) (fInfo:field_info_int) (int:interval_t) (dim_ints:interval_t list) (set_dims:bool) (var: variable_t) = - match fInfo#get_field with - | ConcreteField _ -> - if fInfo#is_accessible_to_stubbed_methods then + match fInfo#get_field with + | ConcreteField _ -> + if fInfo#is_accessible_to_stubbed_methods then begin - match !put_table#get fInfo with - | Some _ -> () - | _ -> + match !put_table#get fInfo with + | Some _ -> () + | _ -> let max_ints = self#mk_max_intervals fInfo in !put_table#set fInfo (new interval_list_t max_ints) end else begin - let ints = + let ints = if JCHSystemUtils.is_number var then [int] - else - if set_dims && dim_ints = [] then - [int; JCHTypeUtils.length_interval] + else + if set_dims && dim_ints = [] then + [int; JCHTypeUtils.length_interval] else int :: dim_ints in let int_list = new interval_list_t ints in - self#add_field_interval set_dims fInfo int_list ; + self#add_field_interval set_dims fInfo int_list; end | _ -> () (* Makes all the fields that the proc writes unknown *) - method set_unknown_fields (jproc_info: JCHProcInfo.jproc_info_t) = - let set cfs = + method set_unknown_fields (jproc_info: JCHProcInfo.jproc_info_t) = + let set cfs = let fInfo = try JCHApplication.app#get_field cfs @@ -310,178 +309,179 @@ class int_field_manager_t = begin ch_error_log#add "missing field" - (LBLOCK [ STR "set-unknown-fields: " ; p ]) ; - raise (JCH_failure (LBLOCK [ STR "set-unknown-fields: " ; p ])) + (LBLOCK [STR "set-unknown-fields: "; p]); + raise (JCH_failure (LBLOCK [STR "set-unknown-fields: "; p])) end in let max_ints = self#mk_max_intervals fInfo in !put_table#set fInfo (new interval_list_t max_ints) in List.iter set (jproc_info#get_method_info#get_field_writes) - (* fields are recorded in classes_with_fields. These are later used to + (* fields are recorded in classes_with_fields. These are later used to * find the static fields that constant and therefore not tainted - * record_field is called in the first pass of the poly analysis - * So for the taint analysis to work correctly with fields, it has to + * record_field is called in the first pass of the poly analysis + * So for the taint analysis to work correctly with fields, it has to * be called after the numeric analysis *) - method record_field (iinfo:instruction_info_int) = + method record_field (iinfo:instruction_info_int) = let fInfo = iinfo#get_field_target in - match fInfo#get_field with - | ConcreteField _ -> - if !first_pass then + match fInfo#get_field with + | ConcreteField _ -> + if !first_pass then classes_with_fields#add - (JCHTypeUtils.get_class_info fInfo#get_class_signature#class_name) ; - | _ -> () + (JCHTypeUtils.get_class_info fInfo#get_class_signature#class_name); + | _ -> () - (* returns an interval if the field is numerical. If the field is an array, - * it returns an interval for the entries and intervals for the dimensions *) + (* returns an interval if the field is numerical. If the field is an array, + * it returns an interval for the entries and intervals for the dimensions *) method get_field_intervals (fInfo:field_info_int) = - match fInfo#get_field with - | ConcreteField _ -> - if !first_pass then + match fInfo#get_field with + | ConcreteField _ -> + if !first_pass then begin match !get_table#get fInfo with - | Some is -> is#ints - | None -> + | Some is -> is#ints + | None -> let max_ints = self#mk_max_intervals fInfo in - !get_table#set fInfo (new interval_list_t max_ints) ; + !get_table#set fInfo (new interval_list_t max_ints); max_ints end - else + else begin match !get_table#get fInfo with - | Some is -> is#ints + | Some is -> is#ints | None -> (* The method that write were not analyzed because they were safe and large *) begin - pr__debug [STR "Analysis failed: get_table does not have "; - fInfo#toPretty; NL; - pp_list fInfo#get_writing_methods; NL] ; + pr__debug [ + STR "Analysis failed: get_table does not have "; + fInfo#toPretty; NL; + pp_list fInfo#get_writing_methods; NL]; raise (JCHAnalysisUtils.numeric_params#analysis_failed 3 "programming error in poly: get_field_intervals") end end - | StubbedField fstub -> - if fstub#has_value then + | StubbedField fstub -> + if fstub#has_value then begin match fstub#get_value with - | ConstInt i -> [ mkSingletonInterval (mkNumericalFromInt32 i) ] - | ConstLong i -> [ mkSingletonInterval (mkNumericalFromInt64 i) ] + | ConstInt i -> [mkSingletonInterval (mkNumericalFromInt32 i)] + | ConstLong i -> [mkSingletonInterval (mkNumericalFromInt64 i)] | ConstDouble f - | ConstFloat f -> + | ConstFloat f -> let (_,_,interval) = JCHAnalysisUtils.float_to_interval f in [interval] - | ConstClass _ + | ConstClass _ | ConstString _ -> self#mk_max_intervals fInfo end else self#mk_max_intervals fInfo | _ -> self#mk_max_intervals fInfo - - method get_all_num_fields = + + method get_all_num_fields = let all_fields = new FieldInfoCollections.set_t in begin - all_fields#addList !put_table#listOfKeys ; - all_fields#addList !get_table#listOfKeys ; + all_fields#addList !put_table#listOfKeys; + all_fields#addList !get_table#listOfKeys; all_fields#toList end - - (* It returns all the fields that are set. This is used for constructors + + (* It returns all the fields that are set. This is used for constructors * to get the initialized fields. * In case that the code is not in a straight line, it returns an empty set. - * It also adds the fields that were assigned a non-constant value to - * non-consts *) - method private get_init_fields_m (mInfo:method_info_int) = - match mInfo#get_implementation with - | ConcreteMethod m -> + * It also adds the fields that were assigned a non-constant value to + * non-consts *) + method private get_init_fields_m (mInfo:method_info_int) = + match mInfo#get_implementation with + | ConcreteMethod _m -> let proc_name = mInfo#get_procname in - let (not_analyzed, proc) = + let (not_analyzed, proc) = try - (false, JCHSystem.jsystem#get_transformed_chif#getProcedure proc_name) + (false, JCHSystem.jsystem#get_transformed_chif#getProcedure proc_name) with _ -> - (true, JCHSystem.jsystem#get_original_chif#getProcedure proc_name) in + (true, JCHSystem.jsystem#get_original_chif#getProcedure proc_name) in let collector = new collect_init_fields_t not_analyzed non_consts mInfo#is_class_constructor proc_name in begin - collector#walkCode proc#getBody ; + collector#walkCode proc#getBody; collector#get_init_fields end | _ -> new IntCollections.set_t - (* Finds fields that are initialized in the class by all the analyzed - * constructor methods *) - method private get_init_fields_c (cInfo:class_info_int) = + (* Finds fields that are initialized in the class by all the analyzed + * constructor methods *) + method private get_init_fields_c (cInfo:class_info_int) = let rec get_init_fields_ms ~(first:bool) ~(init_fields:IntCollections.set_t) - ~(mInfos:method_info_int list) = - match mInfos with - | mInfo :: rest_minfos -> + ~(mInfos:method_info_int list) = + match mInfos with + | mInfo :: rest_minfos -> let fs = self#get_init_fields_m mInfo in - let new_init_fields = + let new_init_fields = if first then - fs + fs else init_fields#inter fs in get_init_fields_ms ~first:false ~init_fields:new_init_fields - ~mInfos:rest_minfos + ~mInfos:rest_minfos | _ -> init_fields in let cn = cInfo#get_class_name in let meths = List.filter (fun mInfo -> (mInfo#get_class_name#equal cn) && mInfo#has_bytecode) app#get_methods in - let (class_constrs, rest_meths) = + let (class_constrs, rest_meths) = List.partition (fun mi -> mi#is_class_constructor) meths in - let (constrs, rest_meths) = + let (constrs, rest_meths) = List.partition (fun mi -> mi#is_constructor) rest_meths in - let init_st_fields = + let init_st_fields = get_init_fields_ms ~first:true ~init_fields:(new IntCollections.set_t) ~mInfos:class_constrs in - let init_fields = + let init_fields = get_init_fields_ms ~first:true ~init_fields:(new IntCollections.set_t) ~mInfos:constrs in - (* This is just to find the non constant fields *) + (* This is just to find the non constant fields *) let _ = get_init_fields_ms ~first:true ~init_fields:(new IntCollections.set_t) ~mInfos:rest_meths in begin - class_to_init_st_fields#set cInfo init_st_fields ; + class_to_init_st_fields#set cInfo init_st_fields; class_to_init_fields#set cInfo init_fields end (* Adds 0 if the field is not known to have been initialized *) method private initialize_fields = - - (* This is done here not in start because in the first pass some - * info is collected that is needed for this *) - classes_with_fields#iter self#get_init_fields_c ; - - let add0 (fInfo:field_info_int) = - match !put_table#get fInfo with - | Some int_list -> + + (* This is done here not in start because in the first pass some + * info is collected that is needed for this *) + classes_with_fields#iter self#get_init_fields_c; + + let add0 (fInfo:field_info_int) = + match !put_table#get fInfo with + | Some int_list -> if self#is_initialized fInfo || fInfo#is_constant then - () - else + () + else begin let is = int_list#ints in - let i = List.hd is in - let int0 = mkSingletonInterval numerical_zero in + let i = List.hd is in + let int0 = mkSingletonInterval numerical_zero in !put_table#set - fInfo (new interval_list_t ((i#join int0) :: (List.tl is))) + fInfo (new interval_list_t ((i#join int0) :: (List.tl is))) end - | _ -> - let int0 = mkSingletonInterval numerical_zero in + | _ -> + let int0 = mkSingletonInterval numerical_zero in !put_table#set fInfo (new interval_list_t [int0]) in - List.iter add0 !get_table#listOfKeys ; - - let add_unknown_field (cfs:class_field_signature_int) = + List.iter add0 !get_table#listOfKeys; + + let add_unknown_field (cfs:class_field_signature_int) = let fInfo = try JCHApplication.app#get_field cfs @@ -490,78 +490,79 @@ class int_field_manager_t = begin ch_error_log#add "missing field" - (LBLOCK [ STR "collect-init-fields: " ; p ]); - raise (JCH_failure (LBLOCK [ STR "collect-init-fields: " ; p ])) - end in + (LBLOCK [STR "collect-init-fields: "; p]); + raise (JCH_failure (LBLOCK [STR "collect-init-fields: "; p])) + end in let max_ints = self#mk_max_intervals fInfo in !put_table#set fInfo (new interval_list_t max_ints) in - - let add_unknown_bad_method (cmsix:int) = + + let add_unknown_bad_method (cmsix:int) = let cms = retrieve_cms cmsix in let mInfo = app#get_method cms in let cfss = mInfo#get_field_writes in List.iter add_unknown_field cfss in - JCHSystem.jsystem#get_not_analyzed_bad#iter add_unknown_bad_method ; - - let add_unknown_good_method (cmsix:int) = (* CHANGE to get the length of the array fields *) + JCHSystem.jsystem#get_not_analyzed_bad#iter add_unknown_bad_method; + + let add_unknown_good_method (cmsix:int) = (* CHANGE to get the length of the array fields *) let cms = retrieve_cms cmsix in let mInfo = app#get_method cms in let cfss = mInfo#get_field_writes in List.iter add_unknown_field cfss in JCHSystem.jsystem#get_not_analyzed_good#iter add_unknown_good_method - method private is_initialized (fInfo:field_info_int) = - let cInfo = JCHTypeUtils.get_class_info fInfo#get_class_signature#class_name in - if fInfo#is_static then - match class_to_init_st_fields#get cInfo with + method private is_initialized (fInfo:field_info_int) = + let cInfo = + JCHTypeUtils.get_class_info fInfo#get_class_signature#class_name in + if fInfo#is_static then + match class_to_init_st_fields#get cInfo with | Some set -> set#has fInfo#get_index - | None -> false - else - match class_to_init_fields#get cInfo with + | None -> false + else + match class_to_init_fields#get cInfo with | Some set -> set#has fInfo#get_index - | None -> false + | None -> false - method private add_to_consts (fInfo:field_info_int) = - if fInfo#is_static && not (non_consts#has fInfo#get_index) then + method private add_to_consts (fInfo:field_info_int) = + if fInfo#is_static && not (non_consts#has fInfo#get_index) then consts#add fInfo#get_index - + method start = begin - self#initialize ; - get_table := new FieldInfoCollections.table_t ; - put_table := new FieldInfoCollections.table_t ; + self#initialize; + get_table := new FieldInfoCollections.table_t; + put_table := new FieldInfoCollections.table_t; first_pass := true end - + method reset = begin - self#initialize_fields ; - List.iter self#add_to_consts JCHApplication.app#get_fields ; - get_table := !put_table ; - put_table := new FieldInfoCollections.table_t ; - first_pass := false + self#initialize_fields; + List.iter self#add_to_consts JCHApplication.app#get_fields; + get_table := !put_table; + put_table := new FieldInfoCollections.table_t; + first_pass := false end - - method get_all_non_private_fields = + + method get_all_non_private_fields = let add_field res (fInfo:field_info_int) - (intervals:interval_list_t) = + (intervals:interval_list_t) = if fInfo#is_private then - res + res else (fInfo, intervals#ints) :: res in - !put_table#fold add_field [] + !put_table#fold add_field [] - method toPretty = - LBLOCK [ STR "put_field_table: "; INDENT(5, !put_table#toPretty); NL; - STR "get_field_table: "; INDENT(5, !get_table#toPretty); NL ] + method toPretty = + LBLOCK [ + STR "put_field_table: "; INDENT(5, !put_table#toPretty); NL; + STR "get_field_table: "; INDENT(5, !get_table#toPretty); NL] end -let int_field_manager = - new int_field_manager_t +let int_field_manager = + new int_field_manager_t -let class_to_fields = +let _class_to_fields = new ClassNameCollections.table_t (* class -> fields that are not static or constant *) - diff --git a/CodeHawk/CHJ/jchpoly/jCHFields.mli b/CodeHawk/CHJ/jchpoly/jCHFields.mli index 66131403..f1090925 100644 --- a/CodeHawk/CHJ/jchpoly/jCHFields.mli +++ b/CodeHawk/CHJ/jchpoly/jCHFields.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -42,10 +43,10 @@ class int_field_manager_t : method get_all_non_private_fields : (field_info_int * interval_t list) list method get_all_num_fields : field_info_int list method get_field_intervals : field_info_int -> interval_t list - method is_const_field : field_info_int -> bool - method is_dt_field : class_name_int -> field_signature_int -> bool - method project_out : field_info_int -> unit - method put_field : + method is_const_field : field_info_int -> bool + method is_dt_field : class_name_int -> field_signature_int -> bool + method project_out : field_info_int -> unit + method put_field : symbol_t -> field_info_int -> interval_t @@ -54,7 +55,7 @@ class int_field_manager_t : -> variable_t -> unit method record_field : instruction_info_int -> unit - method reset : unit + method reset : unit method start : unit method set_unknown_fields : JCHProcInfo.jproc_info_t -> unit method toPretty : pretty_t @@ -62,4 +63,3 @@ class int_field_manager_t : end val int_field_manager : int_field_manager_t - diff --git a/CodeHawk/CHJ/jchpoly/jCHIntStubs.ml b/CodeHawk/CHJ/jchpoly/jCHIntStubs.ml index 209cfa99..ae9d8c08 100755 --- a/CodeHawk/CHJ/jchpoly/jCHIntStubs.ml +++ b/CodeHawk/CHJ/jchpoly/jCHIntStubs.ml @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -27,18 +27,12 @@ ============================================================================= *) (* chlib *) -open CHBounds open CHLanguage -open CHNonRelationalDomainValues -open CHNonRelationalDomainNoArrays -open CHNumerical open CHPretty open CHUtils (* chutil *) open CHPrettyUtil -open CHInvStore -open CHAnalysisSetup (* jchlib *) open JCHBasicTypes @@ -53,92 +47,102 @@ open JCHPrintUtils (* jchpoly *) open JCHPolyIntervalArray -open JCHNumericInfo -let dbg = ref false +let dbg = ref false -type stub_condition_t = +type stub_condition_t = | CheckReturnType (* Used when extracted info from an object, such as in Unwrap *) | CopyInfo of variable_t * variable_t (* (src, dst) *) | JoinInfo of variable_t * variable_t * variable_t (* (dst, src1, src2) *) | PostInterval of variable_t * CHIntervals.interval_t (* var, post_interval *) - (* For the case when an argument array or collection changes in a way that - * cannot be expressed *) - | Abstract of variable_t + (* For the case when an argument array or collection changes in a way that + * cannot be expressed *) + | Abstract of variable_t -let stub_condition_to_pretty extra_conds = - match extra_conds with - | CheckReturnType -> STR "CheckReturnType" +let stub_condition_to_pretty extra_conds = + match extra_conds with + | CheckReturnType -> STR "CheckReturnType" | CopyInfo (src, dst) -> - LBLOCK [STR "CopyInfo "; src#toPretty; STR " "; dst#toPretty; NL] + LBLOCK [STR "CopyInfo "; src#toPretty; STR " "; dst#toPretty; NL] | JoinInfo (src1, src2, dst) -> LBLOCK [STR "JoinInfo "; dst#toPretty; STR " "; - src1#toPretty; STR " "; src2#toPretty; NL] + src1#toPretty; STR " "; src2#toPretty; NL] | PostInterval (var, interval) -> - LBLOCK [STR "PostInterval "; var#toPretty; STR " "; interval#toPretty; NL] - | Abstract var -> LBLOCK [STR "Abstract "; var#toPretty; NL] + LBLOCK [STR "PostInterval "; var#toPretty; STR " "; interval#toPretty; NL] + | Abstract var -> LBLOCK [STR "Abstract "; var#toPretty; NL] -(* Numeric metod summaries *) -class int_stub_t - ~(stub_name: symbol_t) +(* Numeric method summaries *) +class int_stub_t + ~(stub_name: symbol_t) ~(vars: variable_t list) (* list of all variables in signature *) - - (* list of all variables that have a length in signature *) + + (* list of all variables that have a length in signature *) ~(vars_with_lengths:variable_t list) - (* list of length of all the vars_with_lengths *) + (* list of length of all the vars_with_lengths *) ~(lengths : variable_t list) - (* the numeric return variable if one exists *) + (* the numeric return variable if one exists *) ~(return_var_opt:variable_t option) - - (* the length of the return if this is an array *) + + (* the length of the return if this is an array *) ~(return_lengths_ope:variable_t option) = -object (self:_) - +object + val var_names = List.map (fun v -> v#getName#getBaseName) vars - (* It contains the vars and the lengths of the vars in the same order *) - val poly_int_array_opt:poly_interval_array_t option ref = ref None + (* It contains the vars and the lengths of the vars in the same order *) + val poly_int_array_opt:poly_interval_array_t option ref = ref None val extra_conds : stub_condition_t list ref = ref [] - method get_stub_name = stub_name - method get_vars = vars + method get_stub_name = stub_name + method get_vars = vars method get_vars_with_lengths = vars_with_lengths method get_lengths = lengths - - method set_poly_int_array poly_int_array = - poly_int_array_opt := Some poly_int_array ; - + + method set_poly_int_array poly_int_array = + poly_int_array_opt := Some poly_int_array; + method get_poly_int_array = Option.get !poly_int_array_opt - method set_extra_conds conds = extra_conds := conds - - method get_extra_conds = !extra_conds - - method toPretty = - let polyp = + method set_extra_conds conds = extra_conds := conds + + method get_extra_conds = !extra_conds + + method toPretty = + let polyp = match !poly_int_array_opt with | Some poly_int_array -> LBLOCK [STR "poly_int_array:"; NL; - INDENT (5, poly_int_array#to_pretty) ; NL] + INDENT (5, poly_int_array#to_pretty); NL] | None -> STR "" in - let condsp = + let condsp = pretty_print_list !extra_conds stub_condition_to_pretty "" "\n" "" in - let print_stub () = - LBLOCK [stub_name#toPretty; NL; - STR "vars: "; pp_list vars; NL; + let retvarsp = + match return_var_opt with + | Some v -> v#toPretty + | _ -> STR "" in + let retlensp = + match return_lengths_ope with + | Some v -> v#toPretty + | _ -> STR "" in + let print_stub () = + LBLOCK [stub_name#toPretty; NL; + STR "vars: "; pp_list vars; NL; STR "lengths: "; pp_list lengths; NL; - polyp; NL; - STR "extra conditions: "; NL; INDENT (5, condsp); NL] in - match !poly_int_array_opt with - | Some poly_int_array -> - if poly_int_array#is_bottom then - LBLOCK [stub_name#toPretty; NL; - STR "vars: "; pp_list vars; - STR "lengths: "; pp_list lengths; NL; polyp; NL] - else - print_stub () + polyp; NL; + retvarsp; NL; + retlensp; NL; + STR "extra conditions: "; NL; + INDENT (5, condsp); NL] in + match !poly_int_array_opt with + | Some poly_int_array -> + if poly_int_array#is_bottom then + LBLOCK [stub_name#toPretty; NL; + STR "vars: "; pp_list vars; + STR "lengths: "; pp_list lengths; NL; polyp; NL] + else + print_stub () | _ -> print_stub () end @@ -149,15 +153,15 @@ let rec process_cond name_to_index index_to_types (constrs, extra_conds) - (post: postcondition_predicate_t) = + (post: postcondition_predicate_t) = try let constr = JCHLinearConstraint.mk_arg_constraint_from_post_predicate name_to_index index_to_types post in (constr :: constrs, extra_conds, true) with - | Exit -> - match post with + | Exit -> + match post with | PostTrue -> process_cond stub_name @@ -178,15 +182,15 @@ let rec process_cond | PostObjectClass _ -> (constrs, extra_conds, true) | PostNull -> (constrs, extra_conds, true) | PostNotNull -> (constrs, extra_conds, true) - | PostSameCollection (JLocalVar i) - | PostElement (JLocalVar i) -> - let coll_var = List.assoc ("arg"^(string_of_int i)) name_vars in + | PostSameCollection (JLocalVar i) + | PostElement (JLocalVar i) -> + let coll_var = List.assoc ("arg"^(string_of_int i)) name_vars in let ret = List.assoc "return" name_vars in let extra = CopyInfo (coll_var, ret) in (constrs, extra :: extra_conds, true) - | _ -> + | _ -> pr__debug [STR "postcondition not translated "; stub_name#toPretty; - STR " "; postcond_preds_to_pretty [post]; NL] ; + STR " "; postcond_preds_to_pretty [post]; NL]; (constrs, extra_conds, false) @@ -195,146 +199,146 @@ let process_side_effect name_to_index index_to_types (constrs, extra_conds) - side = - match side with - | Wrap (term1, term2) -> + side = + match side with + | Wrap (term1, term2) -> let constr = JCHLinearConstraint.mk_arg_constraint_from_post_predicate name_to_index index_to_types (PostRelationalExpr (JEquals, term1, term2)) in - (constr :: constrs, extra_conds) - | NumericJoin (JLocalVar i, JLocalVar j, JLocalVar k) -> - let argi = List.assoc ("arg"^(string_of_int i)) name_vars in - let argj = List.assoc ("arg"^(string_of_int j)) name_vars in - let argk = List.assoc ("arg"^(string_of_int k)) name_vars in + (constr :: constrs, extra_conds) + | NumericJoin (JLocalVar i, JLocalVar j, JLocalVar k) -> + let argi = List.assoc ("arg"^(string_of_int i)) name_vars in + let argj = List.assoc ("arg"^(string_of_int j)) name_vars in + let argk = List.assoc ("arg"^(string_of_int k)) name_vars in let extra = JoinInfo (argi, argj, argk) in - (constrs, extra :: extra_conds) - | NumericAbstract (JLocalVar i) -> - let argi = List.assoc ("arg"^(string_of_int i)) name_vars in + (constrs, extra :: extra_conds) + | NumericAbstract (JLocalVar i) -> + let argi = List.assoc ("arg"^(string_of_int i)) name_vars in let extra = Abstract argi in - (constrs, extra :: extra_conds) + (constrs, extra :: extra_conds) | _ -> (constrs, extra_conds) -let get_lib_stub stub_info = +let get_lib_stub stub_info = let cmsig = stub_info#get_cms in let is_static = stub_info#is_static in let stub_name = new symbol_t cmsig#class_method_signature_string in let msig = cmsig#class_method_signature_data#method_signature in let msigd = msig#descriptor in - let get_var_type t = - match t with + let get_var_type t = + match t with | TObject _ | TBasic Object -> SYM_VAR_TYPE | _ -> NUM_VAR_TYPE in - let args = ref [] in + let args = ref [] in let arg_with_lengths = ref [] in let arg_lengths = ref [] in - let names = ref [] in + let names = ref [] in let name_to_index = ref [] in let index_to_types = ref [] in let var_count = ref 0 in - let (return_var_opt, return_length_opt) = - match msigd#return_value with + let (return_var_opt, return_length_opt) = + match msigd#return_value with | None - | Some TBasic Void -> - args := [exception_var] ; - names := ["throw"] ; - name_to_index := [("throw", 0)] ; + | Some TBasic Void -> + args := [exception_var]; + names := ["throw"]; + name_to_index := [("throw", 0)]; index_to_types := [(0, [JCHTypeUtils.get_throwable_vt ()])]; var_count := 1; (None, None) - | Some t -> - names := ["throw"; "return"] ; - name_to_index := [("throw", 1); ("return", 0)] ; - index_to_types := [(1, [JCHTypeUtils.get_throwable_vt ()]); (0, [t])] ; - var_count := 2 ; - let rec is_num t = - match t with + | Some t -> + names := ["throw"; "return"]; + name_to_index := [("throw", 1); ("return", 0)]; + index_to_types := [(1, [JCHTypeUtils.get_throwable_vt ()]); (0, [t])]; + var_count := 2; + let rec is_num t = + match t with | TObject TClass cn -> Option.is_some (JCHTypeUtils.get_numeric_type cn) | TObject TArray vt -> is_num vt | TBasic Object -> false | _ -> true in - if is_num t then + if is_num t then begin let v = num_return_var in - args := [exception_var; v] ; - if JCHTypeUtils.is_type_with_length t then + args := [exception_var; v]; + if JCHTypeUtils.is_type_with_length t then begin - arg_with_lengths := [v] ; + arg_with_lengths := [v]; let length_v = JCHSystemUtils.make_length v in - arg_lengths := [length_v] ; + arg_lengths := [length_v]; (Some v, Some length_v) end else (Some v, None) end - else + else begin - args := [exception_var; sym_return_var] ; - if JCHTypeUtils.is_type_with_length t then + args := [exception_var; sym_return_var]; + if JCHTypeUtils.is_type_with_length t then begin - arg_with_lengths := [sym_return_var] ; + arg_with_lengths := [sym_return_var]; let length_v = JCHSystemUtils.make_length sym_return_var in - arg_lengths := [length_v] ; + arg_lengths := [length_v]; (None, Some length_v) end else (None, None) end in - - let number = ref 0 in (* argument index *) + + let number = ref 0 in (* argument index *) if is_static then () - else + else begin let name = "arg0" in let var = make_variable name SYM_VAR_TYPE in - args := var :: !args ; - names := name :: !names ; - name_to_index := (name, !var_count) :: !name_to_index ; + args := var :: !args; + names := name :: !names; + name_to_index := (name, !var_count) :: !name_to_index; let cn = cmsig#class_name in - index_to_types := (!var_count, [TObject (TClass cn)]) :: !index_to_types ; - if JCHTypeUtils.is_class_with_length cn then + index_to_types := (!var_count, [TObject (TClass cn)]) :: !index_to_types; + if JCHTypeUtils.is_class_with_length cn then begin arg_with_lengths := var :: !arg_with_lengths; let arg_length = JCHSystemUtils.make_length var in - arg_lengths := arg_length :: !arg_lengths ; - end ; - incr number ; - incr var_count - end ; - - let rec addArg types = - match types with - | t :: rest_types -> + arg_lengths := arg_length :: !arg_lengths; + end; + incr number; + incr var_count + end; + + let rec addArg types = + match types with + | t :: rest_types -> let name = "arg"^(string_of_int !number) in let var = make_variable name (get_var_type t) in - args := var :: !args ; - names := name :: !names ; - name_to_index := (name, !var_count) :: !name_to_index ; - index_to_types := (!var_count, [t]) :: !index_to_types ; - if JCHTypeUtils.is_type_with_length t then + args := var :: !args; + names := name :: !names; + name_to_index := (name, !var_count) :: !name_to_index; + index_to_types := (!var_count, [t]) :: !index_to_types; + if JCHTypeUtils.is_type_with_length t then begin arg_with_lengths := var :: !arg_with_lengths; let arg_length = JCHSystemUtils.make_length var in - arg_lengths := arg_length :: !arg_lengths ; - end ; - incr number ; - incr var_count ; + arg_lengths := arg_length :: !arg_lengths; + end; + incr number; + incr var_count; addArg rest_types | [] -> () in - addArg msigd#arguments ; - + addArg msigd#arguments; + let vars_with_lengths = List.rev !arg_with_lengths in let lengths = List.rev !arg_lengths in let vars = List.rev !args in - let add_len var_with_length = + let add_len var_with_length = let name = "length_" ^ var_with_length#getName#getBaseName in - names := name :: !names ; + names := name :: !names; name_to_index := (name, !var_count) :: !name_to_index; index_to_types := (!var_count, [TBasic Int]) :: !index_to_types in - List.iter add_len vars_with_lengths ; + List.iter add_len vars_with_lengths; let names = List.rev !names in let name_to_index = List.rev !name_to_index in @@ -342,8 +346,8 @@ let get_lib_stub stub_info = let name_vars = List.combine names (vars @ lengths) in let unknown_condition = ref false in - let add_post (constrs, extra_conds) post = - let (new_constrs, new_extra_conds, processed) = + let add_post (constrs, extra_conds) post = + let (new_constrs, new_extra_conds, processed) = process_cond stub_name name_vars @@ -351,41 +355,41 @@ let get_lib_stub stub_info = index_to_types (constrs, extra_conds) post#get_predicate in - if not processed then + if not processed then begin - unknown_condition := true ; - raise (JCH_failure (STR "condition not parsed")) + unknown_condition := true; + raise (JCH_failure (STR "condition not parsed")) end else (new_constrs, new_extra_conds) in - let (constrs, extra_conds) = + let (constrs, extra_conds) = try List.fold_left add_post ([], []) stub_info#get_post with _ -> ([], []) in - let (error_constrs, extra_conds) = + let (error_constrs, extra_conds) = try List.fold_left add_post ([], extra_conds) stub_info#get_error_post with _ -> ([], []) in - let add_side (constrs, extra_conds) side = + let add_side (constrs, extra_conds) side = process_side_effect name_vars name_to_index index_to_types (constrs, extra_conds) side in - let (constrs, extra_conds) = + let (constrs, extra_conds) = if !unknown_condition then - ([], []) + ([], []) else List.fold_left add_side (constrs, extra_conds) stub_info#get_sideeffects in - let add_safety_cond res (exception_info: exception_info_int) = - if exception_info#has_safety_condition then + let add_safety_cond res (exception_info: exception_info_int) = + if exception_info#has_safety_condition then begin - let add_safety (constrs, extra_conds) scond = + let add_safety (constrs, extra_conds) scond = let post = JCHNumericUtils.pre_to_post_predicate scond in - let (new_constrs, new_extra_conds, processed) = + let (new_constrs, new_extra_conds, _processed) = process_cond stub_name name_vars @@ -397,7 +401,7 @@ let get_lib_stub stub_info = let (constrs, _) = List.fold_left add_safety ([], []) exception_info#get_safety_condition in constrs - end + end else res in let safety_constrs = @@ -405,11 +409,11 @@ let get_lib_stub stub_info = let poly = JCHPoly.mk_poly_from_constraints true (safety_constrs @ constrs) in - let add_error_constr p constr = + let add_error_constr p constr = let error_poly = JCHPoly.mk_poly_from_constraints false [constr] in let res = p#join error_poly in res in - let poly = List.fold_left add_error_constr poly error_constrs in + let poly = List.fold_left add_error_constr poly error_constrs in let top_poly_int_array = top_poly_interval_array [] (vars @ lengths) in let all_poly_int_array = top_poly_int_array#set_poly poly in @@ -422,122 +426,142 @@ let get_lib_stub stub_info = ~vars_with_lengths ~lengths ~return_var_opt - ~return_lengths_ope:return_length_opt in - stub#set_poly_int_array restr_poly_int_array ; - stub#set_extra_conds extra_conds ; + ~return_lengths_ope:return_length_opt in + stub#set_poly_int_array restr_poly_int_array; + stub#set_extra_conds extra_conds; stub - + class call_t (proc_name: symbol_t) (jproc_info: JCHProcInfo.jproc_info_t) (vars: variable_t list) (length_vars: variable_t list) - (length_to_array: variable_t VariableCollections.table_t) = + (length_to_array: variable_t VariableCollections.table_t) = object (self: 'a) val poly_int_array_opt : poly_interval_array_t option ref = ref None - (* calls from within the method itself *) - val rec_poly_int_array_opt : poly_interval_array_t option ref = ref None - val widening_poly_int_array_opt : poly_interval_array_t option ref = ref None + (* calls from within the method itself *) + val rec_poly_int_array_opt : poly_interval_array_t option ref = ref None + val widening_poly_int_array_opt : poly_interval_array_t option ref = ref None method get_all_vars = (vars, length_vars, length_to_array) - method get_widening_poly_int_array_opt use_widening = - match (!widening_poly_int_array_opt, !rec_poly_int_array_opt) with + method get_widening_poly_int_array_opt use_widening = + match (!widening_poly_int_array_opt, !rec_poly_int_array_opt) with | (Some widening_poly_int_array, Some rec_poly_int_array) -> begin - widening_poly_int_array_opt := + widening_poly_int_array_opt := Some (if use_widening then widening_poly_int_array#simple_widening rec_poly_int_array else - widening_poly_int_array#simple_join rec_poly_int_array) ; + widening_poly_int_array#simple_join rec_poly_int_array); !widening_poly_int_array_opt end - | (None, Some rec_poly_int_array) -> + | (None, Some rec_poly_int_array) -> begin - match !poly_int_array_opt with + match !poly_int_array_opt with | Some poly_int_array -> begin - widening_poly_int_array_opt := + widening_poly_int_array_opt := Some (if use_widening then poly_int_array#simple_widening rec_poly_int_array else - poly_int_array#simple_join rec_poly_int_array) ; + poly_int_array#simple_join rec_poly_int_array); !widening_poly_int_array_opt end | _ -> None end - | _ -> !poly_int_array_opt + | _ -> !poly_int_array_opt - method get_narrowing_poly_int_array_opt = - match (!poly_int_array_opt, !rec_poly_int_array_opt) with - | (Some poly_int_array, Some rec_poly_int_array) -> + method get_narrowing_poly_int_array_opt = + match (!poly_int_array_opt, !rec_poly_int_array_opt) with + | (Some poly_int_array, Some rec_poly_int_array) -> Some (poly_int_array#simple_join rec_poly_int_array) | (Some poly_int_array, None) -> Some poly_int_array | (None, _) -> None - - method are_rec_calls_included_in_calls = - match (!widening_poly_int_array_opt, !rec_poly_int_array_opt) with + + method are_rec_calls_included_in_calls = + match (!widening_poly_int_array_opt, !rec_poly_int_array_opt) with | (Some widening_poly_int_array, Some rec_poly_int_array) -> - rec_poly_int_array#leq widening_poly_int_array + rec_poly_int_array#leq widening_poly_int_array | (Some widening_poly_int_array, None) -> widening_poly_int_array#is_top | _ -> true - method reset_rec_poly_int_array = - rec_poly_int_array_opt := None ; + method reset_rec_poly_int_array = + rec_poly_int_array_opt := None; - method get_rec_poly_int_array = - match !rec_poly_int_array_opt with + method get_rec_poly_int_array = + match !rec_poly_int_array_opt with | Some poly_int_array -> poly_int_array | None -> top_poly_int_array method add_poly_int_array caller_proc_name - (caller_poly_int_array:poly_interval_array_t) = - if proc_name#equal caller_proc_name then + (caller_poly_int_array:poly_interval_array_t) = + if proc_name#equal caller_proc_name then begin - match !rec_poly_int_array_opt with - | Some rec_old_poly_int_array -> - rec_poly_int_array_opt := - let p = caller_poly_int_array#change_vars caller_proc_name proc_name vars length_vars in + match !rec_poly_int_array_opt with + | Some rec_old_poly_int_array -> + rec_poly_int_array_opt := + let p = + caller_poly_int_array#change_vars + caller_proc_name proc_name vars length_vars in let p = p#add_intervals_to_poly in - let typed_p = p#set_type_intervals_and_restrict jproc_info (vars @ length_vars) in + let typed_p = + p#set_type_intervals_and_restrict + jproc_info (vars @ length_vars) in let typed_p = typed_p#move_simple_ineqs in - Some (rec_old_poly_int_array#simple_join typed_p) - | None -> - rec_poly_int_array_opt := - let p = caller_poly_int_array#change_vars caller_proc_name proc_name vars length_vars in + Some (rec_old_poly_int_array#simple_join typed_p) + | None -> + rec_poly_int_array_opt := + let p = + caller_poly_int_array#change_vars + caller_proc_name proc_name vars length_vars in let p = p#add_intervals_to_poly in - let typed_p = p#set_type_intervals_and_restrict jproc_info (vars @ length_vars) in + let typed_p = + p#set_type_intervals_and_restrict + jproc_info (vars @ length_vars) in let typed_p = typed_p#move_simple_ineqs in Some typed_p - end - else + end + else begin - match !poly_int_array_opt with - | Some old_poly_int_array -> - poly_int_array_opt := - let p = caller_poly_int_array#change_vars caller_proc_name proc_name vars length_vars in + match !poly_int_array_opt with + | Some old_poly_int_array -> + poly_int_array_opt := + let p = + caller_poly_int_array#change_vars + caller_proc_name proc_name vars length_vars in let p = p#add_intervals_to_poly in - let typed_p = p#set_type_intervals_and_restrict jproc_info (vars @ length_vars) in + let typed_p = + p#set_type_intervals_and_restrict + jproc_info (vars @ length_vars) in let typed_p = typed_p#move_simple_ineqs in Some (old_poly_int_array#simple_join typed_p) - | None -> - poly_int_array_opt := - let p = caller_poly_int_array#change_vars caller_proc_name proc_name vars length_vars in + | None -> + poly_int_array_opt := + let p = + caller_poly_int_array#change_vars + caller_proc_name proc_name vars length_vars in let p = p#add_intervals_to_poly in - let typed_p = p#set_type_intervals_and_restrict jproc_info (vars @ length_vars) in + let typed_p = + p#set_type_intervals_and_restrict + jproc_info (vars @ length_vars) in let typed_p = typed_p#move_simple_ineqs in Some typed_p - end ; + end; if !dbg then - pr__debug [STR "after add_poly_int_array for "; proc_name#toPretty; - STR " caller: "; caller_proc_name#toPretty; NL; self#toPretty; NL] ; - - method toPretty = + pr__debug [ + STR "after add_poly_int_array for "; + proc_name#toPretty; + STR " caller: "; + caller_proc_name#toPretty; NL; + self#toPretty; NL]; + + method toPretty = let varspp = LBLOCK [STR "vars: "; pp_list vars; NL] in let lengthspp = if length_vars = [] then @@ -545,10 +569,10 @@ class call_t else LBLOCK [STR "length_to_array: "; length_to_array#toPretty; NL] in - let poly_int_array_pp str poly_opt = + let poly_int_array_pp str poly_opt = match poly_opt with - | Some poly_int_array -> - LBLOCK [STR (str ^ ": "); NL; INDENT(5, poly_int_array#to_pretty) ; NL] + | Some poly_int_array -> + LBLOCK [STR (str ^ ": "); NL; INDENT(5, poly_int_array#to_pretty); NL] | None -> LBLOCK [STR (str ^ ": None"); NL] in let poly_pp = poly_int_array_pp "poly_int_array" !poly_int_array_opt in @@ -558,51 +582,52 @@ class call_t poly_int_array_pp "widening_poly_int_array" !widening_poly_int_array_opt in LBLOCK [proc_name#toPretty; NL; - INDENT(5, LBLOCK [varspp; lengthspp; poly_pp; rec_poly_pp; wid_poly_pp]) ] + INDENT(5, LBLOCK [ + varspp; lengthspp; poly_pp; rec_poly_pp; wid_poly_pp])] end module FunctionSummaryCollections = CHCollections.Make - (struct - type t = function_summary_int - let compare s1 s2 = compare s1#get_cms#index + (struct + type t = function_summary_int + let compare s1 s2 = compare s1#get_cms#index s2#get_cms#index let toPretty s = s#toPretty end) - -class int_stub_manager_t = -object (self: _) + +class int_stub_manager_t = +object (self: _) val stub_map : int_stub_t SymbolCollections.table_t ref = ref (new SymbolCollections.table_t) val lib_stub_table = new FunctionSummaryCollections.table_t val call_map = ref (new SymbolCollections.table_t) (* proc -> call poly *) - val new_call_map = ref (new SymbolCollections.table_t) + val new_call_map = ref (new SymbolCollections.table_t) method get_lib_func_summaries = lib_stub_table#listOfKeys method get_lib_stubs = lib_stub_table#listOfValues - method private get_stub_p (procedure:procedure_int) = + method private get_stub_p (procedure:procedure_int) = let proc_name = procedure#getName in - let res = - match !stub_map#get proc_name with + let res = + match !stub_map#get proc_name with | Some stub -> stub - | None -> + | None -> let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let bind_vars = JCHSystemUtils.get_signature_vars procedure in let (bind_lengths, bind_arrays, _) = JCHAnalysisUtils.get_length_vars jproc_info bind_vars in - let (ret_var, ret_length_var) = - try + let (ret_var, ret_length_var) = + try let (_, ret) = List.find (fun (s,_) -> s#getBaseName = "return") procedure#getBindings in - let v = + let v = if JCHAnalysisUtils.is_numeric jproc_info ret then Some ret else None in let l_v = jproc_info#get_length ret in - (v, l_v) - with _ -> (None, None) in + (v, l_v) + with _ -> (None, None) in let stub = new int_stub_t ~stub_name:proc_name @@ -610,83 +635,86 @@ object (self: _) ~vars_with_lengths:bind_arrays ~lengths:bind_lengths ~return_var_opt:ret_var - ~return_lengths_ope:ret_length_var in - !stub_map#set proc_name stub ; + ~return_lengths_ope:ret_length_var in + !stub_map#set proc_name stub; stub in - + if !dbg then pr__debug [STR "get_stub_p "; proc_name#toPretty; NL; res#toPretty; NL]; res - method mk_poly_int_array_stub (procedure: procedure_int) restr_poly_int_array = - let stub = self#get_stub_p procedure in - stub#set_poly_int_array restr_poly_int_array + method mk_poly_int_array_stub (procedure: procedure_int) restr_poly_int_array = + let stub = self#get_stub_p procedure in + stub#set_poly_int_array restr_poly_int_array - method mk_lib_stub stub_info = - match lib_stub_table#get stub_info with + method mk_lib_stub stub_info = + match lib_stub_table#get stub_info with | Some stub -> stub - | None -> + | None -> let stub = get_lib_stub stub_info in begin - lib_stub_table#set stub_info stub ; + lib_stub_table#set stub_info stub; stub end - method mk_proc_call proc = + method mk_proc_call proc = let proc_name = proc#getName in let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let vars = JCHSystemUtils.get_signature_read_vars proc in - let (length_vars, array_vars, length_to_array) = + let (length_vars, _array_vars, length_to_array) = JCHAnalysisUtils.get_length_vars jproc_info vars in let call = new call_t proc_name jproc_info vars length_vars length_to_array in - !new_call_map#set proc_name call - - method private get_call proc_name = + !new_call_map#set proc_name call + + method private get_call proc_name = Option.get (!new_call_map#get proc_name) - method get_all_call_vars invoked_proc_name = + method get_all_call_vars invoked_proc_name = let call = self#get_call invoked_proc_name in call#get_all_vars method record_poly_int_array_call caller_proc_name invoked_proc_name caller_poly_int_array = - + if !dbg then pr__debug [STR "record_poly_int_array_call "; caller_proc_name#toPretty; STR " "; invoked_proc_name#toPretty; NL; - caller_poly_int_array#toPretty; NL] ; - + caller_poly_int_array#toPretty; NL]; + if caller_poly_int_array#is_bottom then - () - else + () + else begin let call = self#get_call invoked_proc_name in if !dbg then pr__debug [STR "call = "; call#toPretty; NL]; - call#add_poly_int_array caller_proc_name caller_poly_int_array ; + call#add_poly_int_array caller_proc_name caller_poly_int_array; end method invoke_poly_int_array - (jproc_info:JCHProcInfo.jproc_info_t) + (_jproc_info: JCHProcInfo.jproc_info_t) (proc_names: symbol_t list) (stub_infos: function_summary_int list) = - if !dbg then pr__debug [STR "invoke_poly_int_array "; NL] ; + if !dbg then pr__debug [STR "invoke_poly_int_array "; NL]; if List.exists (fun n -> not (!stub_map#has n)) proc_names then (None, [], [], None, [], [], []) - else + else begin let invoke_one_p - (res_poly_int_array_opt, res_vars, res_vars_with_lengths, res_lengths) + (res_poly_int_array_opt, + res_vars, + res_vars_with_lengths, + res_lengths) (proc_name:symbol_t) = - + if !dbg then - pr__debug [STR "IntStubs.invoke_one_p "; proc_name#toPretty; NL] ; - + pr__debug [STR "IntStubs.invoke_one_p "; proc_name#toPretty; NL]; + let stub = Option.get (!stub_map#get proc_name) in - + if !dbg then pr__debug [stub#toPretty; NL]; - + let poly_int_array = stub#get_poly_int_array in - match res_poly_int_array_opt with + match res_poly_int_array_opt with | Some res_poly_int_array -> if res_poly_int_array#is_bottom then (Some poly_int_array, @@ -713,23 +741,23 @@ object (self: _) if new_lengths#size < res_lengths#size then res_poly_int_array#restrict_to_vars_2 remaining_vars else res_poly_int_array in - + if !dbg then pr__debug [STR "restricted_res_poly_int_array "; pp_list remaining_vars; NL; - restricted_res_poly_int_array#toPretty; NL] ; - + restricted_res_poly_int_array#toPretty; NL]; + let restricted_poly_int_array = - if new_lengths#size < p_lengths#size then - poly_int_array#restrict_to_vars_2 remaining_vars + if new_lengths#size < p_lengths#size then + poly_int_array#restrict_to_vars_2 remaining_vars else poly_int_array in if !dbg then - + pr__debug [STR "restricted_poly_int_array "; pp_list remaining_vars; NL; - restricted_poly_int_array#toPretty; NL] ; - + restricted_poly_int_array#toPretty; NL]; + (Some (restricted_res_poly_int_array#join restricted_poly_int_array), res_vars, new_vars_with_lengths, new_lengths) end @@ -747,16 +775,16 @@ object (self: _) let invoke_one_s ((res_poly_int_array_opt, res_vars, res_vars_with_lengths, res_lengths), res_conds) stub_info = - - if !dbg then pr__debug [STR "invoke_one_s "; NL] ; - + + if !dbg then pr__debug [STR "invoke_one_s "; NL]; + let stub = self#mk_lib_stub stub_info in - + if !dbg then pr__debug [stub#toPretty; NL]; - + let poly_int_array = stub#get_poly_int_array in - match res_poly_int_array_opt with - | Some res_poly_int_array -> + match res_poly_int_array_opt with + | Some res_poly_int_array -> if res_poly_int_array#is_bottom then ((Some poly_int_array, stub#get_vars, @@ -767,41 +795,43 @@ object (self: _) ((Some res_poly_int_array, res_vars, res_vars_with_lengths, - res_lengths), res_conds) + res_lengths), res_conds) else begin - (* Conditions are assumed to be the same for different stubs *) - let all_conds = stub#get_extra_conds @ res_conds in + (* Conditions are assumed to be the same for different stubs *) + let all_conds = stub#get_extra_conds @ res_conds in let p_vars_with_lengths = VariableCollections.set_of_list stub#get_vars_with_lengths in - let p_lengths = VariableCollections.set_of_list stub#get_lengths in + let p_lengths = + VariableCollections.set_of_list stub#get_lengths in let new_vars_with_lengths = res_vars_with_lengths#inter p_vars_with_lengths in let new_lengths = res_lengths#inter p_lengths in let remaining_vars = res_vars @ new_lengths#toList in let restricted_res_poly_int_array = - if new_lengths#size < res_lengths#size then + if new_lengths#size < res_lengths#size then res_poly_int_array#restrict_to_vars_2 remaining_vars else res_poly_int_array in - + if !dbg then pr__debug [STR "restricted_res_poly_int_array "; pp_list remaining_vars; NL; - restricted_res_poly_int_array#toPretty; NL] ; - + restricted_res_poly_int_array#toPretty; NL]; + let restricted_poly_int_array = - if new_lengths#size < p_lengths#size then + if new_lengths#size < p_lengths#size then poly_int_array#restrict_to_vars_2 remaining_vars else poly_int_array in - + if !dbg then pr__debug [STR "restricted_poly_int_array "; pp_list remaining_vars; NL; - restricted_poly_int_array#toPretty; NL] ; - - ((Some (restricted_res_poly_int_array#join restricted_poly_int_array), + restricted_poly_int_array#toPretty; NL]; + + ((Some (restricted_res_poly_int_array#join + restricted_poly_int_array), res_vars, new_vars_with_lengths, new_lengths), all_conds) end | _ -> @@ -814,59 +844,69 @@ object (self: _) let ((stub_p, stub_vs, stub_vls, _), stub_conds) = List.fold_left invoke_one_s - ((None, [], new VariableCollections.set_t, new VariableCollections.set_t), []) + ((None, + [], + new VariableCollections.set_t, + new VariableCollections.set_t), []) stub_infos in - (proc_p, proc_vs, proc_vls#toList, stub_p, stub_vs, stub_vls#toList, stub_conds) + (proc_p, + proc_vs, + proc_vls#toList, + stub_p, + stub_vs, + stub_vls#toList, + stub_conds) end - method get_stub proc_name = - !stub_map#get proc_name + method get_stub proc_name = + !stub_map#get proc_name method get_widening_call_poly_int_array use_widening proc_name use_new = - + if !dbg then - pr__debug [STR ("get_widening_call_poly_int_array use_widening = " - ^ (if use_widening then "true " else "false ")); - proc_name#toPretty; - STR ("use_new = " ^ (if use_new then "true " else "false ")); NL] ; - + pr__debug [ + STR ("get_widening_call_poly_int_array use_widening = " + ^ (if use_widening then "true " else "false ")); + proc_name#toPretty; + STR ("use_new = " ^ (if use_new then "true " else "false ")); NL]; + let map = if use_new then !new_call_map else !call_map in - match map#get proc_name with + match map#get proc_name with | Some call -> call#get_widening_poly_int_array_opt use_widening | None -> None method get_narrowing_call_poly_int_array proc_name use_new = - + if !dbg then - pr__debug [STR "get_narrowing_call_poly_int_array "; - proc_name#toPretty; STR ("use_new = " - ^ (if use_new then "true " else "false ")); NL] ; + pr__debug [ + STR "get_narrowing_call_poly_int_array "; + proc_name#toPretty; + STR ("use_new = " ^ (if use_new then "true " else "false ")); NL]; let map = if use_new then !new_call_map else !call_map in - match map#get proc_name with + match map#get proc_name with | Some call -> call#get_narrowing_poly_int_array_opt | None -> None - method are_recursive_calls_included_in_calls proc_name = + method are_recursive_calls_included_in_calls proc_name = let call = self#get_call proc_name in call#are_rec_calls_included_in_calls - + method reset_calls = - if !dbg then pr__debug [STR "reset_calls"; NL] ; - call_map := !new_call_map ; - new_call_map := new SymbolCollections.table_t + if !dbg then pr__debug [STR "reset_calls"; NL]; + call_map := !new_call_map; + new_call_map := new SymbolCollections.table_t - method reset_recursive_calls proc_name = + method reset_recursive_calls proc_name = let call = self#get_call proc_name in call#reset_rec_poly_int_array; - method toPretty = - LBLOCK [NL; NL; - STR "int_stub_map: "; NL; !stub_map#toPretty; NL; + method toPretty = + LBLOCK [NL; NL; + STR "int_stub_map: "; NL; !stub_map#toPretty; NL; STR "lib_stub_table: "; NL; lib_stub_table#toPretty; NL; STR "call_map: "; NL; !call_map#toPretty; NL; STR "new_call_map: "; NL; !new_call_map#toPretty; NL] - + end let int_stub_manager = new int_stub_manager_t - diff --git a/CodeHawk/CHJ/jchpoly/jCHIntStubs.mli b/CodeHawk/CHJ/jchpoly/jCHIntStubs.mli index 828f3603..b761d993 100644 --- a/CodeHawk/CHJ/jchpoly/jCHIntStubs.mli +++ b/CodeHawk/CHJ/jchpoly/jCHIntStubs.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -32,14 +32,11 @@ open CHLanguage open CHPretty open CHUtils -(* jchlib *) -open JCHBasicTypesAPI - (* jchpre *) open JCHPreAPI -type stub_condition_t = - | CheckReturnType +type stub_condition_t = + | CheckReturnType | CopyInfo of variable_t * variable_t | JoinInfo of variable_t * variable_t * variable_t | PostInterval of variable_t * interval_t @@ -57,12 +54,13 @@ class int_stub_t : object method get_extra_conds : stub_condition_t list method get_lengths : variable_t list - method get_poly_int_array : JCHPolyIntervalArray.poly_interval_array_t + method get_poly_int_array : JCHPolyIntervalArray.poly_interval_array_t method get_stub_name : symbol_t method get_vars : variable_t list method get_vars_with_lengths : variable_t list method set_extra_conds : stub_condition_t list -> unit - method set_poly_int_array : JCHPolyIntervalArray.poly_interval_array_t -> unit + method set_poly_int_array : + JCHPolyIntervalArray.poly_interval_array_t -> unit method toPretty : pretty_t end @@ -74,8 +72,8 @@ class int_stub_manager_t : -> variable_t list * variable_t list * variable_t VariableCollections.table_t - - method get_lib_stubs : int_stub_t list + + method get_lib_stubs : int_stub_t list method get_lib_func_summaries : function_summary_int list method get_stub : symbol_t -> int_stub_t option method get_widening_call_poly_int_array : @@ -83,12 +81,12 @@ class int_stub_manager_t : -> symbol_t -> bool -> JCHPolyIntervalArray.poly_interval_array_t option - + method get_narrowing_call_poly_int_array : symbol_t -> bool -> JCHPolyIntervalArray.poly_interval_array_t option - + method invoke_poly_int_array : JCHProcInfo.jproc_info_t -> symbol_t list @@ -99,24 +97,24 @@ class int_stub_manager_t : * (JCHPolyIntervalArray.poly_interval_array_t option) * (variable_t list) * (variable_t list) * stub_condition_t list - - method mk_lib_stub : function_summary_int -> int_stub_t + + method mk_lib_stub : function_summary_int -> int_stub_t method mk_poly_int_array_stub : procedure_int -> JCHPolyIntervalArray.poly_interval_array_t -> unit - + method record_poly_int_array_call : symbol_t -> symbol_t -> JCHPolyIntervalArray.poly_interval_array_t -> unit - - method mk_proc_call : procedure_int -> unit + + method mk_proc_call : procedure_int -> unit method reset_calls : unit method reset_recursive_calls : symbol_t -> unit method toPretty : pretty_t end -val int_stub_manager : int_stub_manager_t +val int_stub_manager : int_stub_manager_t val dbg : bool ref diff --git a/CodeHawk/CHJ/jchpoly/jCHIntervalArray.ml b/CodeHawk/CHJ/jchpoly/jCHIntervalArray.ml index 72a86009..b1bf45a8 100644 --- a/CodeHawk/CHJ/jchpoly/jCHIntervalArray.ml +++ b/CodeHawk/CHJ/jchpoly/jCHIntervalArray.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -25,90 +26,85 @@ SOFTWARE. ============================================================================= *) -open Big_int_Z (* chlib *) open CHIntervals open CHLanguage open CHPretty -open CHUtils (* chutil *) open CHPrettyUtil -(* jchlib *) -open JCHBasicTypes - (* jchsys *) open JCHPrintUtils let interval_array_index = ref (-1) let get_interval_array_index () = begin - incr interval_array_index ; + incr interval_array_index; !interval_array_index end let dbg = ref false -let empty_small_array = Array.make 0 topInterval +let empty_small_array = Array.make 0 topInterval let array_size = JCHAnalysisUtils.numeric_params#interval_array_size (* Wrapper around an array of intervals. - * The bottom interval is used for a variable that is not in use, + * The bottom interval is used for a variable that is not in use, * such as before it is first assigned, or after is last read. *) -class interval_array_t s = - object (self: 'a) +class interval_array_t s = + object (self: 'a) - val size = s + val size = s val intervals_opt = None (* double indexed array of intervals *) val type_intervals_opt = None (* double indexed array of type intervals *) - val interval_array_ind = get_interval_array_index () + val interval_array_ind = get_interval_array_index () - method private make_arrays (size:int) (interval:interval_t) = - let (dim1, dim2) = self#get_dimensions size in + method private make_arrays (size:int) (interval:interval_t) = + let (dim1, dim2) = self#get_dimensions size in let new_arrays = Array.make dim1 empty_small_array in begin - for i = 0 to dim1 - 2 do - new_arrays.(i) <- (Array.make array_size interval) - done ; - new_arrays.(pred dim1) <- Array.make dim2 interval ; + for i = 0 to dim1 - 2 do + new_arrays.(i) <- (Array.make array_size interval) + done; + new_arrays.(pred dim1) <- Array.make dim2 interval; new_arrays end - method make (size:int) (interval:interval_t) = + method make (size:int) (interval:interval_t) = if size = 0 then {< intervals_opt = None >} else - {< size = size ; - intervals_opt = Some (self#make_arrays size interval) ; - type_intervals_opt = None; + {< size = size; + intervals_opt = Some (self#make_arrays size interval); + type_intervals_opt = None; interval_array_ind = get_interval_array_index () >} method set_type_intervals (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = if vars = [] then - {< type_intervals_opt = None ; + {< type_intervals_opt = None; interval_array_ind = get_interval_array_index () - >} + >} else - let new_arrays = self#make_arrays size topInterval in - let set_interval i var = - let tinterval = - if JCHAnalysisUtils.numeric_params#use_types then + let new_arrays = self#make_arrays size topInterval in + let set_interval i var = + let tinterval = + if JCHAnalysisUtils.numeric_params#use_types then try (* var could be made-up length variable that is not in the system *) let num_type = (jproc_info#get_jvar_info var)#get_basic_num_type in - JCHTypeUtils.get_var_interval_from_type var num_type + JCHTypeUtils.get_var_interval_from_type var num_type with _ -> JCHTypeUtils.length_interval else topInterval in let (index1, index2) = self#get_indices i in begin - new_arrays.(index1).(index2) <- tinterval ; + new_arrays.(index1).(index2) <- tinterval; succ i end in let _ = List.fold_left set_interval 0 vars in - {< type_intervals_opt = Some new_arrays ; + {< type_intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} @@ -116,436 +112,443 @@ class interval_array_t s = method set_type_intervals_and_restrict (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = if vars = [] then - {< type_intervals_opt = None ; + {< type_intervals_opt = None; interval_array_ind = get_interval_array_index () - >} + >} else - let new_type_arrays = self#make_arrays size topInterval in + let new_type_arrays = self#make_arrays size topInterval in let new_arrays = self#make_arrays size topInterval in - let set_intervals i var = - let tinterval = + let set_intervals i var = + let tinterval = try (* var could be made-up length variable that is not in the system *) let num_type = (jproc_info#get_jvar_info var)#get_basic_num_type in - JCHTypeUtils.get_var_interval_from_type var num_type + JCHTypeUtils.get_var_interval_from_type var num_type with _ -> JCHTypeUtils.length_interval in let (index1, index2) = self#get_indices i in begin - new_type_arrays.(index1).(index2) <- tinterval ; - new_arrays.(index1).(index2) <- new_arrays.(index1).(index2)#meet tinterval ; + new_type_arrays.(index1).(index2) <- tinterval; + new_arrays.(index1).(index2) <- + new_arrays.(index1).(index2)#meet tinterval; succ i end in let _ = List.fold_left set_intervals 0 vars in - {} - - method clone = - match intervals_opt with - | Some arrays -> {< intervals_opt = Some (Array.copy arrays) >} + method clone = + match intervals_opt with + | Some arrays -> {< intervals_opt = Some (Array.copy arrays) >} | None -> {< >} - method private copy' arrays = + method private copy' arrays = let new_arrays = Array.copy arrays in begin - for i = 0 to pred (Array.length arrays) do + for i = 0 to pred (Array.length arrays) do new_arrays.(i) <- Array.copy (arrays.(i)) - done ; + done; new_arrays end - - method copy = - {< intervals_opt = Some (self#copy' self#get_arrays) ; + + method copy = + {< intervals_opt = Some (self#copy' self#get_arrays); interval_array_ind = get_interval_array_index () - >} - - method make_bottom_intervals (size:int) = + >} + + method make_bottom_intervals (size:int) = if size = 0 then - {< intervals_opt = None ; + {< intervals_opt = None; interval_array_ind = get_interval_array_index () >} else - {< intervals_opt = Some (self#make_arrays size bottomInterval) ; + {< intervals_opt = Some (self#make_arrays size bottomInterval); interval_array_ind = get_interval_array_index () >} - method make_top_intervals (size:int) = + method make_top_intervals (size:int) = if size = 0 then - {< intervals_opt = None ; + {< intervals_opt = None; interval_array_ind = get_interval_array_index () >} else - {< size = size ; - intervals_opt = Some (self#make_arrays size topInterval) ; - type_intervals_opt = None ; + {< size = size; + intervals_opt = Some (self#make_arrays size topInterval); + type_intervals_opt = None; interval_array_ind = get_interval_array_index () >} - method make_from_types (size:int) = + method make_from_types (size:int) = if size = 0 then - {< intervals_opt = None ; + {< intervals_opt = None; interval_array_ind = get_interval_array_index () - >} + >} else - {< intervals_opt = Some (self#copy' self#get_type_arrays) ; + {< intervals_opt = Some (self#copy' self#get_type_arrays); interval_array_ind = get_interval_array_index () >} - method get_arrays = - match intervals_opt with + method get_arrays = + match intervals_opt with | Some arrays -> arrays | None -> Array.make 0 empty_small_array - method private get_type_arrays = - match type_intervals_opt with + method private get_type_arrays = + match type_intervals_opt with | Some arrays -> arrays | None -> Array.make 0 empty_small_array - method get_type_interval (index:int) = + method get_type_interval (index:int) = let (index1, index2) = self#get_indices index in - (self#get_type_arrays).(index1).(index2) + (self#get_type_arrays).(index1).(index2) - method private get_indices (index:int)= + method private get_indices (index:int)= let index1 = index / array_size in let index2 = index mod array_size in - (index1, index2) + (index1, index2) - method is_discrete (index:int) = + method is_discrete (index:int) = let (index1, index2) = self#get_indices index in not (self#get_type_arrays.(index1).(index2)#equal topInterval) - method get (index:int) = + method get (index:int) = let (index1, index2) = self#get_indices index in - (self#get_arrays).(index1).(index2) + (self#get_arrays).(index1).(index2) - method private get_dimensions (dim:int) = + method private get_dimensions (dim:int) = if dim = 0 then - (0, 0) - else + (0, 0) + else let (index1, index2) = self#get_indices dim in if index2 = 0 then - (index1, array_size) + (index1, array_size) else (succ index1, index2) - method set (index:int) (interval:interval_t) = + method set (index:int) (interval:interval_t) = let (index1, index2) = self#get_indices index in (self#get_arrays).(index1).(index2) <- interval - method copy_set (index:int) (interval:interval_t) = - let arrays = self#get_arrays in + method copy_set (index:int) (interval:interval_t) = + let arrays = self#get_arrays in let new_arrays = self#copy' arrays in let (index1, index2) = self#get_indices index in let small_array = new_arrays.(index1) in begin - small_array.(index2) <- interval ; - {< intervals_opt = Some new_arrays ; + small_array.(index2) <- interval; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - method copy_set_typed (index:int) (interval:interval_t) = - let arrays = self#get_arrays in + method copy_set_typed (index:int) (interval:interval_t) = + let arrays = self#get_arrays in let new_arrays = self#copy' arrays in let (index1, index2) = self#get_indices index in let small_array = new_arrays.(index1) in begin - small_array.(index2) <- interval#meet (self#get_type_arrays).(index1).(index2) ; - {< intervals_opt = Some new_arrays ; + small_array.(index2) <- interval#meet (self#get_type_arrays).(index1).(index2); + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - method project_out (inds:int list) = + method project_out (inds:int list) = if inds = [] then {< >} - else - let new_intervals = self#copy' self#get_arrays in + else + let new_intervals = self#copy' self#get_arrays in let type_intervals = self#get_type_arrays in - let set_type_interval i = + let set_type_interval i = let (index1, index2) = self#get_indices i in new_intervals.(index1).(index2) <- type_intervals.(index1).(index2) in begin - List.iter set_type_interval inds ; - {< intervals_opt = Some new_intervals ; + List.iter set_type_interval inds; + {< intervals_opt = Some new_intervals; interval_array_ind = get_interval_array_index () >} end method remove (inds:int list) = if inds = [] then - {< >} - else - let new_intervals = self#copy' self#get_arrays in - let set_type_interval i = + {< >} + else + let new_intervals = self#copy' self#get_arrays in + let set_type_interval i = let (index1, index2) = self#get_indices i in new_intervals.(index1).(index2) <- bottomInterval in begin - List.iter set_type_interval inds ; - {< intervals_opt = Some new_intervals ; + List.iter set_type_interval inds; + {< intervals_opt = Some new_intervals; interval_array_ind = get_interval_array_index () >} end - method restrict_to_type (inds:int list) = + method restrict_to_type (inds:int list) = if inds = [] then - {< >} - else + {< >} + else let intervals = self#get_arrays in - let new_intervals = self#copy' intervals in + let new_intervals = self#copy' intervals in let type_intervals = self#get_type_arrays in - let set_type_interval i = + let set_type_interval i = let (index1, index2) = self#get_indices i in new_intervals.(index1).(index2) <- intervals.(index1).(index2)#meet type_intervals.(index1).(index2) in begin - List.iter set_type_interval inds ; - {< intervals_opt = Some new_intervals ; + List.iter set_type_interval inds; + {< intervals_opt = Some new_intervals; interval_array_ind = get_interval_array_index () >} end - method meet (a: 'a) (ignore_bottom:bool) = + method meet (a: 'a) (ignore_bottom:bool) = if size = 0 then - {< >} - else + {< >} + else let new_arrays = self#make_arrays size bottomInterval in let arrays = self#get_arrays in let aarrays = a#get_arrays in let (dim1, dim2) = self#get_dimensions size in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_new_array = new_arrays.(i) in let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in - let new_interval = - match (interval#isBottom, ainterval#isBottom) with + let new_interval = + match (interval#isBottom, ainterval#isBottom) with | (true, true) -> bottomInterval | (true, _) -> if ignore_bottom then ainterval else bottomInterval | (_, true) -> if ignore_bottom then interval else bottomInterval | _ -> interval#meet ainterval in - small_new_array.(j) <- new_interval + small_new_array.(j) <- new_interval done - done ; - {< intervals_opt = Some new_arrays ; + done; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - method join' (size:int) (a: 'a) = + method join' (size:int) (a: 'a) = if size = 0 then - {< >} - else + {< >} + else let new_arrays = self#make_arrays size bottomInterval in let arrays = self#get_arrays in let aarrays = a#get_arrays in let (dim1, dim2) = self#get_dimensions size in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_new_array = new_arrays.(i) in let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in - small_new_array.(j) <- interval#join ainterval + small_new_array.(j) <- interval#join ainterval done - done ; - {< intervals_opt = Some new_arrays ; + done; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - method join (a: 'a) = + method join (a: 'a) = if size = 0 then - {< >} - else + {< >} + else let new_arrays = self#make_arrays size bottomInterval in let arrays = self#get_arrays in let aarrays = a#get_arrays in let (dim1, dim2) = self#get_dimensions size in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_new_array = new_arrays.(i) in let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in - small_new_array.(j) <- interval#join ainterval + small_new_array.(j) <- interval#join ainterval done - done ; - {< intervals_opt = Some new_arrays ; + done; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - (* It returns the variables that are singleton in one but not the + (* It returns the variables that are singleton in one but not the * other or are different singletons *) - method get_singletons_that_changed (a: 'a) : + method get_singletons_that_changed (a: 'a) : ((int * interval_t) list * (int * interval_t) list) = let arrays = self#get_arrays in let aarrays = a#get_arrays in - let (dim1, dim2) = self#get_dimensions size in + let (dim1, dim2) = self#get_dimensions size in let changed = ref [] in let achanged = ref [] in let index = ref 0 in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in - (match (interval#singleton, ainterval#singleton) with - | (Some n1, Some n2) -> - if not (n1#equal n2) then - begin - changed := (!index, interval) :: !changed ; - achanged := (!index, ainterval) :: !achanged + (match (interval#singleton, ainterval#singleton) with + | (Some n1, Some n2) -> + if not (n1#equal n2) then + begin + changed := (!index, interval) :: !changed; + achanged := (!index, ainterval) :: !achanged end - | (Some _, _) -> - if not ainterval#isBottom then + | (Some _, _) -> + if not ainterval#isBottom then changed := (!index, interval) :: !changed - | (_, Some _) -> - if not interval#isBottom then + | (_, Some _) -> + if not interval#isBottom then achanged := (!index, ainterval) :: !achanged - | _ -> () ) ; - incr index ; + | _ -> () ); + incr index; done - done ; + done; (!changed, !achanged) end (* returns a list of (index, singleton value) *) - method get_singletons = - let (dim1, dim2) = self#get_dimensions size in + method get_singletons = + let (dim1, dim2) = self#get_dimensions size in let arrays = self#get_arrays in let singletons = ref [] in let index = ref 0 in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_array = arrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in (match interval#singleton with - | Some n -> singletons := (!index, n#getNum) :: !singletons ; - | _ -> () ) ; - incr index ; + | Some n -> singletons := (!index, n#getNum) :: !singletons; + | _ -> () ); + incr index; done - done ; + done; !singletons end - method widening' (a: 'a) (* (hint_opt: 'a option) *) = + method widening' (a: 'a) (* (hint_opt: 'a option) *) = if size = 0 then - {< >} - else + {< >} + else let new_arrays = self#make_arrays size bottomInterval in let arrays = self#get_arrays in let aarrays = a#get_arrays in let (dim1, dim2) = self#get_dimensions size in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_new_array = new_arrays.(i) in let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in - let new_interval = if interval#isBottom then ainterval else interval#widening ainterval in + let new_interval = + if interval#isBottom then + ainterval + else + interval#widening ainterval in small_new_array.(j) <- new_interval done - done ; - {< intervals_opt = Some new_arrays ; + done; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - - method widening (a: 'a) (* (hint_opt: 'a option) *) = + + method widening (a: 'a) (* (hint_opt: 'a option) *) = if size = 0 then - {< >} - else + {< >} + else let new_arrays = self#make_arrays size bottomInterval in let arrays = self#get_arrays in let aarrays = a#get_arrays in let tarrays = self#get_type_arrays in let (dim1, dim2) = self#get_dimensions size in begin - for i = 0 to pred dim1 do + for i = 0 to pred dim1 do let small_new_array = new_arrays.(i) in let small_array = arrays.(i) in let small_aarray = aarrays.(i) in let small_tarray = tarrays.(i) in let dim = if i = pred dim1 then dim2 else array_size in - for j = 0 to pred dim do + for j = 0 to pred dim do let interval = small_array.(j) in let ainterval = small_aarray.(j) in let tinterval = small_tarray.(j) in let new_interval = - if interval#isBottom then ainterval else interval#widening ainterval in - small_new_array.(j) <- new_interval#meet tinterval + if interval#isBottom then + ainterval + else + interval#widening ainterval in + small_new_array.(j) <- new_interval#meet tinterval done - done ; - {< intervals_opt = Some new_arrays ; + done; + {< intervals_opt = Some new_arrays; interval_array_ind = get_interval_array_index () >} end - method iteri f = + method iteri f = let arrays = self#get_arrays in let start_index = ref 0 in - for i = 0 to Array.length arrays - 1 do - let small_array = arrays.(i) in + for i = 0 to Array.length arrays - 1 do + let small_array = arrays.(i) in let small_f j = f (!start_index + j) in - Array.iteri small_f small_array ; + Array.iteri small_f small_array; start_index := !start_index + array_size - done + done - method private type_iteri f = + method private type_iteri f = let arrays = self#get_type_arrays in let start_index = ref 0 in - for i = 0 to Array.length arrays - 1 do - let small_array = arrays.(i) in + for i = 0 to Array.length arrays - 1 do + let small_array = arrays.(i) in let small_f j = f (!start_index + j) in - Array.iteri small_f small_array ; + Array.iteri small_f small_array; start_index := !start_index + array_size - done + done (* Copies the first len entries of source into dest starting at index 0 *) - method private copy_beginning (source:'a) (dest:'a) (len:int) = + method private copy_beginning (source:'a) (dest:'a) (len:int) = let sarrays = source#get_arrays in let darrays = dest#get_arrays in if len = 0 then - () - else + () + else let (len1, len2) = self#get_dimensions len in begin - for i = 0 to pred len1 do + for i = 0 to pred len1 do let sarray = sarrays.(i) in let darray = darrays.(i) in let size = if i = pred len1 then len2 else array_size in - for j = 0 to pred size do - darray.(j) <- sarray.(j) - done + for j = 0 to pred size do + darray.(j) <- sarray.(j) + done done end - (* Unlike Array.blit, this does not work if it is the same array *) - method private blit (a: 'a) o1 (b: 'a) o2 len = - if len = 0 then () - else + (* Unlike Array.blit, this does not work if it is the same array *) + method private blit (a: 'a) o1 (b: 'a) o2 len = + if len = 0 then () + else let (astart1, astart2) = self#get_indices o1 in let (bstart1, bstart2) = self#get_indices o2 in let aarrays = a#get_arrays in @@ -557,62 +560,62 @@ class interval_array_t s = let i2 = ref astart2 in let j2 = ref bstart2 in begin - for k = 1 to len do - if !i2 = array_size then - begin - incr i1 ; - i2 := 0 ; - asmall_array := aarrays.(!i1) - end ; - if !j2 = array_size then - begin - incr j1 ; - j2 := 0 ; - bsmall_array := barrays.(!j1) - end ; - !bsmall_array.(!j2) <- !asmall_array.(!i2) ; + for _k = 1 to len do + if !i2 = array_size then + begin + incr i1; + i2 := 0; + asmall_array := aarrays.(!i1) + end; + if !j2 = array_size then + begin + incr j1; + j2 := 0; + bsmall_array := barrays.(!j1) + end; + !bsmall_array.(!j2) <- !asmall_array.(!i2); incr i2; incr j2; done end (* new_dim >= old_dim *) - method augment (old_dim:int) (new_dim:int) (interval:interval_t) = + method augment (old_dim:int) (new_dim:int) (interval:interval_t) = if old_dim = new_dim then - {< >} + {< >} else if old_dim = 0 then self#make new_dim interval - else + else let arrays = self#get_arrays in - let (old_dim1, old_dim2) = self#get_dimensions old_dim in + let (old_dim1, old_dim2) = self#get_dimensions old_dim in let pred_old_dim1 = pred old_dim1 in - let (dim1, dim2) = self#get_dimensions new_dim in + let (dim1, dim2) = self#get_dimensions new_dim in let new_arrays = Array.make dim1 empty_small_array in begin - for i = 0 to pred pred_old_dim1 do - new_arrays.(i) <- arrays.(i) - done ; + for i = 0 to pred pred_old_dim1 do + new_arrays.(i) <- arrays.(i) + done; - (if old_dim2 = array_size then - new_arrays.(pred_old_dim1) <- arrays.(pred_old_dim1) - else + (if old_dim2 = array_size then + new_arrays.(pred_old_dim1) <- arrays.(pred_old_dim1) + else begin let size = if dim1 > old_dim1 then array_size else dim2 in let new_small_array = Array.make size interval in - Array.blit arrays.(pred_old_dim1) 0 new_small_array 0 old_dim2 ; - new_arrays.(pred_old_dim1) <- new_small_array - end) ; + Array.blit arrays.(pred_old_dim1) 0 new_small_array 0 old_dim2; + new_arrays.(pred_old_dim1) <- new_small_array + end); - (if old_dim1 < dim1 then + (if old_dim1 < dim1 then begin - for i = old_dim1 to dim1 - 2 do - new_arrays.(i) <- Array.make array_size interval - done ; + for i = old_dim1 to dim1 - 2 do + new_arrays.(i) <- Array.make array_size interval + done; new_arrays.(pred dim1) <- Array.make dim2 interval - end) ; - - {< size = new_dim; intervals_opt = Some new_arrays ; - type_intervals_opt = None ; + end); + + {< size = new_dim; intervals_opt = Some new_arrays; + type_intervals_opt = None; interval_array_ind = get_interval_array_index () >} @@ -620,68 +623,72 @@ class interval_array_t s = (* Changes the size of the array *) (* inds_to_remove have to be sorted from largest to smallest *) - method remove_entries (dim:int) (inds_to_remove:int list) = - let remove (res, dim) ind = + method remove_entries (dim:int) (inds_to_remove:int list) = + let remove (res, dim) ind = let new_dim = pred dim in let new_array = self#make new_dim topInterval in begin - self#copy_beginning res new_array ind ; - self#blit res (succ ind) new_array ind (new_dim - ind) ; + self#copy_beginning res new_array ind; + self#blit res (succ ind) new_array ind (new_dim - ind); (new_array, new_dim) end in - let (res, new_dim) = List.fold_left remove (self, dim) inds_to_remove in - res + let (res, _new_dim) = List.fold_left remove (self, dim) inds_to_remove in + res - method remap (dim:int) (map:(int * int) list) = + method remap (dim:int) (map:(int * int) list) = let new_array = self#make dim topInterval in begin - for i = 0 to pred dim do - let new_i = List.assoc i map in - new_array#set new_i (self#get i) - done ; + for i = 0 to pred dim do + let new_i = List.assoc i map in + new_array#set new_i (self#get i) + done; new_array end - method to_pretty (vars:variable_t list) = + method to_pretty (vars:variable_t list) = try (* if it is top *) let pps = ref [] in - let vs = ref vars in - let add_interval i interval = + let vs = ref vars in + let add_interval _i interval = let v = List.hd !vs in begin - pps := (LBLOCK [v#toPretty; STR " -> "; interval#toPretty; NL]) :: !pps ; + pps := + (LBLOCK [v#toPretty; STR " -> "; interval#toPretty; NL]) :: !pps; vs := List.tl !vs end in - self#iteri add_interval ; - + self#iteri add_interval; + let pps_types = ref [] in - let vs = ref vars in - let add_interval i interval = + let vs = ref vars in + let add_interval _i interval = let v = List.hd !vs in begin - pps_types := (LBLOCK [v#toPretty; STR " -> "; interval#toPretty; NL]) :: !pps_types ; + pps_types := + (LBLOCK [ + v#toPretty; STR " -> "; interval#toPretty; NL]) :: !pps_types; vs := List.tl !vs end in - self#type_iteri add_interval ; - + self#type_iteri add_interval; + LBLOCK[ STR "intervals: "; INT interval_array_ind; NL; LBLOCK (List.rev !pps); NL; STR "types: "; NL; LBLOCK (List.rev !pps_types) ] - with _ -> + with _ -> self#toPretty - - method toPretty = + + method toPretty = let pps = ref [] in - let add_interval i interval = - if not interval#isBottom then + let add_interval i interval = + if not interval#isBottom then pps := (LBLOCK [INT i; STR " -> "; interval#toPretty; NL]) :: !pps in - self#iteri add_interval ; - + self#iteri add_interval; + let pps_types = ref [] in - let add_interval i interval = - pps_types := (LBLOCK [INT i; STR " -> "; interval#toPretty; NL]) :: !pps_types in - self#type_iteri add_interval ; - + let add_interval i interval = + pps_types := + (LBLOCK [INT i; STR " -> "; interval#toPretty; NL]) :: !pps_types in + self#type_iteri add_interval; + LBLOCK[ STR "intervals: "; INT interval_array_ind; NL; LBLOCK (List.rev !pps); NL; STR "types: "; NL; LBLOCK (List.rev !pps_types) ] @@ -690,16 +697,17 @@ class interval_array_t s = (extra_infos:JCHNumericInfo.numeric_info_t) (indent:string) (vars:variable_t list) = - pr__debug [STR indent; STR "intervals: "; INT interval_array_ind; NL] ; + pr__debug [STR indent; STR "intervals: "; INT interval_array_ind; NL]; let vs = ref vars in let pp_interval has_excluded i interval = let v = - try + try List.hd !vs with _ -> - pr__debug [STR indent; STR "i = "; INT i; STR " -> "; interval#toPretty; NL]; + pr__debug [ + STR indent; STR "i = "; INT i; STR " -> "; interval#toPretty; NL]; List.hd !vs in - vs := List.tl !vs ; + vs := List.tl !vs; pr__debug [STR indent; v#toPretty; STR " -> "; interval#toPretty; ]; if has_excluded then let excls = extra_infos#get_excluded_vals v in @@ -707,23 +715,21 @@ class interval_array_t s = pr__debug [STR " - "; pp_list excls; NL] else pr__debug [NL] else pr__debug [NL] in - self#iteri (pp_interval true); + self#iteri (pp_interval true); pr__debug [NL; STR indent; STR "types: "; NL]; - vs := vars ; + vs := vars; self#type_iteri (pp_interval false); pr__debug[NL]; - end + end -let make_top_intervals size = (new interval_array_t size)#make_top_intervals size +let make_top_intervals size = (new interval_array_t size)#make_top_intervals size -let make_from_types (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = - let size = List.length vars in +let make_from_types (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = + let size = List.length vars in if size = 0 then - (new interval_array_t 0) - else + (new interval_array_t 0) + else let new_interval_array = make_top_intervals size in - (new_interval_array#set_type_intervals jproc_info vars)#make_from_types size - - + (new_interval_array#set_type_intervals jproc_info vars)#make_from_types size diff --git a/CodeHawk/CHJ/jchpoly/jCHIntervalArray.mli b/CodeHawk/CHJ/jchpoly/jCHIntervalArray.mli index fa6b1081..71173473 100644 --- a/CodeHawk/CHJ/jchpoly/jCHIntervalArray.mli +++ b/CodeHawk/CHJ/jchpoly/jCHIntervalArray.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -32,12 +33,12 @@ open CHIntervals open CHLanguage open CHPretty - -class interval_array_t : - int -> + +class interval_array_t : + int -> object ('a) method augment : int -> int -> interval_t -> 'a - method get_arrays : interval_t array array + method get_arrays : interval_t array array method clone : 'a method copy : 'a method copy_set : int -> interval_t -> 'a @@ -45,9 +46,9 @@ class interval_array_t : method get : int -> interval_t method get_type_interval : int -> interval_t method get_singletons : (int * big_int) list - method get_singletons_that_changed : 'a -> - (int * interval_t) list * (int * interval_t) list - method is_discrete : int -> bool + method get_singletons_that_changed : 'a -> + (int * interval_t) list * (int * interval_t) list + method is_discrete : int -> bool method iteri : (int -> interval_t -> unit) -> unit method join' : int -> 'a -> 'a method join : 'a -> 'a @@ -75,7 +76,8 @@ class interval_array_t : end -val make_top_intervals : int -> interval_array_t -val make_from_types : JCHProcInfo.jproc_info_t -> variable_t list -> interval_array_t +val make_top_intervals : int -> interval_array_t +val make_from_types : + JCHProcInfo.jproc_info_t -> variable_t list -> interval_array_t val dbg : bool ref diff --git a/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.ml b/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.ml index 89d1fbfa..f274126b 100644 --- a/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.ml +++ b/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -33,86 +34,83 @@ open CHIntervals open CHLanguage open CHNumerical open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil (* jchlib *) -open JCHBasicTypes open JCHBasicTypesAPI (* jchpre *) open JCHPreAPI -(* jchsys *) -open JCHSystemUtils -open JCHPrintUtils - -(* jchpoly *) -open JCHNumericUtils - -let dbg = ref false -let params = JCHAnalysisUtils.numeric_params +let _params = JCHAnalysisUtils.numeric_params -(* The ineq is >= *) +(* The ineq is >= *) (* sum of a * v + cont = or >= 0 where pairs is a list (ind, a) *) -class linear_constraint_t iseq ps cnst = +class linear_constraint_t iseq ps cnst = object (self: 'a) - val is_eq = iseq + val is_eq = iseq val pairs = ref [] val const = ref zero_big_int - initializer - let (ps', cnst') = + initializer + let (ps', cnst') = if is_eq && (List.length ps) > 0 then let (_, coeff) = List.hd ps in - if ge_big_int coeff zero_big_int then (ps, cnst) - else (List.map (fun (i, c) -> (i, minus_big_int c)) ps, minus_big_int cnst) - else (ps, cnst) in - let compare_pairs (i1, n1) (i2, n2) = compare i1 i2 in - pairs := List.sort compare_pairs ps' ; + if ge_big_int coeff zero_big_int then + (ps, cnst) + else + (List.map (fun (i, c) -> (i, minus_big_int c)) ps, minus_big_int cnst) + else + (ps, cnst) in + let compare_pairs (i1, _n1) (i2, _n2) = compare i1 i2 in + pairs := List.sort compare_pairs ps'; const := cnst' method is_equality = is_eq - method compare (a: 'a) = + method compare (a: 'a) = let (apairs, aconst) = a#get_pairs_const in match (is_eq, a#is_equality) with | (true, false) -> 1 | (false, true) -> -1 - | _ -> - let rec compare_pairs ps1 ps2 = - match (ps1, ps2) with - | ([], []) -> - if eq_big_int !const aconst then 0 - else if gt_big_int !const aconst then 1 - else -1 + | _ -> + let rec compare_pairs ps1 ps2 = + match (ps1, ps2) with + | ([], []) -> + if eq_big_int !const aconst then + 0 + else if gt_big_int !const aconst then + 1 + else + -1 | ([], _) -> -1 | (_, []) -> 1 - | ((ind1, coeff1) :: rest_ps1, (ind2, coeff2) :: rest_ps2) -> + | ((ind1, coeff1) :: rest_ps1, (ind2, coeff2) :: rest_ps2) -> let c = compare ind1 ind2 in - if c = 0 then - if eq_big_int coeff1 coeff2 then compare_pairs rest_ps1 rest_ps2 - else if gt_big_int coeff1 coeff2 then 1 - else -1 - else c in + if c = 0 then + if eq_big_int coeff1 coeff2 then + compare_pairs rest_ps1 rest_ps2 + else if gt_big_int coeff1 coeff2 then + 1 + else + -1 + else + c in compare_pairs !pairs apairs - method is_const_equality = + method is_const_equality = is_eq && (List.length !pairs = 1) - method is_interval = + method is_interval = List.length !pairs = 1 - method is_1_geq_0 = + method is_1_geq_0 = not is_eq && !pairs = [] && (eq_big_int !const unit_big_int) - method is_0_geq_0 = + method is_0_geq_0 = not is_eq && !pairs = [] && (eq_big_int !const zero_big_int) - method get_pairs_const = (!pairs, !const) + method get_pairs_const = (!pairs, !const) method is_const = !pairs = [] @@ -120,50 +118,51 @@ class linear_constraint_t iseq ps cnst = if JCHTypeUtils.integer_interval#contains (new numerical_t !const) then List.for_all (fun (_, n) -> JCHTypeUtils.integer_interval#contains (new numerical_t n)) !pairs - else false + else + false - method number_pairs = List.length !pairs + method number_pairs = List.length !pairs - method has_index ind = - List.exists (fun (i, _) -> i = ind) !pairs + method has_index ind = + List.exists (fun (i, _) -> i = ind) !pairs - method replace_consts ls = + method replace_consts ls = let rest_pairs = ref [] in let new_const = ref !const in - let check (ind, coeff) = - match List.partition (fun (i, c) -> i = ind) ls with - | ((_, cst) :: _, _) -> + let check (ind, coeff) = + match List.partition (fun (i, _c) -> i = ind) ls with + | ((_, cst) :: _, _) -> new_const := add_big_int !new_const (mult_big_int coeff cst) | _ -> rest_pairs := (ind, coeff) :: !rest_pairs in - List.iter check !pairs ; - {< pairs = rest_pairs ; const = new_const >} + List.iter check !pairs; + {< pairs = rest_pairs; const = new_const >} - method remap map = + method remap map = let new_pairs = List.map (fun (i, c) -> (List.assoc i map, c)) !pairs in new linear_constraint_t is_eq new_pairs !const - method to_array size = + method to_array size = let a = Array.make size zero_big_int in - a.(pred size) <- !const ; - let set_pair (ind, c) = + a.(pred size) <- !const; + let set_pair (ind, c) = a.(ind) <- c in - List.iter set_pair !pairs ; + List.iter set_pair !pairs; (is_eq, a) method get_used_indices = List.map fst !pairs - method get_max_and_nr_coeffs = + method get_max_and_nr_coeffs = let max = ref !const in - let add_pair (int, c) = + let add_pair (_int, c) = let abs_c = abs_big_int c in if gt_big_int abs_c !max then max := abs_c in - List.iter add_pair !pairs ; + List.iter add_pair !pairs; (!max, List.length !pairs) - method get_v_interval = - match !pairs with - | [(i, coeff)] -> - let int = + method get_v_interval = + match !pairs with + | [(i, coeff)] -> + let int = if is_eq then mkSingletonInterval (mkNumerical_big !const)#neg else @@ -180,19 +179,19 @@ class linear_constraint_t iseq ps cnst = (lc_pairs: (int * int) list) (length_pairs: (int * int) list) (aux_map: (int * string) list) - (aux_length_map: (int * string) list):jterm_t = - let mk_sum_op (i, c) = - let v = + (aux_length_map: (int * string) list):jterm_t = + let mk_sum_op (i, c) = + let v = try (* v is an argument or return *) - let arg_ind = List.assoc i map in - JLocalVar arg_ind + let arg_ind = List.assoc i map in + JLocalVar arg_ind with _ -> (* v is a loop counter *) try - JLoopCounter (List.assoc i lc_pairs) + JLoopCounter (List.assoc i lc_pairs) with _ -> (* v is a length of an argument or return *) try let array_ind = List.assoc i length_pairs in - JSize (JLocalVar array_ind) + JSize (JLocalVar array_ind) with _ -> (* v is an auxiliary var *) try let name = List.assoc i aux_map in @@ -206,18 +205,18 @@ class linear_constraint_t iseq ps cnst = else JArithmeticExpr (JTimes, coeff, v) in let exprs = List.map mk_sum_op !pairs in - let add_product expr_opt p = - match expr_opt with + let add_product expr_opt p = + match expr_opt with | Some expr -> Some (JArithmeticExpr (JPlus, p, expr)) | _ -> Some p in - let expr = + let expr = let e = Option.get (List.fold_left add_product None exprs) in if eq_big_int !const zero_big_int then e else JArithmeticExpr (JPlus, e, JConstant (mkNumerical_big !const)) in expr - + method to_relational_expr (map: (int * int) list) (lc_pairs:(int * int) list) @@ -225,7 +224,7 @@ class linear_constraint_t iseq ps cnst = (aux_map:(int * string) list) (aux_length_map:(int * string) list) = let expr = self#to_jterm map lc_pairs length_pairs aux_map aux_length_map in - if is_eq then + if is_eq then (JEquals, expr, JConstant numerical_zero) else (JGreaterEqual, expr, JConstant numerical_zero) @@ -248,23 +247,23 @@ class linear_constraint_t iseq ps cnst = PostRelationalExpr (self#to_relational_expr map lc_pairs length_pairs aux_map aux_length_map) - method to_string = - let rec add_pair first str (pairs: (int * big_int) list) = - match pairs with - | (ind, c) :: rest_pairs -> + method to_string = + let rec add_pair first str (pairs: (int * big_int) list) = + match pairs with + | (ind, c) :: rest_pairs -> if eq_big_int c zero_big_int then add_pair first str rest_pairs - else if first then + else if first then add_pair false ((string_of_big_int c) ^ "v_" ^ (string_of_int ind)) rest_pairs - else if gt_big_int c zero_big_int then + else if gt_big_int c zero_big_int then add_pair false (str ^ " + " ^ (string_of_big_int c) ^ "v_" ^ (string_of_int ind)) rest_pairs - else + else add_pair false (str @@ -274,226 +273,233 @@ class linear_constraint_t iseq ps cnst = ^ (string_of_int ind)) rest_pairs | [] -> str in - let expr_str = + let expr_str = let str = add_pair true "" !pairs in if eq_big_int !const zero_big_int then str - else if gt_big_int !const zero_big_int then + else if gt_big_int !const zero_big_int then str ^ " + " ^ (string_of_big_int !const) - else + else str ^ " - " ^ (string_of_big_int (minus_big_int !const)) in if is_eq then expr_str ^ " = 0" else - expr_str ^ " >= 0" + expr_str ^ " >= 0" - method to_pretty (vars: variable_t array) = + method to_pretty (vars: variable_t array) = let pp = ref [] in - let rec add_pair first (pairs: (int * big_int) list) = - match pairs with + let rec add_pair first (pairs: (int * big_int) list) = + match pairs with | (ind, c) :: rest_pairs -> let v = vars.(ind) in if eq_big_int c zero_big_int then add_pair first rest_pairs - else if first then + else if first then begin if eq_big_int c unit_big_int then - pp := v#toPretty :: !pp + pp := v#toPretty :: !pp else if eq_big_int c (minus_big_int unit_big_int) then - pp := v#toPretty :: (STR "-") :: !pp + pp := v#toPretty :: (STR "-") :: !pp else - pp := v#toPretty :: (STR (string_of_big_int c)) :: !pp ; + pp := v#toPretty :: (STR (string_of_big_int c)) :: !pp; add_pair false rest_pairs end - else if gt_big_int c zero_big_int then + else if gt_big_int c zero_big_int then begin if eq_big_int c unit_big_int then - pp := v#toPretty :: (STR " + ") :: !pp + pp := v#toPretty :: (STR " + ") :: !pp else - pp := v#toPretty :: (STR (" + " ^ (string_of_big_int c) ^ "")) :: !pp ; + pp := + v#toPretty :: (STR (" + " ^ (string_of_big_int c) ^ "")) :: !pp; add_pair false rest_pairs end - else + else begin if eq_big_int c (minus_big_int unit_big_int) then - pp := v#toPretty :: (STR " - ") :: !pp + pp := v#toPretty :: (STR " - ") :: !pp else pp := v#toPretty - :: (STR (" - " ^ (string_of_big_int (minus_big_int c)) ^ "")) :: !pp ; + :: (STR (" - " ^ (string_of_big_int (minus_big_int c)) ^ "")) + :: !pp; add_pair false rest_pairs end | [] -> pp in let pp = add_pair true !pairs in (if eq_big_int !const zero_big_int then () - else if gt_big_int !const zero_big_int then + else if gt_big_int !const zero_big_int then pp := (STR (" + " ^ (string_of_big_int !const))) :: !pp - else - pp := (STR (" - " ^ (string_of_big_int (minus_big_int !const)))) :: !pp ) ; + else + pp := (STR (" - " ^ (string_of_big_int (minus_big_int !const)))) :: !pp ); (if is_eq then pp := (STR " = 0") :: !pp else - pp := (STR " >= 0") :: !pp) ; + pp := (STR " >= 0") :: !pp); LBLOCK (List.rev !pp) method toPretty = - LBLOCK [STR (self#to_string)] + LBLOCK [STR (self#to_string)] end let mk_arg_constraint_from_rel_expr (name_to_index:(string * int) list) (index_to_types:(int * value_type_t list) list) - (rel_expr:relational_expr_t) = - let rec add_to_pairs (pairs, const, is_float) coeff expr = + (rel_expr:relational_expr_t) = + let rec add_to_pairs (pairs, const, is_float) coeff expr = match expr with (* TBA: JPower (t,n), JUninterpreted (name,terms) ?? *) | JArithmeticExpr (JPlus, e1, e2) -> let (pairs1, const1, is_float1) = add_to_pairs (pairs, const, is_float) coeff e1 in - add_to_pairs (pairs1, const1, is_float1) coeff e2 + add_to_pairs (pairs1, const1, is_float1) coeff e2 | JArithmeticExpr (JMinus, e1, e2) -> let (pairs1, const1, is_float1) = add_to_pairs (pairs, const, is_float) coeff e1 in add_to_pairs (pairs1, const1, is_float1) (minus_big_int coeff) e2 | JArithmeticExpr (JTimes, JConstant num, e2) -> add_to_pairs (pairs, const, is_float) (mult_big_int coeff num#getNum) e2 - | JLocalVar (-1) -> + | JLocalVar (-1) -> let index = List.assoc "return" name_to_index in - let is_float = JCHTypeUtils.can_be_float (List.assoc index index_to_types) in + let is_float = + JCHTypeUtils.can_be_float (List.assoc index index_to_types) in ((index, coeff) :: pairs, const, is_float) - | JLocalVar i -> + | JLocalVar i -> let index = List.assoc ("arg" ^ (string_of_int i)) name_to_index in - let is_float = JCHTypeUtils.can_be_float (List.assoc index index_to_types) in + let is_float = + JCHTypeUtils.can_be_float (List.assoc index index_to_types) in ((index, coeff) :: pairs, const, is_float) - | JConstant num -> + | JConstant num -> (pairs, add_big_int const (mult_big_int coeff num#getNum), false) - | JBoolConstant true -> + | JBoolConstant true -> (pairs, add_big_int const (mult_big_int coeff unit_big_int), false) - | JBoolConstant false -> + | JBoolConstant false -> (pairs, add_big_int const (mult_big_int coeff zero_big_int), false) - | JSize (JLocalVar (-1)) -> + | JSize (JLocalVar (-1)) -> ((List.assoc "length_return" name_to_index, coeff) :: pairs, const, false) - | JSize (JLocalVar i) -> + | JSize (JLocalVar i) -> ((List.assoc ("length_arg" ^ (string_of_int i)) name_to_index, coeff) :: pairs, const, false) | JAuxiliaryVar name -> ((List.assoc name name_to_index, coeff) :: pairs, const, false) - | _ -> + | _ -> raise Exit in - let rec make_constr (re:relational_expr_t) = + let rec make_constr (re:relational_expr_t) = match re with - | (JEquals, term1, term2) -> + | (JEquals, term1, term2) -> let (pairs1, const1, is_float1) = add_to_pairs ([], zero_big_int, false) unit_big_int term1 in - let (pairs, const, is_float) = - add_to_pairs (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in - new linear_constraint_t true pairs const - | (JLessThan, term1, term2) -> + let (pairs, const, _is_float) = + add_to_pairs + (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in + new linear_constraint_t true pairs const + | (JLessThan, term1, term2) -> make_constr (JGreaterThan, term2, term1) - | (JLessEqual, term1, term2) -> + | (JLessEqual, term1, term2) -> make_constr (JGreaterEqual, term2, term1) - | (JGreaterThan, term1, term2) -> + | (JGreaterThan, term1, term2) -> let (pairs1, const1, is_float1) = add_to_pairs ([], zero_big_int, false) unit_big_int term1 in let (pairs, const, is_float) = - add_to_pairs (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in - if is_float then - new linear_constraint_t false pairs const - else + add_to_pairs + (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in + if is_float then + new linear_constraint_t false pairs const + else new linear_constraint_t false pairs (sub_big_int const unit_big_int) - - | (JGreaterEqual, term1, term2) -> + + | (JGreaterEqual, term1, term2) -> let (pairs1, const1, is_float1) = add_to_pairs ([], zero_big_int, false) unit_big_int term1 in - let (pairs, const, is_float) = - add_to_pairs (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in - new linear_constraint_t false pairs const + let (pairs, const, _is_float) = + add_to_pairs + (pairs1, const1, is_float1) (minus_big_int unit_big_int) term2 in + new linear_constraint_t false pairs const | _ -> raise Exit in make_constr rel_expr let mk_arg_constraint_from_post_predicate (name_to_index:(string * int) list) (index_to_types:(int * value_type_t list) list) - (post:postcondition_predicate_t) = - match post with - | PostRelationalExpr (op, term1, term2) -> + (post:postcondition_predicate_t) = + match post with + | PostRelationalExpr (op, term1, term2) -> mk_arg_constraint_from_rel_expr - name_to_index index_to_types (op, term1, term2) - | PostWrapped term -> + name_to_index index_to_types (op, term1, term2) + | PostWrapped term -> mk_arg_constraint_from_rel_expr name_to_index index_to_types (JEquals, JLocalVar (-1), term) - | PostUnwrapped -> + | PostUnwrapped -> mk_arg_constraint_from_rel_expr name_to_index index_to_types (JEquals, JLocalVar (-1), JLocalVar 0) - | _ -> raise Exit + | _ -> raise Exit let mk_constraints_from_interval - (only_small:bool) (ind:int) (interval:interval_t) = + (only_small:bool) (ind:int) (interval:interval_t) = let constrs = ref [] in let is_eq = Option.is_some interval#singleton in begin - match interval#getMin#getBound with - | NUMBER min -> + match interval#getMin#getBound with + | NUMBER min -> let c = min#neg#getNum in if not only_small - || JCHAnalysisUtils.numeric_params#is_good_coefficient c then - constrs := [new linear_constraint_t is_eq [(ind, unit_big_int)] c] - | _ -> () - end ; - if not is_eq then + || JCHAnalysisUtils.numeric_params#is_good_coefficient c then + constrs := [new linear_constraint_t is_eq [(ind, unit_big_int)] c] + | _ -> () + end; + if not is_eq then begin - match interval#getMax#getBound with - | NUMBER max -> + match interval#getMax#getBound with + | NUMBER max -> let c = max#getNum in if not only_small - || JCHAnalysisUtils.numeric_params#is_good_coefficient c then + || JCHAnalysisUtils.numeric_params#is_good_coefficient c then constrs := (new linear_constraint_t false [(ind, minus_big_int unit_big_int)] c) :: !constrs - | _ -> () - end ; + | _ -> () + end; !constrs -let linear_constraint_of_array (is_eq:bool) (a:big_int array) = +let linear_constraint_of_array (is_eq:bool) (a:big_int array) = let ncols = Array.length a in let nvars = pred ncols in let const = a.(nvars) in let pairs = ref [] in - let add_pair i c = - if i <> nvars && not (eq_big_int c zero_big_int) then + let add_pair i c = + if i <> nvars && not (eq_big_int c zero_big_int) then pairs := (i, c) :: !pairs in - Array.iteri add_pair a ; - new linear_constraint_t is_eq !pairs const + Array.iteri add_pair a; + new linear_constraint_t is_eq !pairs const -let linear_constraints_of_matrix (is_eq:bool) (m:big_int array array) = +let linear_constraints_of_matrix (is_eq:bool) (m:big_int array array) = let constrs = ref [] in for i = 0 to pred (Array.length m) do constrs := (linear_constraint_of_array is_eq m.(i)) :: !constrs - done ; + done; !constrs let linear_constraints_to_matrices (nvars:int) (constrs:linear_constraint_t list) = let size = nvars + 1 in - let (eq_constrs, ineq_constrs) = - let (eq_cs, ineq_cs) = + let (eq_constrs, ineq_constrs) = + let (eq_cs, ineq_cs) = List.partition fst (List.map (fun c -> c#to_array size) constrs) in (List.map snd eq_cs, List.map snd ineq_cs) in let eq_nrows = List.length eq_constrs in let ineq_nrows = List.length ineq_constrs in let eq_m = Array.make_matrix eq_nrows size zero_big_int in let ineq_m = Array.make_matrix ineq_nrows size zero_big_int in - let rec add_constrs m col constrs = - match constrs with - | constr :: rest_constrs -> - m.(col) <- constr ; + let rec add_constrs m col constrs = + match constrs with + | constr :: rest_constrs -> + m.(col) <- constr; add_constrs m (succ col) rest_constrs | _ -> () in begin - add_constrs eq_m 0 eq_constrs ; - add_constrs ineq_m 0 ineq_constrs ; + add_constrs eq_m 0 eq_constrs; + add_constrs ineq_m 0 ineq_constrs; (eq_m, ineq_m) end diff --git a/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.mli b/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.mli index 3a7b19e9..31245aaf 100644 --- a/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.mli +++ b/CodeHawk/CHJ/jchpoly/jCHLinearConstraint.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -39,7 +40,7 @@ open JCHBasicTypesAPI open JCHPreAPI class linear_constraint_t : -bool -> (int * big_int) list -> big_int -> +bool -> (int * big_int) list -> big_int -> object ('a) method compare : 'a -> int method get_max_and_nr_coeffs : big_int * int @@ -60,7 +61,7 @@ object ('a) method to_array : int -> bool * big_int array method to_pretty : variable_t array -> pretty_t method to_string : string - + method to_pre_predicate : (int * int) list -> (int * int) list @@ -68,7 +69,7 @@ object ('a) -> (int * string) list -> (int * string) list -> precondition_predicate_t - + method to_post_predicate : (int * int) list -> (int * int) list @@ -76,7 +77,7 @@ object ('a) -> (int * string) list -> (int * string) list -> postcondition_predicate_t - + method to_relational_expr : (int * int) list -> (int * int) list @@ -88,23 +89,23 @@ object ('a) method replace_consts : (int * big_int) list -> 'a end -val mk_arg_constraint_from_rel_expr : +val mk_arg_constraint_from_rel_expr : (string * int) list -> (int * value_type_t list) list -> relational_expr_t -> linear_constraint_t - -val mk_arg_constraint_from_post_predicate : + +val mk_arg_constraint_from_post_predicate : (string * int) list -> (int * value_type_t list) list -> postcondition_predicate_t -> linear_constraint_t - + val mk_constraints_from_interval : bool -> int -> interval_t -> linear_constraint_t list - + val linear_constraints_of_matrix : bool -> big_int array array -> linear_constraint_t list - + val linear_constraints_to_matrices: int -> linear_constraint_t list -> big_int array array * big_int array array diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.ml b/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.ml index 1cf93056..f97710b3 100755 --- a/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.ml +++ b/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.ml @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -66,10 +66,10 @@ module H = Hashtbl let dbg = ref false -(* invariants saved during analysis by jch_op_semantics *) +(* invariants saved during analysis by jch_op_semantics *) let numeric_invs:domain_int IntCollections.table_t ref = ref (new IntCollections.table_t) (* pc -> poly_int_dom *) - + let old_numeric_invs:domain_int IntCollections.table_t ref = ref (new IntCollections.table_t) (* pc -> poly_int_dom *) @@ -81,49 +81,49 @@ let get_numeric_invariants (proc_name: symbol_t) = with _ -> None let max_loop_iterations = ref (H.create 3) (* cmsix -> pc -> poly_int_dom *) - + let add_exit_loop (cmsix:int) (pc:int) (dom:domain_int) = - let table: ('a, 'b) H.t = + let table: ('a, 'b) H.t = match H.find_opt !max_loop_iterations cmsix with | Some t -> t | _ -> let t = H.create 3 in - + (if !dbg then - pr__debug [STR "add_exit_loop add "; INT cmsix; STR " "; INT pc; NL]) ; - + pr__debug [STR "add_exit_loop add "; INT cmsix; STR " "; INT pc; NL]); + H.add !max_loop_iterations cmsix t; t in match H.find_opt table pc with | Some old_dom -> - + (if !dbg then - pr__debug [STR "add_exit_loop replace "; INT cmsix; STR " "; INT pc; NL]) ; - + pr__debug [STR "add_exit_loop replace "; INT cmsix; STR " "; INT pc; NL]); + H.replace table pc (old_dom#join ?variables:(Some []) dom) | _ -> (if !dbg then - pr__debug [STR "add_exit_loop add "; INT cmsix; STR " "; INT pc; NL]) ; - + pr__debug [STR "add_exit_loop add "; INT cmsix; STR " "; INT pc; NL]); + H.add table pc dom let get_exit_loop (cmsix:int) (pc:int) = - + (if !dbg then - pr__debug [STR "get_exit_loop "; INT cmsix; STR " "; INT pc; NL]) ; - + pr__debug [STR "get_exit_loop "; INT cmsix; STR " "; INT pc; NL]); + match H.find_opt !max_loop_iterations cmsix with | Some table -> begin (if !dbg then - pr__debug [STR "get_exit_loop found table"; NL]) ; - + pr__debug [STR "get_exit_loop found table"; NL]); + match H.find_opt table pc with | Some dom -> - + (if !dbg then - pr__debug [STR "get_exit_loop found dom"; NL]) ; - + pr__debug [STR "get_exit_loop found dom"; NL]); + Some dom | _ -> None end @@ -131,8 +131,8 @@ let get_exit_loop (cmsix:int) (pc:int) = module TypeCollections = CHCollections.Make (struct - type t = value_type_t - let compare = compare_value_types + type t = value_type_t + let compare = compare_value_types let toPretty = value_type_to_pretty end) @@ -140,7 +140,7 @@ let change_stack_layout (proc_name:symbol_t) (jproc_info:JCHProcInfo.jproc_info_t) (invariant:atlas_t) - (pc:int) = + (pc:int) = let poly_int_array = JCHPolyIntDomainNoArrays.get_poly_int_array (invariant#getDomain poly_dom_name) in @@ -153,92 +153,92 @@ let change_stack_layout let var_type = var_info#get_types in let slot_type = slot#get_type in - if JCHTypeUtils.sub_value_type_lists var_type slot_type then - if JCHSystemUtils.is_number var then + if JCHTypeUtils.sub_value_type_lists var_type slot_type then + if JCHSystemUtils.is_number var then begin let vtype = Option.get (var_info#get_basic_num_type) in - let int = + let int = let int = poly_int_array#get_interval var in - if slot#has_value then - let slot_interval = + if slot#has_value then + let slot_interval = try - JCHAnalysisUtils.get_slot_interval slot + JCHAnalysisUtils.get_slot_interval slot with _ -> begin - pr__debug [STR "Analysis failed: programming error: problem in get slot interval"; NL] ; + pr__debug [STR "Analysis failed: programming error: problem in get slot interval"; NL]; raise (JCHAnalysisUtils.numeric_params#analysis_failed 3 "programming error: problem in get slot interval") end in - int#join slot_interval + int#join slot_interval else int in - if JCHTypeUtils.is_bool vtype then - match int#singleton with - | Some num -> + if JCHTypeUtils.is_bool vtype then + match int#singleton with + | Some num -> slot#set_value (mk_boolconstant_jterm_range (num#equal numerical_one)) - | _ -> () - else - match vtype with + | _ -> () + else + match vtype with | TBasic Byte | TBasic Short | TBasic Char - | TBasic Int - | TBasic Int2Bool + | TBasic Int + | TBasic Int2Bool | TBasic ByteBool -> (try - let min_num = - match int#getMin#getBound with + let min_num = + match int#getMin#getBound with | NUMBER min -> Some min | _ -> None in - let max_num = - match int#getMax#getBound with + let max_num = + match int#getMax#getBound with | NUMBER max -> Some max | _ -> None in slot#set_value (mk_intrange min_num max_num) - with _ -> + with _ -> begin - pr__debug [ STR "expected integer bound: "; INT pc; STR " "; - var#toPretty; NL; proc_name#toPretty; NL; - invariant#toPretty; NL; jproc_info#toPretty; NL] ; + pr__debug [ STR "expected integer bound: "; INT pc; STR " "; + var#toPretty; NL; proc_name#toPretty; NL; + invariant#toPretty; NL; jproc_info#toPretty; NL]; slot#set_value JCHJTerm.intminmax_jterm_range end) | TBasic Long -> - let min_long = - match int#getMin#getBound with + let min_long = + match int#getMin#getBound with | NUMBER min -> Some min | _ -> None in - let max_long = - match int#getMax#getBound with + let max_long = + match int#getMax#getBound with | NUMBER max -> Some max | _ -> None in slot#set_value (mk_intrange min_long max_long) | _ -> - let min_float = - match int#getMin#getBound with + let min_float = + match int#getMin#getBound with | NUMBER min -> Some (float_of_big_int min#getNum) | _ -> None in - let max_float = - match int#getMin#getBound with + let max_float = + match int#getMin#getBound with | NUMBER max -> Some (float_of_big_int max#getNum) | _ -> None in slot#set_value (mk_floatrange min_float max_float) end in - List.iter change_slot stack_layout#get_slots - + List.iter change_slot stack_layout#get_slots + (* taint analysis support *) - + let local_var_maps = ref (H.create 0) - + let set_local_var_maps (proc_name: symbol_t) (*invs*) = let pc_table = new IntCollections.table_t in let add_pc_dom (pc, dom) = let map = JCHPolyIntDomainNoArrays.get_local_var_map dom in let map_table = new VariableCollections.table_t in - List.iter (fun (v1, v2) -> map_table#set v1 v2) map ; + List.iter (fun (v1, v2) -> map_table#set v1 v2) map; pc_table#set pc map_table in begin - List.iter add_pc_dom !numeric_invs#listOfPairs ; + List.iter add_pc_dom !numeric_invs#listOfPairs; H.replace !local_var_maps proc_name#getSeqNumber pc_table end @@ -248,10 +248,10 @@ let get_local_var_maps (proc_name: symbol_t) = with _ -> new IntCollections.table_t - + (* cost analysis support *) -module JTermCollections = CHCollections.Make +module JTermCollections = CHCollections.Make (struct type t = jterm_t let compare j1 j2 = JCHJTerm.jterm_compare j1 j2 @@ -260,7 +260,7 @@ module JTermCollections = CHCollections.Make let method_arg_lbounds = ref (new IntCollections.table_t) (* cmsix -> pc -> arg no -> lower bounds *) - + let method_arg_ubounds = ref (new IntCollections.table_t) (* cmsix -> pc -> arg no -> upper bounds *) @@ -268,19 +268,19 @@ let add_method_arg_bounds (is_lower:bool) (cmsix:int) (pc:int) - ((var_jterm, bound): jterm_t * jterm_t) = + ((var_jterm, bound): jterm_t * jterm_t) = let method_bounds = if is_lower then !method_arg_lbounds else !method_arg_ubounds in - let cms_table = + let cms_table = match method_bounds#get cmsix with | Some cms_table -> cms_table | _ -> let cms_table = new IntCollections.table_t in begin - method_bounds#set cmsix cms_table ; + method_bounds#set cmsix cms_table; cms_table end in let pc_table = @@ -289,10 +289,10 @@ let add_method_arg_bounds | _ -> let pc_table = new JTermCollections.table_t in begin - cms_table#set pc pc_table ; + cms_table#set pc pc_table; pc_table end in - + match pc_table#get var_jterm with | Some set -> set#add bound | _ -> pc_table#set var_jterm (JTermCollections.set_of_list [bound]) @@ -304,7 +304,7 @@ let get_method_arg_bounds (cmsix:int) (pc:int) = let add (jterm_var, bounds) = lists := (jterm_var, bounds#toList) :: !lists in begin - List.iter add table#listOfPairs ; + List.iter add table#listOfPairs; !lists end in let lbs = @@ -314,8 +314,8 @@ let get_method_arg_bounds (cmsix:int) (pc:int) = begin (if !dbg then - pr__debug [STR "ltable = "; NL; pc_ltable#toPretty; NL]) ; - + pr__debug [STR "ltable = "; NL; pc_ltable#toPretty; NL]); + mk_lists pc_ltable end with _ -> [] in @@ -325,36 +325,36 @@ let get_method_arg_bounds (cmsix:int) (pc:int) = let cms_table = Option.get (!method_arg_ubounds#get cmsix) in let pc_utable = Option.get (cms_table#get pc) in begin - + (if !dbg then - pr__debug [STR "utable = "; NL; pc_utable#toPretty; NL]) ; - + pr__debug [STR "utable = "; NL; pc_utable#toPretty; NL]); + mk_lists pc_utable end with _ -> [] in (lbs, ubs) -(* cmsix -> head wto -> bounds *) +(* cmsix -> head wto -> bounds *) let iterations_lbs = ref (new IntCollections.table_t) -(* cmsix -> head wto -> bounds *) -let iterations_ubs = ref (new IntCollections.table_t) - +(* cmsix -> head wto -> bounds *) +let iterations_ubs = ref (new IntCollections.table_t) + let add_iteration_bounds (jproc_info:JCHProcInfo.jproc_info_t) (pc:int) (is_lb:bool) - (bounds:jterm_t list) = + (bounds:jterm_t list) = let cmsix = jproc_info#get_name#getSeqNumber in let iterations = if is_lb then !iterations_lbs else !iterations_ubs in - let table = + let table = match iterations#get cmsix with | Some table -> table | _ -> let table = new IntCollections.table_t in begin - iterations#set cmsix table ; + iterations#set cmsix table; table end in match table#get pc with @@ -362,15 +362,15 @@ let add_iteration_bounds | _ -> let set = JTermCollections.set_of_list bounds in begin - + (if !dbg then - pr__debug [STR "add_max_iterations "; INT pc; NL; set#toPretty; NL]) ; - + pr__debug [STR "add_max_iterations "; INT pc; NL; set#toPretty; NL]); + table#set pc set end - + let get_iteration_bounds (cmsix:int) (pc:int) = - let get_bounds iterations = + let get_bounds iterations = match iterations#get cmsix with | Some table -> begin @@ -382,7 +382,7 @@ let get_iteration_bounds (cmsix:int) (pc:int) = (get_bounds !iterations_lbs, get_bounds !iterations_ubs) let pos_fields = ref (new IntCollections.table_t) - + let set_pos_fields () = let manager = JCHFields.int_field_manager in let fields = manager#get_all_num_fields in @@ -397,16 +397,16 @@ let set_pos_fields () = begin let cnix = field_info#get_class_name#index in let jterm = JCHNumericUtils.get_field_term (-1) field_info in - let table = + let table = match !pos_fields#get cnix with | Some table -> table | _ -> let table = new JTermCollections.table_t in begin - !pos_fields#set cnix table ; + !pos_fields#set cnix table; table end in - table#set jterm int + table#set jterm int end end in List.iter add_field fields @@ -418,10 +418,11 @@ let is_pos_field (jterm:jterm_t) = | JStaticFieldValue (cnix,_) | JObjectFieldValue (_,_,cnix, _) -> cnix | _ -> raise Exit in - let is_same j = + let is_same j = match (jterm, j) with - | (JStaticFieldValue (cnix1,name1), JStaticFieldValue (cnix2,name2)) - | (JObjectFieldValue (_,_,cnix1,name1), JObjectFieldValue (_,_,cnix2,name2)) -> + | (JStaticFieldValue (cnix1,name1), JStaticFieldValue (cnix2,name2)) + | (JObjectFieldValue (_,_,cnix1,name1), + JObjectFieldValue (_,_,cnix2,name2)) -> cnix1 = cnix2 && name1 = name2 | _ -> false in let res = match !pos_fields#get cnix with @@ -429,7 +430,7 @@ let is_pos_field (jterm:jterm_t) = | _ -> false in res with _ -> false - + let get_pos_field_interval (jterm:jterm_t) = try (* if jterm is not a field *) let cnix = @@ -437,19 +438,20 @@ let get_pos_field_interval (jterm:jterm_t) = | JStaticFieldValue (cnix,_) | JObjectFieldValue (_,_,cnix, _) -> cnix | _ -> raise Exit in - let is_same (j, int) = + let is_same (j, _int) = match (jterm, j) with - | (JStaticFieldValue (cnix1,name1), JStaticFieldValue (cnix2,name2)) - | (JObjectFieldValue (_,_,cnix1,name1), JObjectFieldValue (_,_,cnix2,name2)) -> + | (JStaticFieldValue (cnix1,name1), JStaticFieldValue (cnix2,name2)) + | (JObjectFieldValue (_,_,cnix1,name1), + JObjectFieldValue (_,_,cnix2,name2)) -> cnix1 = cnix2 && name1 = name2 | _ -> false in match !pos_fields#get cnix with | Some table -> Some (snd (List.find is_same table#listOfPairs)) - | _ -> None + | _ -> None with _ -> None - + let geq_terms = ref (new IntCollections.table_t) (* cmsix -> join pc -> dom *) - + let add_pos_terms (jproc_info:JCHProcInfo.jproc_info_t) (pc:int) geqs = let cmsix = jproc_info#get_name#getSeqNumber in @@ -459,10 +461,10 @@ let add_pos_terms | _ -> let table = new IntCollections.table_t in begin - table#set pc geqs ; + table#set pc geqs; !geq_terms#set cmsix table end - + let get_pos_terms (cmsix:int) (pc:int) = match !geq_terms#get cmsix with | Some table -> @@ -481,10 +483,10 @@ let get_bounds_var_ dom (var:variable_t) poly_int_array :(jterm_t * jterm_t) list * (jterm_t * jterm_t) list = - + (if !dbg - then pr__debug [STR "get_bounds_var_ "; NL]) ; - + then pr__debug [STR "get_bounds_var_ "; NL]); + let fields = poly_int_array#get_extra_infos#get_fields var in let get_field_bound field_info = let cnix = field_info#get_class_name#index in @@ -505,20 +507,20 @@ let get_bounds_var_ let field_bounds = List.concat (List.map get_field_bound fields) in let lbs = ref field_bounds in let ubs = ref field_bounds in - + let get_bounds_var_param p = - + (if !dbg then pr__debug [STR "get_bounds param "; jterm_to_pretty arg_jterm; STR " "; var#toPretty; STR " in arg"; INT p; NL]); - + let v_jterm = JLocalVar p in if jvar_info#has_length then let length_arg_jterm = JSize (arg_jterm) in let length_v_jterm = JSize (v_jterm) in begin - lbs := [(arg_jterm, v_jterm); (length_arg_jterm, length_v_jterm)] ; + lbs := [(arg_jterm, v_jterm); (length_arg_jterm, length_v_jterm)]; ubs := [(arg_jterm, v_jterm); (length_arg_jterm, length_v_jterm)] end else @@ -526,25 +528,25 @@ let get_bounds_var_ lbs := [(arg_jterm, v_jterm)]; ubs := [(arg_jterm, v_jterm)] end in - + let get_bounds_var_not_param () = try (* The variable might not be in poly *) - + (if !dbg then pr__debug [STR "get_bounds not param poly_int_array = "; NL; - poly_int_array#toPretty; NL]) ; - + poly_int_array#toPretty; NL]); + let poly = poly_int_array#get_poly in let inds = poly#get_poly_inds in let var_to_index = poly_int_array#get_var_to_index in - let find_poly_ind v = + let find_poly_ind v = let index = v#getIndex in - let is_ind (var_index, ind) = var_index = index in + let is_ind (var_index, _ind) = var_index = index in let ind = snd (List.find is_ind var_to_index) in List.find (fun i -> i = ind) inds in let var_index = find_poly_ind var in let poly_vars = poly_int_array#get_poly_vars in - let is_var_to_remove (v: variable_t) = + let is_var_to_remove (v: variable_t) = if v#equal var then false else begin @@ -555,7 +557,7 @@ let get_bounds_var_ let v'info = jproc_info#get_jvar_info v' in not v'info#is_parameter else - not vinfo#is_parameter + not vinfo#is_parameter with _ -> false end in let vars_to_remove = List.filter is_var_to_remove poly_vars in @@ -571,34 +573,35 @@ let get_bounds_var_ jterm_to_pretty arg_jterm; STR " "; var#toPretty; STR " in poly"; NL; red_poly_int_array#toPretty; NL]); - + let add_bounds_from_constraint (lbs, ubs) constr = - + (if !dbg then - pr__debug [STR "get_bounds_from_constraint "; constr#toPretty; NL]) ; - + pr__debug [ + STR "get_bounds_from_constraint "; constr#toPretty; NL]); + let (pairs, const) = constr#get_pairs_const in let get_index col = try - fst (List.find (fun (ind, c) -> c = col) var_to_index) + fst (List.find (fun (_ind, c) -> c = col) var_to_index) with _ -> begin - pr__debug [STR "variable not found for column "; INT col; NL] ; + pr__debug [STR "variable not found for column "; INT col; NL]; raise Exit end in - let (res_pairs, const, coeff, is_eq, is_leq) = + let (res_pairs, const, _coeff, is_eq, is_leq) = let rec process (res_pairs, c) pairs = match pairs with - | (col, cf) :: other_pairs -> + | (col, cf) :: other_pairs -> let ind = get_index col in if ind = var_index then process (res_pairs, cf) other_pairs else let v = List.find (fun v -> v#getIndex = ind) poly_vars in process ((v, cf) :: res_pairs, c) other_pairs - | [] -> (res_pairs, c) in + | [] -> (res_pairs, c) in let (ps, c) = process ([], zero_big_int) pairs in - if ge_big_int c zero_big_int then + if ge_big_int c zero_big_int then (List.map (fun (col, cf) -> (col, minus_big_int cf)) ps, minus_big_int const, c, @@ -615,7 +618,7 @@ let get_bounds_var_ else ref (Some (JConstant (mkNumerical_big const))) in let add_pair (v, cf) = let info = jproc_info#get_jvar_info v in - let var_jterm = + let var_jterm = if info#is_length then let corresp_v = Option.get (fst info#get_variable_from_length) in let corresp_info = jproc_info#get_jvar_info corresp_v in @@ -628,14 +631,16 @@ let get_bounds_var_ if ge_big_int cf unit_big_int then var_jterm else - JArithmeticExpr(JTimes, JConstant (mkNumerical_big cf), var_jterm) in + JArithmeticExpr( + JTimes, JConstant (mkNumerical_big cf), var_jterm) in match !jterm with | None -> jterm := Some prod_jterm - | Some jt -> jterm := Some (JArithmeticExpr(JPlus, jt, prod_jterm)) in + | Some jt -> + jterm := Some (JArithmeticExpr(JPlus, jt, prod_jterm)) in List.iter add_pair res_pairs; let jterm = Option.get !jterm in if is_eq then - (jterm :: lbs, jterm :: ubs) + (jterm :: lbs, jterm :: ubs) else if is_leq then (lbs, jterm :: ubs) else @@ -659,15 +664,15 @@ let get_bounds_var_ | NUMBER n -> ubs := (arg_jterm, JConstant n) :: !ubs | _ -> ()) with _ -> () - end ; + end; in - (match jvar_info#get_param_index with - | Some p -> get_bounds_var_param p + (match jvar_info#get_param_index with + | Some p -> get_bounds_var_param p | _ -> get_bounds_var_not_param ()); - (!lbs, !ubs) + (!lbs, !ubs) + - let get_bounds_var (jproc_info: JCHProcInfo.jproc_info_t) (cmsix:int) @@ -675,21 +680,21 @@ let get_bounds_var jvar_info dom (var:variable_t):(jterm_t * jterm_t) list * (jterm_t * jterm_t) list = - + (if !dbg then pr__debug [STR "get_bounds_var arg_"; INT arg_no; STR " "; - jvar_info#toPretty; NL; dom#toPretty; NL]) ; - + jvar_info#toPretty; NL; dom#toPretty; NL]) ; + let arg_jterm = JLocalVar arg_no in match jvar_info#get_constant with | Some n -> ([(arg_jterm, JConstant n)], [(arg_jterm, JConstant n)]) | _ -> begin let poly_int_array = JCHPolyIntDomainNoArrays.get_poly_int_array dom in - + (if !dbg then pr__debug [ STR "var not a constant, poly_int_array = "; NL; - poly_int_array#toPretty; NL]) ; + poly_int_array#toPretty; NL]); try match (poly_int_array#get_interval var)#singleton with | Some n -> @@ -706,50 +711,51 @@ let get_bounds_var let poly_op_semantics ~(invariant:atlas_t) - ~(stable: bool) + ~(stable: bool) ~(fwd_direction:bool) ~context ~operation = - + (if !dbg then pr__debug [STR "poly_op_semantics "; - command_to_pretty 0 (OPERATION operation); NL]) ; + command_to_pretty 0 (OPERATION operation); NL]); - let set_write_vars_to_top (invariant:atlas_t) = + let set_write_vars_to_top (invariant:atlas_t) = let write_vars = JCHSystemUtils.get_write_vars operation.op_args in invariant#analyzeFwd (ABSTRACT_VARS write_vars) in - - let mk_dom_op operation = + + let mk_dom_op operation = DOMAIN_OPERATION - ([poly_dom_name], - { op_name = operation.op_name ; op_args = operation.op_args }) in + ([poly_dom_name], + { op_name = operation.op_name; op_args = operation.op_args }) in let pc = operation.op_name#getSeqNumber in match operation.op_name#getBaseName with - | "init_params" - | "init_assumptions" + | "init_params" + | "init_assumptions" | "op_get_array_field" - | "op_put_array_field" -> - if fwd_direction then - invariant#analyzeFwd (mk_dom_op operation) + | "op_put_array_field" -> + if fwd_direction then + invariant#analyzeFwd (mk_dom_op operation) else invariant - | "exit_loop" -> + | "exit_loop" -> if fwd_direction && stable then begin - + (if !dbg then - pr__debug [STR "exit_loop stable"; NL]) ; - + pr__debug [STR "exit_loop stable"; NL]); + let wto_var = JCHSystemUtils.get_arg_var "loop_counter" operation.op_args in let jproc_info = JCHAnalysisUtils.get_current_jproc_info () in let cmsix = (JCHAnalysisUtils.get_current_proc_name ())#getSeqNumber in let wto_info = - List.find (fun w -> w#get_var#equal wto_var) jproc_info#get_wto_infos in + List.find + (fun w -> w#get_var#equal wto_var) jproc_info#get_wto_infos in let pc = wto_info#get_entry_pc in let pia = invariant#getDomain poly_dom_name in begin - add_exit_loop cmsix pc pia ; + add_exit_loop cmsix pc pia; invariant end end @@ -757,119 +763,119 @@ let poly_op_semantics let op = {op_name = remove_vars_sym; op_args = operation.op_args} in invariant#analyzeFwd (mk_dom_op op) | "v" -> - if fwd_direction && stable then - begin - let new_dom = + if fwd_direction && stable then + begin + let new_dom = let dom = invariant#getDomain poly_dom_name in - match !old_numeric_invs#get pc with - | Some old_dom -> + match !old_numeric_invs#get pc with + | Some old_dom -> dom#meet old_dom - | _ -> + | _ -> dom in !numeric_invs#set pc new_dom; if not invariant#isBottom - && JCHAnalysisUtils.numeric_params#use_types then + && JCHAnalysisUtils.numeric_params#use_types then begin let proc_name = JCHAnalysisUtils.get_current_proc_name () in let jproc_info = JCHAnalysisUtils.get_current_jproc_info () in - change_stack_layout proc_name jproc_info invariant pc - end ; - invariant - end - else - invariant + change_stack_layout proc_name jproc_info invariant pc + end; + invariant + end + else + invariant | "i" - | "ii" -> - begin + | "ii" -> + begin let proc_name = JCHAnalysisUtils.get_current_proc_name () in let jproc_info = JCHAnalysisUtils.get_current_jproc_info () in let bcloc = get_bytecode_location proc_name#getSeqNumber pc in let iInfo = app#get_instruction bcloc in - JCHPolyIntDomainNoArrays.set_instr_pc pc ; - + JCHPolyIntDomainNoArrays.set_instr_pc pc; + (if stable && not invariant#isBottom - && JCHAnalysisUtils.numeric_params#use_types then + && JCHAnalysisUtils.numeric_params#use_types then let wvars = JCHSystemUtils.get_write_vars operation.op_args in - List.iter JCHPolyIntDomainNoArrays.add_reachable wvars) ; - + List.iter JCHPolyIntDomainNoArrays.add_reachable wvars); + match iInfo#get_opcode with - | OpPutStatic _ - | OpPutField _ -> - if fwd_direction && not invariant#isBottom then + | OpPutStatic _ + | OpPutField _ -> + if fwd_direction && not invariant#isBottom then begin let var = JCHSystemUtils.get_arg_var "val" operation.op_args in - if JCHAnalysisUtils.is_numeric jproc_info var then + if JCHAnalysisUtils.is_numeric jproc_info var then begin let constr_int_array = JCHPolyIntDomainNoArrays.get_poly_int_array (invariant#getDomain poly_dom_name) in let fInfo = iInfo#get_field_target in let interval = constr_int_array#get_interval var in - let length_interval = + let length_interval = let jvar_info = jproc_info#get_jvar_info var in - if jvar_info#has_length then + if jvar_info#has_length then let length = Option.get (jproc_info#get_length var) in [constr_int_array#get_interval length] else [] in JCHFields.int_field_manager#put_field - proc_name fInfo interval length_interval true var ; + proc_name fInfo interval length_interval true var; (* CHANGE : bring back info about the length *) - if JCHAnalysisUtils.is_collection_or_array jproc_info var then - JCHPolyIntDomainNoArrays.add_variable_to_field var iInfo ; + if JCHAnalysisUtils.is_collection_or_array jproc_info var then + JCHPolyIntDomainNoArrays.add_variable_to_field var iInfo; end - end ; + end; if fwd_direction then invariant#analyzeFwd (mk_dom_op operation) - else + else JCHAnalysisUtils.jch_op_semantics ~invariant ~stable ~fwd_direction ~context ~operation | OpArrayLoad _ - | OpArrayStore _ - | OpNewArray _ + | OpArrayStore _ + | OpNewArray _ | OpCheckCast _ | OpDiv Float - | OpDiv Double - | OpRem _ + | OpDiv Double + | OpRem _ | OpGetStatic _ - | OpGetField _ + | OpGetField _ | OpAMultiNewArray _ - | OpArrayLength + | OpArrayLength | OpI2L | OpI2F | OpI2D | OpL2F | OpL2D - | OpF2D + | OpF2D | OpL2I | OpF2I | OpF2L - | OpD2I + | OpD2I | OpD2L - | OpD2F + | OpD2F | OpI2B | OpI2C - | OpI2S - | OpNew _ - | OpFloatConst _ + | OpI2S + | OpNew _ + | OpFloatConst _ | OpDoubleConst _ | OpAdd Float - | OpAdd Double + | OpAdd Double | OpSub Float - | OpSub Double + | OpSub Double | OpMult Float - | OpMult Double - | OpIAnd + | OpMult Double + | OpIAnd | OpLAnd | OpIOr | OpLOr | OpStore _ - -> - if fwd_direction then + -> + if fwd_direction then invariant#analyzeFwd (mk_dom_op operation) - else - set_write_vars_to_top invariant + else + set_write_vars_to_top invariant | OpDiv _ -> (* This is analyzed by DIV *) invariant | OpInvokeStatic _ @@ -878,96 +884,96 @@ let poly_op_semantics | OpInvokeVirtual _ -> if not JCHAnalysisUtils.numeric_params#create_model && stable then begin - + (if !dbg then pr__debug [proc_name#toPretty; STR " "; INT pc; STR " is method call"; NL; command_to_pretty 0 (OPERATION operation); NL; iInfo#toPretty; NL]); - + let dom = Option.get (!numeric_invs#get pc) in - + (if !dbg then pr__debug [dom#toPretty; NL]); - - let func (s,v,m) = + + let func (s, v, _m) = let cmsix = proc_name#getSeqNumber in let arg_no = int_of_string (Str.string_after s 3) in let (lbs, ubs) = get_bounds_var jproc_info cmsix arg_no (jproc_info#get_jvar_info v) dom v in - + (if !dbg then pr__debug [STR "after get_bounds_var for arg "; - INT arg_no; NL ]); - + INT arg_no; NL]); + (if !dbg then pr__debug [STR "lbs = "; pretty_print_list (List.map snd lbs) - JCHJTerm.jterm_to_pretty "[" ", " "]"; NL]) ; - + JCHJTerm.jterm_to_pretty "[" ", " "]"; NL]); + (if !dbg then pr__debug [STR "ubs = "; pretty_print_list (List.map snd ubs) - JCHJTerm.jterm_to_pretty "[" ", " "]"; NL]) ; - - List.iter (add_method_arg_bounds true cmsix pc) lbs ; + JCHJTerm.jterm_to_pretty "[" ", " "]"; NL]); + + List.iter (add_method_arg_bounds true cmsix pc) lbs; List.iter (add_method_arg_bounds false cmsix pc) ubs in List.iter func - (List.filter (fun (_, _, m) -> m = READ) operation.op_args) - end ; - if fwd_direction then + (List.filter (fun (_, _, m) -> m = READ) operation.op_args) + end; + if fwd_direction then invariant#analyzeFwd (mk_dom_op operation) - else - set_write_vars_to_top invariant - | _ -> + else + set_write_vars_to_top invariant + | _ -> JCHAnalysisUtils.jch_op_semantics ~invariant ~stable ~fwd_direction ~context ~operation - end + end | _ -> begin - (if fwd_direction && stable && not invariant#isBottom then + (if fwd_direction && stable && not invariant#isBottom then let wvars = JCHSystemUtils.get_write_vars operation.op_args in - List.iter JCHPolyIntDomainNoArrays.add_reachable wvars + List.iter JCHPolyIntDomainNoArrays.add_reachable wvars else - ()) ; + ()); JCHAnalysisUtils.jch_op_semantics ~invariant ~stable ~fwd_direction ~context ~operation end let reset_refs (first:bool) wto_pc_to_poly_int_array = - + (if !dbg then - pr__debug [STR "reset_refs"; NL]) ; - + pr__debug [STR "reset_refs"; NL]); + old_numeric_invs := - if first then new IntCollections.table_t else !numeric_invs ; - if first then JCHPolyIntDomainNoArrays.set_invs wto_pc_to_poly_int_array ; - numeric_invs := new IntCollections.table_t ; - max_loop_iterations := (H.create 3) + if first then new IntCollections.table_t else !numeric_invs; + if first then JCHPolyIntDomainNoArrays.set_invs wto_pc_to_poly_int_array; + numeric_invs := new IntCollections.table_t; + max_loop_iterations := (H.create 3) -let get_num_invs () = !numeric_invs +let _get_num_invs () = !numeric_invs let record_stub jproc_info procedure exit_dom = - + (if !dbg then - pr__debug [STR "record_stub "; NL; exit_dom#toPretty; NL]) ; - + pr__debug [STR "record_stub "; NL; exit_dom#toPretty; NL]); + let vars = JCHAnalysisUtils.include_length_vars jproc_info (JCHSystemUtils.get_signature_vars procedure) in let restr_dom = JCHPolyIntDomainNoArrays.restrict_to_vars exit_dom vars in - + (if !dbg then - pr__debug [STR "restr_dom = "; NL; restr_dom#toPretty; NL]) ; - + pr__debug [STR "restr_dom = "; NL; restr_dom#toPretty; NL]); + let pia = JCHPolyIntDomainNoArrays.get_poly_int_array restr_dom in let poly = pia#get_poly in - let restr_poly_int_array = + let restr_poly_int_array = if poly#is_top || poly#is_bottom then pia else @@ -978,132 +984,135 @@ let record_stub jproc_info procedure exit_dom = pia#get_extra_infos#add_changed_sym_params changed_sym_params in let changed_poly_int_array = restr_poly_int_array#set_extra_infos changed_extra_infos in - + (if !dbg then pr__debug [STR "changed_poly_int_array = "; - changed_poly_int_array#toPretty; NL]) ; - + changed_poly_int_array#toPretty; NL]); + JCHIntStubs.int_stub_manager#mk_poly_int_array_stub - procedure changed_poly_int_array ; - restr_poly_int_array#to_postconditions2 jproc_info + procedure changed_poly_int_array; + restr_poly_int_array#to_postconditions2 jproc_info -let get_interval dom lvar = - JCHPolyIntDomainNoArrays.get_interval dom lvar +let _get_interval dom lvar = + JCHPolyIntDomainNoArrays.get_interval dom lvar -(* It augments int_array with the numeric variables of proc that are not +(* It augments int_array with the numeric variables of proc that are not * in num_params *) -let add_all_vars jproc_info int_array num_params = +let add_all_vars jproc_info int_array num_params = let vars = - List.filter (JCHAnalysisUtils.is_numeric jproc_info) jproc_info#get_variables in + List.filter + (JCHAnalysisUtils.is_numeric jproc_info) jproc_info#get_variables in let param_inds = List.map (fun v -> v#getIndex) num_params in - let is_other_var var = - JCHAnalysisUtils.is_numeric jproc_info var && not (List.mem var#getIndex param_inds) in + let is_other_var var = + JCHAnalysisUtils.is_numeric + jproc_info var && not (List.mem var#getIndex param_inds) in let other_vars = List.filter is_other_var vars in - int_array#add_vars jproc_info other_vars + int_array#add_vars jproc_info other_vars -(* This accumulates methods not analyzed over all the passes. Methods that - * are not analyzed in the first pass, will not be analyzed in the second +(* This accumulates methods not analyzed over all the passes. Methods that + * are not analyzed in the first pass, will not be analyzed in the second * pass wither *) -let not_analyzed = new SymbolCollections.set_t +let not_analyzed = new SymbolCollections.set_t let analyzed_with_intervals = ref (new SymbolCollections.set_t) -let method_time_count = Array.make 21 0 +let method_time_count = Array.make 21 0 let reset_analysis_counts () = begin analyzed_with_intervals := new SymbolCollections.set_t; - for i = 0 to 20 do + for i = 0 to 20 do method_time_count.(i) <- 0 done end let print_method_time_count () = begin - for i = 0 to 19 do + for i = 0 to 19 do pr__debug [STR "["; INT (5 * i); STR ", "; INT (5 * (i + 1)); STR ") seconds : "; - INT (method_time_count.(i)); NL] - done ; - pr__debug [STR "[100, +oo) seconds : "; INT (method_time_count.(20)); NL] ; + INT (method_time_count.(i)); NL] + done; + pr__debug [STR "[100, +oo) seconds : "; INT (method_time_count.(20)); NL]; pr__debug [STR "Methods analyzed only with intervals: "; INT (!analyzed_with_intervals#size); - STR " "; !analyzed_with_intervals#toPretty; NL] ; + STR " "; !analyzed_with_intervals#toPretty; NL]; pr__debug [STR "Methods not analyzed: "; INT not_analyzed#size; STR " "; - not_analyzed#toPretty; NL] + not_analyzed#toPretty; NL] end - -let rec analyze_proc proc_name jproc_info procedure num_params init_dom = - let analyzer = mk_analysis_setup () in + +let rec analyze_proc proc_name jproc_info procedure num_params init_dom = + let analyzer = mk_analysis_setup () in analyzer#setOpSemantics poly_op_semantics; - analyzer#setStrategy + analyzer#setStrategy { CHIterator.widening = (fun i -> i >= JCHAnalysisUtils.numeric_params#number_joins, ""); - CHIterator.narrowing = (fun i -> i >= 2) } ; - + CHIterator.narrowing = (fun i -> i >= 2) }; + let count_numeric_vars = jproc_info#get_count_numeric_vars in let count_number_vars = jproc_info#get_count_number_vars in let loop_depth = jproc_info#get_loop_depth in let loop_number = jproc_info#get_loop_number in - + pr__debug [STR " "; proc_name#toPretty; STR " all vars analyzed: "; INT count_numeric_vars; STR "; vars of numeric types: "; - INT count_number_vars; + INT count_number_vars; (if count_numeric_vars > 50000 then STR " ** very many variables **" else - STR "") ; + STR ""); STR "; number of loops: "; INT loop_number; - STR "; loop depth: "; INT loop_depth; NL] ; - - analyzer#addDomain poly_dom_name init_dom ; + STR "; loop depth: "; INT loop_depth; NL]; + + analyzer#addDomain poly_dom_name init_dom; if count_number_vars > 500 then JCHAnalysisUtils.numeric_params#set_use_intervals true; (* make it into a parameter *) - JCHAnalysisUtils.numeric_params#start_numeric_analysis_time ; - try + JCHAnalysisUtils.numeric_params#start_numeric_analysis_time; + try analyzer#analyze_procedure - ~do_loop_counters:false JCHSystem.jsystem#get_transformed_chif procedure ; - - pr__debug [STR " number of constraints: " ; - INT JCHAnalysisUtils.numeric_params#max_number_constraints; NL] ; + ~do_loop_counters:false JCHSystem.jsystem#get_transformed_chif procedure; + + pr__debug [STR " number of constraints: "; + INT JCHAnalysisUtils.numeric_params#max_number_constraints; NL]; (match (JCHAnalysisUtils.get_exit_invariant ()) with - | Some invariant -> - let dom = invariant#getDomain poly_dom_name in - if JCHAnalysisUtils.numeric_params#use_intervals then + | Some invariant -> + let dom = invariant#getDomain poly_dom_name in + if JCHAnalysisUtils.numeric_params#use_intervals then begin - pr__debug [STR "intervals used "; NL] ; - !analyzed_with_intervals#add proc_name - end ; - (dom, true) - | None -> (JCHPolyIntDomainNoArrays.bottom_poly_int_dom jproc_info, true)) ; - with _ -> + pr__debug [STR "intervals used "; NL]; + !analyzed_with_intervals#add proc_name + end; + (dom, true) + | None -> (JCHPolyIntDomainNoArrays.bottom_poly_int_dom jproc_info, true)); + with _ -> let n = JCHAnalysisUtils.numeric_params#get_analysis_status in - if n <= 2 then + if n <= 2 then begin - JCHAnalysisUtils.numeric_params#reset_analysis_failure_status ; + JCHAnalysisUtils.numeric_params#reset_analysis_failure_status; if n = 2 then JCHAnalysisUtils.numeric_params#set_use_intervals true; - + pr__debug [STR "found error <= 2, reanalyzing with intervals"; proc_name#toPretty; NL]; - + analyze_proc proc_name jproc_info procedure num_params init_dom; end - else + else begin - let message = + let message = if JCHAnalysisUtils.numeric_params#get_analysis_status < 10 then - (JCHAnalysisUtils.numeric_params#get_analysis_failure_reason ^ " - abandoned") + (JCHAnalysisUtils.numeric_params#get_analysis_failure_reason + ^ " - abandoned") else " out of time - abandoned" in pr__debug [STR " number of constraints: "; - INT JCHAnalysisUtils.numeric_params#max_number_constraints; NL] ; - pr__debug [INT n; STR message; NL] ; + INT JCHAnalysisUtils.numeric_params#max_number_constraints; NL]; + pr__debug [INT n; STR message; NL]; (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info num_params, false) end (* Returns an initial poly_interval_array infered from the calls to the - * method or/ and types - * in case of main or of if a library is analyzed and the method is + * method or/ and types + * in case of main or of if a library is analyzed and the method is * not private *) let make_init_poly proc_name @@ -1114,14 +1123,14 @@ let make_init_poly method_info use_widening use_narrowing - reset_use_intervals = - + _reset_use_intervals = + (if !dbg then - pr__debug [NL; STR "make_init_poly "; proc_name_pp proc_name ; - STR (if known_calls then " known calls" else " unknown calls") ; - NL; pp_list poly_params; NL]) ; - - let start_with_unknown_params = + pr__debug [NL; STR "make_init_poly "; proc_name_pp proc_name; + STR (if known_calls then " known calls" else " unknown calls"); + NL; pp_list poly_params; NL]); + + let start_with_unknown_params = method_info#is_main_method || method_info#is_dynamically_dispatched || method_info#is_called_by_reflection @@ -1129,64 +1138,67 @@ let make_init_poly let var_to_index = JCHNumericUtils.mk_var_to_index poly_params in - let make_type_interval_array () = + let make_type_interval_array () = JCHIntervalArray.make_from_types jproc_info poly_params in - let (init_poly, init_interval_array, init_extra_infos) = + let (init_poly, init_interval_array, init_extra_infos) = if start_with_unknown_params then (JCHPoly.top_poly, make_type_interval_array (), - new JCHNumericInfo.numeric_info_t) - else - begin - let call_poly_interval_array_opt = + new JCHNumericInfo.numeric_info_t) + else + begin + let call_poly_interval_array_opt = if use_narrowing then JCHIntStubs.int_stub_manager#get_narrowing_call_poly_int_array - proc_name known_calls + proc_name known_calls else JCHIntStubs.int_stub_manager#get_widening_call_poly_int_array use_widening proc_name known_calls in - + match call_poly_interval_array_opt with - | Some call_poly_interval_array -> - JCHIntStubs.int_stub_manager#reset_recursive_calls proc_name ; + | Some call_poly_interval_array -> + JCHIntStubs.int_stub_manager#reset_recursive_calls proc_name; let call_poly = call_poly_interval_array#get_poly in - let call_interval_array = call_poly_interval_array#get_interval_array in + let call_interval_array = + call_poly_interval_array#get_interval_array in let call_extra_infos = call_poly_interval_array#get_extra_infos in - let inds_to_remove = + let inds_to_remove = let inds = ref [] in - let rec add_ind vars ind = - match vars with - | v :: rest_vars -> - if not (JCHAnalysisUtils.is_numeric jproc_info v) then inds := ind :: !inds ; - add_ind rest_vars (succ ind) + let rec add_ind vars ind = + match vars with + | v :: rest_vars -> + if not (JCHAnalysisUtils.is_numeric jproc_info v) then + inds := ind :: !inds; + add_ind rest_vars (succ ind) | _ -> () in - add_ind sig_read_vars 0 ; + add_ind sig_read_vars 0; !inds in let red_poly = call_poly#project_out_and_remove inds_to_remove in - let red_interval_array = + let red_interval_array = let call_poly_vars = call_poly_interval_array#get_poly_vars in - let call_lengths = List.filter JCHSystemUtils.is_length call_poly_vars in + let call_lengths = + List.filter JCHSystemUtils.is_length call_poly_vars in let dim = (List.length sig_read_vars) + (List.length call_lengths) in call_interval_array#remove_entries dim inds_to_remove in - let add_type v = + let add_type v = let index = List.assoc v#getIndex var_to_index in let var_info = jproc_info#get_jvar_info v in let tp = var_info#get_basic_num_type in let interval = JCHTypeUtils.get_var_interval_from_type v tp in let new_interval = (red_interval_array#get index)#meet interval in red_interval_array#set index new_interval in - List.iter add_type poly_params ; + List.iter add_type poly_params; (red_poly, red_interval_array#set_type_intervals jproc_info poly_params, - call_extra_infos) + call_extra_infos) | None -> (JCHPoly.top_poly, make_type_interval_array (), - new JCHNumericInfo.numeric_info_t) + new JCHNumericInfo.numeric_info_t) end in let var_to_const = JCHNumericUtils.get_constants jproc_info in let top_poly_int_array = JCHPolyIntervalArray.top_poly_interval_array var_to_const poly_params in - let poly_int_array = top_poly_int_array#set_extra_infos init_extra_infos in + let poly_int_array = top_poly_int_array#set_extra_infos init_extra_infos in (poly_int_array#set_poly init_poly)#set_interval_array init_interval_array @@ -1201,8 +1213,8 @@ let run_poly_analysis use_widening use_narrowing reset_old_join_widening - reset_use_intervals = - let init_poly_int_array = + reset_use_intervals = + let init_poly_int_array = let pia = make_init_poly proc_name @@ -1223,13 +1235,13 @@ let run_poly_analysis reset_old_join_widening reset_use_intervals in - if not_analyzed#has proc_name then - begin - pr__debug [STR "skipped"; NL] ; + if not_analyzed#has proc_name then + begin + pr__debug [STR "skipped"; NL]; (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info poly_vars, false) end else - analyze_proc proc_name jproc_info procedure poly_vars init_poly_dom + analyze_proc proc_name jproc_info procedure poly_vars init_poly_dom @@ -1237,28 +1249,28 @@ let run_analysis proc_name jproc_info procedure - method_info + _method_info known_calls first = - let sig_read_vars = JCHSystemUtils.get_signature_read_vars procedure in + let sig_read_vars = JCHSystemUtils.get_signature_read_vars procedure in let poly_params = - List.filter (JCHAnalysisUtils.is_numeric jproc_info) sig_read_vars in - let mInfo = jproc_info#get_method_info in + List.filter (JCHAnalysisUtils.is_numeric jproc_info) sig_read_vars in + let mInfo = jproc_info#get_method_info in - let poly_vars = - let length_vars = ref [] in - let add_var v = - try + let poly_vars = + let length_vars = ref [] in + let add_var v = + try let length = Option.get (jproc_info#get_length v) in - length_vars := length :: !length_vars + length_vars := length :: !length_vars with _ -> () in - List.iter add_var poly_params ; + List.iter add_var poly_params; poly_params @ !length_vars in - if JCHSystem.jsystem#get_call_graph_manager#is_recursive proc_name then + if JCHSystem.jsystem#get_call_graph_manager#is_recursive proc_name then begin (* Running with the external calls *) - pr__debug [STR "running with the external calls"; NL] ; + pr__debug [STR "running with the external calls"; NL]; let analyzed = ref (snd @@ -1277,9 +1289,10 @@ let run_analysis if !analyzed then begin (* Running with the external and internal calls generated *) - - pr__debug [STR "running with the external and interval calls generated"; NL] ; - + + pr__debug [ + STR "running with the external and interval calls generated"; NL]; + let res = ref (run_poly_analysis @@ -1294,15 +1307,15 @@ let run_analysis false first false) in - analyzed := snd !res ; + analyzed := snd !res; if !analyzed then begin let count = ref 2 in while !analyzed && not (JCHIntStubs.int_stub_manager#are_recursive_calls_included_in_calls proc_name) do - - pr__debug [STR "recursive calls are not included in calls"; NL] ; - + + pr__debug [STR "recursive calls are not included in calls"; NL]; + if !count < 5 then begin res := @@ -1317,14 +1330,14 @@ let run_analysis true false false - false ; (* widen *) - analyzed := snd !res + false; (* widen *) + analyzed := snd !res end else begin - - pr__debug [STR "recursive calls are included in calls -> widen"; NL] ; - + + pr__debug [STR "recursive calls are included in calls -> widen"; NL]; + analyzed := snd (run_poly_analysis @@ -1342,9 +1355,9 @@ let run_analysis if !analyzed then begin incr count; - - pr__debug [STR "narrow"; NL] ; - + + pr__debug [STR "narrow"; NL]; + res := run_poly_analysis proc_name @@ -1357,16 +1370,17 @@ let run_analysis false true false - false ; (* narrow *) - analyzed := snd !res ; + false; (* narrow *) + analyzed := snd !res; end - end ; + end; incr count - done ; + done; if !analyzed then !res else - (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info poly_vars, false) + (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info poly_vars, + false) end else (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info poly_vars, false) @@ -1374,7 +1388,7 @@ let run_analysis else (JCHPolyIntDomainNoArrays.top_poly_int_dom jproc_info poly_vars, false) end - else + else run_poly_analysis proc_name jproc_info @@ -1388,43 +1402,43 @@ let run_analysis first true -(* Finds poly invariants. If known_calls then it will use the call poly - * found in the current analysis of the system. Otherwise it will use the +(* Finds poly invariants. If known_calls then it will use the call poly + * found in the current analysis of the system. Otherwise it will use the * one found in the previousyes iteration *) let make_numeric_analysis_proc proc_name jproc_info procedure known_calls first = - - pr__debug [STR " "; proc_name_pp proc_name; NL] ; - - JCHPolyIntDomainNoArrays.dbg := !dbg ; - - let mInfo = jproc_info#get_method_info in - JCHSystemUtils.start_time () ; - + + pr__debug [STR " "; proc_name_pp proc_name; NL]; + + JCHPolyIntDomainNoArrays.dbg := !dbg; + + let mInfo = jproc_info#get_method_info in + JCHSystemUtils.start_time (); + let (exit_dom, analyzed) = run_analysis proc_name jproc_info procedure mInfo known_calls first in let time = JCHSystemUtils.get_time () in - - pr__debug [STR (string_of_float time); STR " seconds"; NL] ; - + + pr__debug [STR (string_of_float time); STR " seconds"; NL]; + let fives = int_of_float (time /. 5.) in (if fives > 19 then - method_time_count.(20) <- method_time_count.(20) + 1 + method_time_count.(20) <- method_time_count.(20) + 1 else - method_time_count.(fives) <- method_time_count.(fives) + 1) ; + method_time_count.(fives) <- method_time_count.(fives) + 1); let _ = record_stub jproc_info procedure exit_dom in analyzed -let total_loop_count = ref 0 -let infinite_loop_count = ref 0 -let get_total_loop_count () = !total_loop_count -let get_infinite_loop_count () = !infinite_loop_count +let total_loop_count = ref 0 +let infinite_loop_count = ref 0 +let _get_total_loop_count () = !total_loop_count +let _get_infinite_loop_count () = !infinite_loop_count -let reset_loop_counts () = - total_loop_count := 0; - infinite_loop_count := 0 +let reset_loop_counts () = + total_loop_count := 0; + infinite_loop_count := 0 -(* taint analysis support *) +(* taint analysis support *) let unreachable_vars = ref (H.create 0) let is_unreachable (proc_name: symbol_t) (var: variable_t) = @@ -1432,109 +1446,122 @@ let is_unreachable (proc_name: symbol_t) (var: variable_t) = let set = H.find !unreachable_vars proc_name#getSeqNumber in set#has var#getIndex with _ -> false -(* end *) +(* end *) let record_analyzed - jproc_info + _jproc_info proc proc_name - (in_bounds, out_of_bounds, no_info, over, under, truncations, reach, div0) = + (_in_bounds, + _out_of_bounds, + _no_info, + _over, + _under, + _truncations, + reach, + _div0) = let all_vars = proc#getScope#getVariables in let unreach = List.filter (fun v -> not ((reach#has v) - (* we do not analyze exceptions well *) - || JCHSystemUtils.is_exception v)) all_vars in - let unreach = IntCollections.set_of_list (List.map (fun v -> v#getIndex) unreach) in - H.replace !unreachable_vars proc_name#getSeqNumber unreach + (* we do not analyze exceptions well *) + || JCHSystemUtils.is_exception v)) all_vars in + let unreach = + IntCollections.set_of_list (List.map (fun v -> v#getIndex) unreach) in + H.replace !unreachable_vars proc_name#getSeqNumber unreach + let set_invariants_and_loop_info jproc_info wtos = - + (if !dbg then pr__debug [STR "set_invariants "; jproc_info#get_name#toPretty; NL; - pp_list_int (List.map fst wtos); NL ]); - + pp_list_int (List.map fst wtos); NL]); + let analysis_results = jproc_info#get_analysis_results in let set_loop_info (pc: int) dom = - + (if !dbg then - pr__debug [STR "set_loop_info "; INT pc; NL]) ; - + pr__debug [STR "set_loop_info "; INT pc; NL]); + try let (_, wto_info) = List.find (fun (entry, _) -> entry = pc) wtos in - + (if !dbg then - pr__debug [ STR "set_max_iterations for "; jproc_info#get_name#toPretty; - STR " "; INT pc; NL; dom#toPretty; NL]) ; - + pr__debug [STR "set_max_iterations for "; jproc_info#get_name#toPretty; + STR " "; INT pc; NL; dom#toPretty; NL]); + let rel_exprs = JCHPolyIntDomainNoArrays.get_relational_exprs true dom in - + (if !dbg then pr__debug [STR "rel_exprs "; pretty_print_list rel_exprs JCHJTerm.relational_expr_to_pretty "[" "; " "]"; NL]); - - incr total_loop_count ; + + incr total_loop_count; let (lbounds, ubounds) = JCHNumericUtils.get_loop_counter_bounds rel_exprs wto_info#get_first_pc in - + (if !dbg then pr__debug [STR "add_iteration lbounds = "; INT pc; STR " "; pretty_print_list lbounds JCHJTerm.jterm_to_pretty "[" "; " "]"; NL]); - + (if !dbg then pr__debug [STR "add_iteration ubounds = "; INT pc; STR " "; pretty_print_list ubounds JCHJTerm.jterm_to_pretty "[" "; " "]"; NL]); - - wto_info#set_max_iterations ubounds ; - + + wto_info#set_max_iterations ubounds; + (* cost analysis support *) if not JCHAnalysisUtils.numeric_params#create_model then begin let vars = wto_info#get_var :: (JCHAnalysisUtils.include_length_vars - jproc_info (JCHSystemUtils.get_signature_vars jproc_info#get_procedure)) in + jproc_info (JCHSystemUtils.get_signature_vars + jproc_info#get_procedure)) in match get_exit_loop jproc_info#get_name#getSeqNumber pc with | Some dom -> begin let interval = - (JCHPolyIntDomainNoArrays.get_poly_int_array dom)#get_interval wto_info#get_var in + (JCHPolyIntDomainNoArrays.get_poly_int_array dom)#get_interval + wto_info#get_var in match interval#singleton with | Some n -> let bounds = [JConstant n] in - add_iteration_bounds jproc_info pc true bounds ; + add_iteration_bounds jproc_info pc true bounds; add_iteration_bounds jproc_info pc false bounds; | _ -> let rel_exprs = - JCHPolyIntDomainNoArrays.get_relational_exprs_vars_fields dom vars in - + JCHPolyIntDomainNoArrays.get_relational_exprs_vars_fields + dom vars in + (if !dbg then pr__debug [STR "rel_exprs "; pretty_print_list rel_exprs JCHJTerm.relational_expr_to_pretty "[" "; " "]"; NL]); - + let (lbounds, ubounds) = - JCHNumericUtils.get_loop_counter_bounds rel_exprs wto_info#get_first_pc in - add_iteration_bounds jproc_info pc true lbounds ; - add_iteration_bounds jproc_info pc false ubounds ; + JCHNumericUtils.get_loop_counter_bounds + rel_exprs wto_info#get_first_pc in + add_iteration_bounds jproc_info pc true lbounds; + add_iteration_bounds jproc_info pc false ubounds; end | _ -> () (* no exit conditions *) end - with _ -> () in + with _ -> () in (* end cost_analysis support *) - + let set_pc pc dom = let dom = JCHPolyIntDomainNoArrays.remove_duplicates dom in let rel_exprs = JCHPolyIntDomainNoArrays.get_relational_exprs false dom in set_loop_info pc dom; - analysis_results#set_invariants pc rel_exprs ; + analysis_results#set_invariants pc rel_exprs; if not JCHAnalysisUtils.numeric_params#create_model then begin let vars = @@ -1542,73 +1569,87 @@ let set_invariants_and_loop_info jproc_info wtos = jproc_info (JCHSystemUtils.get_signature_vars jproc_info#get_procedure)) in let restr_dom = JCHPolyIntDomainNoArrays.restrict_to_vars dom vars in - let rel_exprs = JCHPolyIntDomainNoArrays.get_relational_exprs true restr_dom in + let rel_exprs = + JCHPolyIntDomainNoArrays.get_relational_exprs true restr_dom in let geqs = ref [] in let get_jterms rel_expr = match rel_expr with | (JGreaterEqual, jterm1, jterm2) -> - geqs := (JArithmeticExpr (JPlus, jterm1, JCHNumericUtils.negate_jterm jterm2)) :: !geqs + geqs := + (JArithmeticExpr (JPlus, + jterm1, + JCHNumericUtils.negate_jterm jterm2)) :: !geqs | (JLessEqual, jterm1, jterm2) -> - geqs := (JArithmeticExpr (JPlus, jterm2, JCHNumericUtils.negate_jterm jterm1)) :: !geqs + geqs := + (JArithmeticExpr (JPlus, + jterm2, + JCHNumericUtils.negate_jterm jterm1)) :: !geqs | (JEquals, jterm1, jterm2) -> - geqs := (JArithmeticExpr (JPlus, jterm1, JCHNumericUtils.negate_jterm jterm2)) :: !geqs ; - geqs := (JArithmeticExpr (JPlus, jterm2, JCHNumericUtils.negate_jterm jterm1)) :: !geqs + geqs := + (JArithmeticExpr (JPlus, + jterm1, + JCHNumericUtils.negate_jterm jterm2)) :: !geqs; + geqs := + (JArithmeticExpr (JPlus, + jterm2, + JCHNumericUtils.negate_jterm jterm1)) :: !geqs | _ -> () in - List.iter get_jterms rel_exprs ; + List.iter get_jterms rel_exprs; add_pos_terms jproc_info pc (JTermCollections.set_of_list !geqs) end in - !numeric_invs#iter set_pc - + !numeric_invs#iter set_pc + let make_numeric_analysis bottom_up = let system = JCHSystem.jsystem#get_transformed_chif in let call_graph_manager = JCHSystem.jsystem#get_call_graph_manager in - reset_analysis_counts () ; + reset_analysis_counts (); reset_loop_counts (); - let (procs, in_loop) = + let (procs, in_loop) = if bottom_up then - call_graph_manager#get_bottom_up_list + call_graph_manager#get_bottom_up_list else call_graph_manager#get_top_down_list in if bottom_up then begin - numeric_invariants := H.create JCHSystem.jsystem#get_number_procs ; - unreachable_vars := H.create JCHSystem.jsystem#get_number_procs - end ; + numeric_invariants := H.create JCHSystem.jsystem#get_number_procs; + unreachable_vars := H.create JCHSystem.jsystem#get_number_procs + end; List.iter (fun name -> - JCHIntStubs.int_stub_manager#mk_proc_call (system#getProcedure name)) procs ; + JCHIntStubs.int_stub_manager#mk_proc_call (system#getProcedure name)) procs; let number_method_analyzed = ref 0 in let get_p proc_name = let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let proc = system#getProcedure proc_name in - incr number_method_analyzed ; - let known_calls = - not (bottom_up || in_loop#has proc_name) in - JCHAnalysisUtils.set_current_proc_name proc_name ; + incr number_method_analyzed; + let known_calls = + not (bottom_up || in_loop#has proc_name) in + JCHAnalysisUtils.set_current_proc_name proc_name; let prev_pc_to_wto_pc = jproc_info#get_wto_prev_pc_to_entry_pcs in - JCHPolyIntDomainNoArrays.set_prev_pc_to_wto_pc prev_pc_to_wto_pc ; + JCHPolyIntDomainNoArrays.set_prev_pc_to_wto_pc prev_pc_to_wto_pc; let wto_pcs = List.sort_uniq compare (List.map snd prev_pc_to_wto_pc) in let mk_wto_pc_to_poly_int_array num_invs = let table = new IntCollections.table_t in - let add wto_pc = - match num_invs#get wto_pc with - | Some inv -> + let add wto_pc = + match num_invs#get wto_pc with + | Some inv -> let poly_int_array = JCHPolyIntDomainNoArrays.get_poly_int_array inv in - table#set wto_pc poly_int_array - | _ -> + table#set wto_pc poly_int_array + | _ -> begin - match get_numeric_invariants proc_name with - | Some old_num_invs -> + match get_numeric_invariants proc_name with + | Some old_num_invs -> begin - match old_num_invs#get wto_pc with - | Some inv -> - let poly_int_array = JCHPolyIntDomainNoArrays.get_poly_int_array inv in + match old_num_invs#get wto_pc with + | Some inv -> + let poly_int_array = + JCHPolyIntDomainNoArrays.get_poly_int_array inv in table#set wto_pc poly_int_array | _ -> () end | _ -> () end in - List.iter add wto_pcs ; + List.iter add wto_pcs; table in let analyze @@ -1621,72 +1662,75 @@ let make_numeric_analysis bottom_up = use_loop_counters use_lengths useoverflow - level = + level = let nr_joins = JCHAnalysisUtils.numeric_params#number_joins in let analysis_level = JCHAnalysisUtils.numeric_params#analysis_level in let use_overflow = JCHAnalysisUtils.numeric_params#use_overflow in - + pr__debug [NL; NL; STR "start analyze "; proc_name#toPretty; STR " "; pp_bool analyzed; STR " joins = "; INT joins; - STR " level = "; INT level; NL] ; - - if analyzed then + STR " level = "; INT level; NL]; + + if analyzed then begin - reset_refs first (mk_wto_pc_to_poly_int_array !numeric_invs) ; + reset_refs first (mk_wto_pc_to_poly_int_array !numeric_invs); JCHAnalysisUtils.numeric_params#set_number_joins joins; JCHAnalysisUtils.numeric_params#set_max_poly_coefficient max_coeff; - JCHAnalysisUtils.numeric_params#set_max_number_vars_in_constraint_allowed nr_vars; - JCHAnalysisUtils.numeric_params#set_max_number_constraints_allowed nr_constrs; + JCHAnalysisUtils.numeric_params#set_max_number_vars_in_constraint_allowed + nr_vars; + JCHAnalysisUtils.numeric_params#set_max_number_constraints_allowed + nr_constrs; JCHAnalysisUtils.numeric_params#set_use_loop_counters use_loop_counters; JCHAnalysisUtils.numeric_params#set_use_lengths use_lengths; JCHAnalysisUtils.numeric_params#set_use_overflow useoverflow; JCHAnalysisUtils.numeric_params#set_analysis_level level; let res = - make_numeric_analysis_proc proc_name jproc_info proc known_calls first in + make_numeric_analysis_proc + proc_name jproc_info proc known_calls first in if jproc_info#get_count_number_vars < 500 then begin - + (if !dbg then pr__debug [STR "after end analysis with nr_vars "; INT nr_vars; STR " "; pp_bool res; NL]); - + (if !dbg then pr__debug [STR " the invariants are: "; NL]); - + (if !dbg then pr__debug_large_table (fun dom -> let pia = JCHPolyIntDomainNoArrays.get_poly_int_array dom in pia#pr__debug_large_poly_interval_array) !numeric_invs); - + (if !dbg then pr__debug [NL]); - + end else - + (if !dbg then pr__debug [STR "after end analysis with large nr_vars "; INT nr_vars; STR " "; pp_bool res; NL]); - + let proc_results = JCHPolyIntDomainNoArrays.get_proc_info () in - record_analyzed jproc_info proc proc_name proc_results ; + record_analyzed jproc_info proc proc_name proc_results; JCHAnalysisUtils.numeric_params#set_number_joins nr_joins; JCHAnalysisUtils.numeric_params#set_analysis_level analysis_level; JCHAnalysisUtils.numeric_params#set_use_overflow use_overflow; res - end + end else false in - let analyzed = - if JCHAnalysisUtils.numeric_params#analysis_level = 0 then + let analyzed = + if JCHAnalysisUtils.numeric_params#analysis_level = 0 then begin - + (if !dbg then pr__debug [STR "analyze "; proc_name#toPretty; - STR " with analysis_level = 0"; NL]) ; - + STR " with analysis_level = 0"; NL]); + analyze true true @@ -1699,13 +1743,13 @@ let make_numeric_analysis bottom_up = true 0 end - else if List.length jproc_info#get_wto_infos = 0 then + else if List.length jproc_info#get_wto_infos = 0 then begin - + (if !dbg then pr__debug [STR "analyze "; proc_name#toPretty; - STR " with analysis_level > 0 and with no loops"; NL]) ; - + STR " with analysis_level > 0 and with no loops"; NL]); + analyze true true @@ -1714,17 +1758,17 @@ let make_numeric_analysis bottom_up = 4 20 true - true + true JCHAnalysisUtils.numeric_params#use_overflow JCHAnalysisUtils.numeric_params#analysis_level end - else if not JCHAnalysisUtils.numeric_params#use_overflow then + else if not JCHAnalysisUtils.numeric_params#use_overflow then begin - + (if !dbg then pr__debug [STR "analyze "; proc_name#toPretty; - STR " without overflow "; NL]) ; - + STR " without overflow "; NL]); + let res = analyze true @@ -1736,16 +1780,16 @@ let make_numeric_analysis bottom_up = true true false - JCHAnalysisUtils.numeric_params#analysis_level in - res + JCHAnalysisUtils.numeric_params#analysis_level in + res end - else if JCHAnalysisUtils.numeric_params#analysis_level > 1 then + else if JCHAnalysisUtils.numeric_params#analysis_level > 1 then begin - + (if !dbg then pr__debug [STR "analyze "; proc_name#toPretty; - STR " with analysis_level > 1 "; NL]) ; - + STR " with analysis_level > 1 "; NL]); + let res = analyze true @@ -1757,7 +1801,7 @@ let make_numeric_analysis bottom_up = true true true - 1 in + 1 in let res = analyze false @@ -1769,16 +1813,16 @@ let make_numeric_analysis bottom_up = true true true - JCHAnalysisUtils.numeric_params#analysis_level in + JCHAnalysisUtils.numeric_params#analysis_level in res end - else + else begin - + (if !dbg then pr__debug [STR "analyze "; proc_name#toPretty; - STR " with loops, overflow and analysis_level = 1 "; NL]) ; - + STR " with loops, overflow and analysis_level = 1 "; NL]); + let res = analyze true @@ -1790,7 +1834,7 @@ let make_numeric_analysis bottom_up = true true true - 1 in + 1 in let res = analyze false @@ -1802,37 +1846,37 @@ let make_numeric_analysis bottom_up = true true true - 1 in + 1 in res end in - if analyzed then + if analyzed then begin - H.replace !numeric_invariants proc_name#getSeqNumber !numeric_invs ; - if not bottom_up then + H.replace !numeric_invariants proc_name#getSeqNumber !numeric_invs; + if not bottom_up then let wto_infos = - List.map (fun wto -> (wto#get_entry_pc, wto)) jproc_info#get_wto_infos in + List.map (fun wto -> + (wto#get_entry_pc, wto)) jproc_info#get_wto_infos in begin - set_invariants_and_loop_info jproc_info wto_infos ; + set_invariants_and_loop_info jproc_info wto_infos; set_local_var_maps proc_name - end + end end - else + else begin - JCHFields.int_field_manager#set_unknown_fields jproc_info ; - not_analyzed#add proc_name ; + JCHFields.int_field_manager#set_unknown_fields jproc_info; + not_analyzed#add proc_name; end in - List.iter get_p procs ; - - pr__debug [ NL; NL; STR "Finished a numeric analysis pass of all methods "; NL; - STR "The number of methods analyzed: "; - INT !number_method_analyzed; NL] ; - JCHPolyIntDomainNoArrays.print_lost_info () ; - print_method_time_count () + List.iter get_p procs; + + pr__debug [NL; NL; STR "Finished a numeric analysis pass of all methods "; NL; + STR "The number of methods analyzed: "; + INT !number_method_analyzed; NL]; + JCHPolyIntDomainNoArrays.print_lost_info (); + print_method_time_count () -(* ----------------------------------------------------------------- save/load xml -- -*) +(* --------------------------------------------------------- save/load xml -- *) (* taint analysis support *) @@ -1840,22 +1884,22 @@ let write_xml_unreachable_vars (node: xml_element_int) set = let mk_node var_index = let vnode = xmlElement "var" in begin - vnode#setIntAttribute "var_index" var_index ; + vnode#setIntAttribute "var_index" var_index; vnode end in node#appendChildren (List.map mk_node set#toList) let read_xml_unreachable_vars (node:xml_element_int) = let get_var_index nd = nd#getIntAttribute "var_index" in - IntCollections.set_of_list (List.map get_var_index (node#getTaggedChildren "var")) + IntCollections.set_of_list (List.map get_var_index (node#getTaggedChildren "var")) let write_xml_symbol (node:xml_element_int) (s:symbol_t) = - node#setIntAttribute "seqnr" s#getSeqNumber ; + node#setIntAttribute "seqnr" s#getSeqNumber; node#setAttribute "name" s#getBaseName; let mk_att_node att = let att_node = xmlElement "att" in begin - att_node#setAttribute "att" att ; + att_node#setAttribute "att" att; att_node end in node#appendChildren (List.map mk_att_node s#getAttributes) @@ -1871,7 +1915,7 @@ let read_xml_symbol (node:xml_element_int): symbol_t = let write_xml_variable (node: xml_element_int) (v: variable_t) = begin node#setAttribute - "type" (variable_type_mfts#ts v#getType) ; + "type" (variable_type_mfts#ts v#getType); write_xml_symbol node v#getName end @@ -1882,13 +1926,13 @@ let read_xml_variable (node: xml_element_int): variable_t = let write_xml_local_var_map (node: xml_element_int) (local_var_map: variable_t VariableCollections.table_t) = - let mk_pair_nd (original_var, version_var) = + let mk_pair_nd (original_var, version_var) = let pair_nd = xmlElement "pair" in let orig_nd = xmlElement "orig_var" in - write_xml_variable orig_nd original_var ; + write_xml_variable orig_nd original_var; let vers_nd = xmlElement "vers_var" in - write_xml_variable vers_nd version_var ; - pair_nd#appendChildren [orig_nd; vers_nd] ; + write_xml_variable vers_nd version_var; + pair_nd#appendChildren [orig_nd; vers_nd]; pair_nd in node#appendChildren (List.map mk_pair_nd local_var_map#listOfPairs) @@ -1899,7 +1943,7 @@ let read_xml_local_var_map (node: xml_element_int) = let vers_nd = nd#getTaggedChild "vers_var" in table#set (read_xml_variable orig_nd) (read_xml_variable vers_nd) in begin - List.iter read_pair (node#getTaggedChildren "pair") ; + List.iter read_pair (node#getTaggedChildren "pair"); table end @@ -1909,7 +1953,7 @@ let write_xml_local_var_maps let mk_map_nd (pc, table) = let map_nd = xmlElement "map" in begin - map_nd#setIntAttribute "pc" pc ; + map_nd#setIntAttribute "pc" pc; write_xml_local_var_map map_nd table; map_nd end in @@ -1922,28 +1966,28 @@ let read_xml_local_var_maps (node: xml_element_int) = let t = read_xml_local_var_map nd in table#set pc t in begin - List.iter read_map (node#getTaggedChildren "map") ; + List.iter read_map (node#getTaggedChildren "map"); table end - + let write_xml_method_taint_support (node:xml_element_int) (cms:class_method_signature_int) = let cmsix = cms#index in begin - node#setIntAttribute "cmsix" cmsix ; + node#setIntAttribute "cmsix" cmsix; (try let set = H.find !unreachable_vars cmsix in let unode = xmlElement "unreachable" in begin - write_xml_unreachable_vars unode set ; + write_xml_unreachable_vars unode set; node#appendChildren [unode] end - with _ -> ()) ; - try + with _ -> ()); + try let local_var_maps = H.find !local_var_maps cmsix in let lnode = xmlElement "local_var_maps" in begin - write_xml_local_var_maps lnode local_var_maps ; + write_xml_local_var_maps lnode local_var_maps; node#appendChildren [lnode] end with _ -> () @@ -1957,7 +2001,7 @@ let read_xml_method_taint_support (node:xml_element_int) = begin let unreach = read_xml_unreachable_vars (getc "unreachable_vars") in if not unreach#isEmpty then H.replace !unreachable_vars cmsix unreach - end) ; + end); (if hasc "local_var_maps" then begin let lvar_maps = read_xml_local_var_maps (getc "local_var_maps") in @@ -1972,38 +2016,38 @@ let write_xml_class_taint_support (node:xml_element_int) (cInfo:class_info_int) (List.map (fun ms -> let cms = make_cms cn ms in let mNode = xmlElement "method" in - begin write_xml_method_taint_support mNode cms ; mNode end) - cInfo#get_methods_defined) ; - node#appendChildren [ mmNode ] - end + begin write_xml_method_taint_support mNode cms; mNode end) + cInfo#get_methods_defined); + node#appendChildren [ mmNode] + end -let read_xml_class_taint_support (node:xml_element_int) = +let _read_xml_class_taint_support (node:xml_element_int) = let name = node#getAttribute "name" in let package = node#getAttribute "package" in try List.iter read_xml_method_taint_support - ((node#getTaggedChild "methods")#getTaggedChildren "method") ; + ((node#getTaggedChild "methods")#getTaggedChildren "method"); with | XmlDocumentError (line,col,p) | XmlParseError (line,col,p) -> raise (JCH_failure ( - LBLOCK [ STR "Xml error in " ; STR package ; STR "." ; - STR name ; STR ": (" ; - INT line ; STR "," ; INT col ; STR "): " ; p ])) - + LBLOCK [STR "Xml error in "; STR package; STR "."; + STR name; STR ": ("; + INT line; STR ","; INT col; STR "): "; p])) + let save_xml_class_taint_support (cInfo:class_info_int) = if cInfo#is_stubbed || cInfo#is_missing then () else let cn = cInfo#get_class_name in let node = xmlElement "class" in begin - write_xml_class_taint_support node cInfo ; - node#setAttribute "name" cn#simple_name ; - node#setAttribute "package" cn#package_name ; - save_xml_taint_support_data cn node "class" ; + write_xml_class_taint_support node cInfo; + node#setAttribute "name" cn#simple_name; + node#setAttribute "package" cn#package_name; + save_xml_taint_support_data cn node "class"; end - + (* cost analysis support *) let write_xml_bounds (node:xml_element_int) (bounds:jterm_t list) = @@ -2014,15 +2058,15 @@ let read_xml_bounds (node:xml_element_int):jterm_t list = jtdictionary#read_xml_jterm_list node else [] - + let write_xml_geq_terms (node:xml_element_int) t = let pairs = t#listOfPairs in node#appendChildren (List.map (fun (joinpc,bounds) -> let jnode = xmlElement "join" in begin - jnode#setIntAttribute "pc" joinpc ; - write_xml_bounds jnode bounds#toList ; + jnode#setIntAttribute "pc" joinpc; + write_xml_bounds jnode bounds#toList; jnode end) pairs) @@ -2031,7 +2075,7 @@ let read_xml_geq_terms (node:xml_element_int) t = let pc = n#getIntAttribute "pc" in let bounds = JTermCollections.set_of_list (read_xml_bounds n) in t#set pc bounds) (node#getTaggedChildren "join") - + let write_xml_iterations (node:xml_element_int) t = let pairs = t#listOfPairs in node#appendChildren @@ -2039,7 +2083,7 @@ let write_xml_iterations (node:xml_element_int) t = let jnode = xmlElement "wtohead" in begin jnode#setIntAttribute "pc" headwto; - write_xml_bounds jnode bounds#toList ; + write_xml_bounds jnode bounds#toList; jnode end) pairs) @@ -2047,7 +2091,7 @@ let read_xml_iterations (node:xml_element_int) t = List.iter (fun n -> let pc = n#getIntAttribute "pc" in let bounds = JTermCollections.set_of_list (read_xml_bounds n) in - t#set pc bounds) (node#getTaggedChildren "wtohead") + t#set pc bounds) (node#getTaggedChildren "wtohead") let write_xml_arg_bounds (node:xml_element_int) t = let pairs = t#listOfPairs in @@ -2055,12 +2099,12 @@ let write_xml_arg_bounds (node:xml_element_int) t = (List.map (fun (arg_term,bounds) -> let anode = xmlElement "arg_bounds" in let arg_node = xmlElement "arg" in - jtdictionary#write_xml_jterm arg_node arg_term ; + jtdictionary#write_xml_jterm arg_node arg_term; let bounds_node = xmlElement "bounds" in - write_xml_bounds bounds_node bounds#toList ; - anode#appendChildren [arg_node; bounds_node] ; + write_xml_bounds bounds_node bounds#toList; + anode#appendChildren [arg_node; bounds_node]; anode) pairs) - + let read_xml_arg_bounds (node:xml_element_int) t = List.iter (fun node -> let anode = node#getTaggedChild "arg" in @@ -2075,8 +2119,8 @@ let write_xml_pc_arg_bounds (node:xml_element_int) t = (List.map (fun (pc,argt) -> let anode = xmlElement "call" in begin - anode#setIntAttribute "pc" pc ; - write_xml_arg_bounds anode argt ; + anode#setIntAttribute "pc" pc; + write_xml_arg_bounds anode argt; anode end) pairs) @@ -2085,7 +2129,7 @@ let read_xml_pc_arg_bounds (node:xml_element_int) t = let pc = n#getIntAttribute "pc" in let tt = new JTermCollections.table_t in begin - read_xml_arg_bounds n tt ; + read_xml_arg_bounds n tt; t#set pc tt end) (node#getTaggedChildren "call") @@ -2097,55 +2141,55 @@ let write_xml_method_cost_support | Some t -> let pNode = xmlElement "geq-terms" in begin - write_xml_geq_terms pNode t ; - node#appendChildren [ pNode ] + write_xml_geq_terms pNode t; + node#appendChildren [pNode] end - | _ -> ()) ; + | _ -> ()); (match !iterations_lbs#get cmsix with | Some t -> let mNode = xmlElement "its-lbs" in begin - write_xml_iterations mNode t ; - node#appendChildren [ mNode ] + write_xml_iterations mNode t; + node#appendChildren [mNode] end - | _ -> ()) ; + | _ -> ()); (match !iterations_ubs#get cmsix with | Some t -> let mNode = xmlElement "its-ubs" in begin - write_xml_iterations mNode t ; - node#appendChildren [ mNode ] + write_xml_iterations mNode t; + node#appendChildren [mNode] end - | _ -> ()) ; + | _ -> ()); (match !method_arg_lbounds#get cmsix with | Some t -> let bNode = xmlElement "arg-lbounds" in begin - write_xml_pc_arg_bounds bNode t ; - node#appendChildren [ bNode ] + write_xml_pc_arg_bounds bNode t; + node#appendChildren [bNode] end | _ -> ()); (match !method_arg_ubounds#get cmsix with | Some t -> let bNode = xmlElement "arg-ubounds" in begin - write_xml_pc_arg_bounds bNode t ; - node#appendChildren [ bNode ] + write_xml_pc_arg_bounds bNode t; + node#appendChildren [bNode] end - | _ -> ()) ; + | _ -> ()); (try let set = H.find !unreachable_vars cmsix in let unode = xmlElement "unreachable_vars" in - write_xml_unreachable_vars unode set ; - node#appendChildren [unode] - with _ -> ()) ; - (try + write_xml_unreachable_vars unode set; + node#appendChildren [unode] + with _ -> ()); + (try let local_var_maps = H.find !local_var_maps cmsix in let lnode = xmlElement "local_var_maps" in - write_xml_local_var_maps lnode local_var_maps ; - node#appendChildren [lnode] - with _ -> ()) ; - node#setIntAttribute "cmsix" cmsix + write_xml_local_var_maps lnode local_var_maps; + node#appendChildren [lnode] + with _ -> ()); + node#setIntAttribute "cmsix" cmsix end let read_xml_method_cost_support (node:xml_element_int) = @@ -2156,38 +2200,38 @@ let read_xml_method_cost_support (node:xml_element_int) = (if hasc "geq-terms" then let t = new IntCollections.table_t in begin - read_xml_geq_terms (getc "geq-terms") t ; + read_xml_geq_terms (getc "geq-terms") t; !geq_terms#set cmsix t - end) ; + end); (if hasc "its-lbs" then let t = new IntCollections.table_t in begin - read_xml_iterations (getc "its-lbs") t ; + read_xml_iterations (getc "its-lbs") t; !iterations_lbs#set cmsix t - end) ; + end); (if hasc "its-ubs" then let t = new IntCollections.table_t in begin - read_xml_iterations (getc "its-ubs") t ; + read_xml_iterations (getc "its-ubs") t; !iterations_ubs#set cmsix t - end) ; + end); (if hasc "arg-lbounds" then let t = new IntCollections.table_t in begin - read_xml_pc_arg_bounds (getc "arg-lbounds") t ; + read_xml_pc_arg_bounds (getc "arg-lbounds") t; !method_arg_lbounds#set cmsix t - end) ; + end); (if hasc "arg-ubounds" then let t = new IntCollections.table_t in begin - read_xml_pc_arg_bounds (getc "arg-ubounds") t ; + read_xml_pc_arg_bounds (getc "arg-ubounds") t; !method_arg_ubounds#set cmsix t - end) ; + end); (if hasc "unreachable_vars" then (* taint support *) begin let unreach = read_xml_unreachable_vars (getc "unreachable_vars") in if not unreach#isEmpty then H.replace !unreachable_vars cmsix unreach - end) ; + end); (if hasc "local_var_maps" then (* taint support *) begin let lvar_maps = read_xml_local_var_maps (getc "local_var_maps") in @@ -2208,51 +2252,51 @@ let bound_from_string str = plus_inf_bound else bound_of_num (mkNumericalFromString str) - -let write_xml_interval (node:xml_element_int) int = + +let _write_xml_interval (node:xml_element_int) int = begin node#setAttribute "min" (bound_to_string int#getMin); node#setAttribute "max" (bound_to_string int#getMax) end - + let read_xml_interval (node: xml_element_int) = let min = bound_from_string (node#getAttribute "min") in let max = bound_from_string (node#getAttribute "max") in - new interval_t min max - -let write_xml_field_int_table (node: xml_element_int) table = + new interval_t min max + +let write_xml_field_int_table (node: xml_element_int) table = node#appendChildren - (List.map (fun (field, int) -> - let fnode = xmlElement "field" in - jtdictionary#write_xml_jterm fnode field ; + (List.map (fun (field, _int) -> + let fnode = xmlElement "field" in + jtdictionary#write_xml_jterm fnode field; let intNode = xmlElement "interval" in fnode#appendChildren [intNode]; fnode) table#listOfPairs) let read_xml_field_int_table (node:xml_element_int) = let table = new JTermCollections.table_t in - let add_node nd = + let add_node nd = let jterm = jtdictionary#read_xml_jterm (nd#getTaggedChild "field") in let int = read_xml_interval (nd#getTaggedChild "interval") in table#set jterm int in begin - List.iter add_node (node#getTaggedChildren "field") ; + List.iter add_node (node#getTaggedChildren "field"); table end let write_xml_class_cost_support (node:xml_element_int) (cInfo:class_info_int) = let mmNode = xmlElement "methods" in - node#setIntAttribute "cnix" cInfo#get_index ; + node#setIntAttribute "cnix" cInfo#get_index; let cn = cInfo#get_class_name in begin mmNode#appendChildren (List.map (fun ms -> let cms = make_cms cn ms in let mNode = xmlElement "method" in - begin write_xml_method_cost_support mNode cms ; mNode end) - cInfo#get_methods_defined) ; - node#appendChildren [ mmNode ] - end ; + begin write_xml_method_cost_support mNode cms; mNode end) + cInfo#get_methods_defined); + node#appendChildren [mmNode] + end; (match !pos_fields#get cInfo#get_index with | Some table -> let pos_fields_node = xmlElement "pos_fields" in @@ -2265,8 +2309,8 @@ let read_xml_class_cost_support (node:xml_element_int) = let cnix = node#getIntAttribute "cnix" in try List.iter read_xml_method_cost_support - ((node#getTaggedChild "methods")#getTaggedChildren "method") ; - (if node#hasOneTaggedChild "pos_fields" then + ((node#getTaggedChild "methods")#getTaggedChildren "method"); + (if node#hasOneTaggedChild "pos_fields" then let table = read_xml_field_int_table node in !pos_fields#set cnix table) with @@ -2274,9 +2318,9 @@ let read_xml_class_cost_support (node:xml_element_int) = | XmlParseError (line,col,p) -> raise (JCH_failure ( - LBLOCK [ STR "Xml error in " ; STR package ; STR "." ; - STR name ; STR ": (" ; - INT line ; STR "," ; INT col ; STR "): " ; p ])) + LBLOCK [STR "Xml error in "; STR package; STR "."; + STR name; STR ": ("; + INT line; STR ","; INT col; STR "): "; p])) let save_xml_class_cost_support (cInfo:class_info_int) = @@ -2284,12 +2328,12 @@ let save_xml_class_cost_support (cInfo:class_info_int) = let cn = cInfo#get_class_name in let node = xmlElement "class" in begin - write_xml_class_cost_support node cInfo ; - node#setAttribute "name" cn#simple_name ; - node#setAttribute "package" cn#package_name ; - save_xml_cost_support_data cn node "class" ; + write_xml_class_cost_support node cInfo; + node#setAttribute "name" cn#simple_name; + node#setAttribute "package" cn#package_name; + save_xml_cost_support_data cn node "class"; end - + let load_xml_class_cost_support () = - List.iter read_xml_class_cost_support (load_xml_cost_support_files ()) + List.iter read_xml_class_cost_support (load_xml_cost_support_files ()) diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.mli b/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.mli index b7e99d7a..7da9e005 100644 --- a/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.mli +++ b/CodeHawk/CHJ/jchpoly/jCHNumericAnalysis.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericInfo.ml b/CodeHawk/CHJ/jchpoly/jCHNumericInfo.ml index b57df252..73619721 100644 --- a/CodeHawk/CHJ/jchpoly/jCHNumericInfo.ml +++ b/CodeHawk/CHJ/jchpoly/jCHNumericInfo.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -28,40 +29,37 @@ (* chlib *) open CHIntervals open CHLanguage -open CHNumerical +open CHNumerical open CHPretty open CHUtils - + (* chutil *) open CHPrettyUtil -(* jchlib *) -open JCHBasicTypes - (* jchpre *) open JCHPreAPI - -class num_info_t = - object (self: 'a) + +class num_info_t = + object (_: 'a) val excluded : numerical_t list = [] - val divisions : (variable_t * variable_t) list = [] + val divisions : (variable_t * variable_t) list = [] val empty_collection = false (* it is an empty collection *) val changed_sym_param = false (* it could have been changed *) - (* fields that, at some point, had an equal value with the + (* fields that, at some point, had an equal value with the * value of this variable * range of values for the var included in the range of value for each field * if the variable is a length of a then these are the fields for a *) val fields : JCHPreAPI.field_info_int list = [] method excluded = excluded - method divisions = divisions - method is_empty_collection = empty_collection + method divisions = divisions + method is_empty_collection = empty_collection method is_changed_sym_param = changed_sym_param method fields = fields - method is_empty = + method is_empty = excluded = [] && divisions = [] && not empty_collection @@ -74,54 +72,54 @@ class num_info_t = && not changed_sym_param && fields = [] - method remove_vars (vars: variable_t list) = - let is_not_in_vars var = + method remove_vars (vars: variable_t list) = + let is_not_in_vars var = let index = var#getIndex in List.for_all (fun v -> v#getIndex <> index) vars in {< divisions = List.filter (fun (d,q) -> is_not_in_vars d && is_not_in_vars q) divisions >} - method remove_var (var:variable_t) (interval:interval_t) = + method remove_var (var:variable_t) (_interval:interval_t) = {< divisions = List.filter (fun (d,q) -> not (d#equal var || q#equal var)) divisions >} - method change_vars (vars: variable_t list) = - let is_in_vars var = + method change_vars (vars: variable_t list) = + let is_in_vars var = let index = var#getIndex in List.exists (fun v -> v#getIndex = index) vars in {< divisions = List.filter (fun (d,q) -> is_in_vars d && is_in_vars q) divisions >} - method remove_excluded_val (vl:numerical_t) = + method remove_excluded_val (vl:numerical_t) = let new_excluded = List.filter (fun vl' -> not (vl'#equal vl)) excluded in {< excluded = new_excluded >} - + method remove_excluded = {< excluded = [] >} - - method add_excluded_val (vl:numerical_t) = + + method add_excluded_val (vl:numerical_t) = if List.exists (fun vl' -> vl'#equal vl) excluded then - {< >} + {< >} else - {< excluded = vl :: excluded >} + {< excluded = vl :: excluded >} - method add_excluded_vals (vls:numerical_t list) = + method add_excluded_vals (vls:numerical_t list) = let vls' = List.filter (fun vl -> - not (List.exists (fun vl' -> vl'#equal vl) excluded)) vls in - {< excluded = excluded @ vls' >} + not (List.exists (fun vl' -> vl'#equal vl) excluded)) vls in + {< excluded = excluded @ vls' >} - method set_excluded_vals (vls:numerical_t list) = + method set_excluded_vals (vls:numerical_t list) = {< excluded = vls >} - method set_divisions (divisions:(variable_t * variable_t) list) = + method set_divisions (divisions:(variable_t * variable_t) list) = {< divisions = divisions >} - method set_empty_collection (b:bool) = + method set_empty_collection (b:bool) = {< empty_collection = b >} - method set_changed_sym_param (b:bool) = + method set_changed_sym_param (b:bool) = {< changed_sym_param = b >} method add_field (fInfo:field_info_int) = @@ -133,8 +131,8 @@ class num_info_t = method set_fields (fInfos:field_info_int list) = {< fields = fInfos >} - method meet (a: 'a) = - let equal_vpair (v1, v2) (w1, w2) = + method meet (a: 'a) = + let equal_vpair (v1, v2) (w1, w2) = v1#getIndex = w1#getIndex && v2#getIndex = w2#getIndex in let aexcluded = List.filter (fun vl -> not (List.exists vl#equal excluded)) a#excluded in @@ -145,55 +143,57 @@ class num_info_t = List.filter (fun f1 -> List.exists (fun f2 -> f1#compare f2 != 0) fields) a#fields in - {< excluded = excluded @ aexcluded ; - divisions = divisions @ adivisions ; - empty_collection = empty_collection || a#is_empty_collection ; - changed_sym_param = changed_sym_param || a#is_changed_sym_param ; - fields = List.rev_append fields afields + {< excluded = excluded @ aexcluded; + divisions = divisions @ adivisions; + empty_collection = empty_collection || a#is_empty_collection; + changed_sym_param = changed_sym_param || a#is_changed_sym_param; + fields = List.rev_append fields afields >} - - method join (a: 'a) = - let equal_vpair (v1, v2) (w1, w2) = + + method join (a: 'a) = + let equal_vpair (v1, v2) (w1, w2) = v1#getIndex = w1#getIndex && v2#getIndex = w2#getIndex in let new_divisions = List.filter (fun (v1,v2) -> List.exists (equal_vpair (v1,v2)) divisions) a#divisions in - {< excluded = List.filter (fun vl -> List.exists vl#equal excluded) a#excluded ; - divisions = new_divisions ; - empty_collection = empty_collection && a#is_empty_collection ; - changed_sym_param = changed_sym_param || a#is_changed_sym_param ; + {< excluded = + List.filter (fun vl -> List.exists vl#equal excluded) a#excluded; + divisions = new_divisions; + empty_collection = empty_collection && a#is_empty_collection; + changed_sym_param = changed_sym_param || a#is_changed_sym_param; fields = List.filter (fun f1 -> - List.exists (fun f2 -> f1#compare f2 = 0) fields) a#fields + List.exists (fun f2 -> f1#compare f2 = 0) fields) a#fields >} - method replace_vars (map_v:(variable_t * variable_t) list) = + method replace_vars (map_v:(variable_t * variable_t) list) = let changed_divisions = - List.map (fun (d, q) -> (List.assoc d map_v, List.assoc q map_v)) divisions in + List.map + (fun (d, q) -> (List.assoc d map_v, List.assoc q map_v)) divisions in {< divisions = changed_divisions >} - method toPretty = - let excluded_pp = + method toPretty = + let excluded_pp = if excluded = [] then - STR "" + STR "" else LBLOCK [STR "excluded values: "; pp_list excluded; NL] in - let divisions_pp = + let divisions_pp = if divisions = [] then STR "" - else - let pp_one (dividend, quotient) = + else + let pp_one (dividend, quotient) = LBLOCK [STR "(dividend, quotient) = ("; dividend#toPretty; STR ", "; quotient#toPretty; STR ")"; NL] in LBLOCK [STR "divisor info: "; INDENT (5, pretty_print_list divisions pp_one "" "" ""); NL] in - let empty_collection_pp = + let empty_collection_pp = if empty_collection then LBLOCK [STR "empty collection"; NL] else STR "" in - let changed_sym_param_pp = + let changed_sym_param_pp = if changed_sym_param then LBLOCK [STR "changed sym param"; NL] else @@ -206,22 +206,22 @@ class num_info_t = LBLOCK [excluded_pp; divisions_pp; empty_collection_pp; changed_sym_param_pp; fields_pp] - method to_pretty_no_excluded = - let divisions_pp = + method to_pretty_no_excluded = + let divisions_pp = if divisions = [] then STR "" - else - let pp_one (dividend, quotient) = + else + let pp_one (dividend, quotient) = LBLOCK [STR "(dividend, quotient) = ("; dividend#toPretty; STR ", "; quotient#toPretty; STR ")"; NL] in LBLOCK [STR "divisor info: "; INDENT (5, pretty_print_list divisions pp_one "" "" ""); NL] in - let empty_collection_pp = + let empty_collection_pp = if empty_collection then LBLOCK [STR "empty collection"; NL] else STR "" in - let changed_sym_param_pp = + let changed_sym_param_pp = if changed_sym_param then LBLOCK [STR "changed sym param"; NL] else @@ -233,62 +233,62 @@ class num_info_t = LBLOCK [STR "fields: "; pp_list fields; NL] in LBLOCK [divisions_pp; empty_collection_pp; changed_sym_param_pp; fields_pp] - + end -class numeric_info_t = +class numeric_info_t = object (self: 'a) - - val info_map : (int * num_info_t) list = [] + + val info_map : (int * num_info_t) list = [] method initialize - (d2div2quot: variable_t VariableCollections.table_t VariableCollections.table_t) = + (d2div2quot: variable_t VariableCollections.table_t VariableCollections.table_t) = let info_map = ref [] in - let add_divisions divisor table = + let add_divisions divisor table = let divisions = ref [] in - let add dividend quotient = + let add dividend quotient = divisions := (dividend, quotient) :: !divisions in - table#iter add ; + table#iter add; let num_info = (new num_info_t)#set_divisions !divisions in info_map := (divisor#getIndex, num_info) :: !info_map in begin - d2div2quot#iter add_divisions ; + d2div2quot#iter add_divisions; {< info_map = !info_map >} end - + method add_div_info - (d2div2quot: variable_t VariableCollections.table_t VariableCollections.table_t) = + (d2div2quot: variable_t VariableCollections.table_t VariableCollections.table_t) = let imap = ref info_map in - let add_divisions divisor table = + let add_divisions divisor table = let divisions = ref [] in - let add dividend quotient = + let add dividend quotient = divisions := (dividend, quotient) :: !divisions in - table#iter add ; + table#iter add; let num_info = (new num_info_t)#set_divisions !divisions in imap := (divisor#getIndex, num_info) :: !imap in begin - d2div2quot#iter add_divisions ; + d2div2quot#iter add_divisions; {< info_map = !imap >} end - method clone = {< >} + method clone = {< >} method get_info_map = info_map - method get_num_info (var:variable_t) = + method get_num_info (var:variable_t) = try List.assoc var#getIndex info_map with - | _ -> new num_info_t + | _ -> new num_info_t - method private get_num_info_opt (var:variable_t) = + method private get_num_info_opt (var:variable_t) = try Some (List.assoc var#getIndex info_map) with - | _ -> None + | _ -> None - method private get_num_info_opt_not_excluded (var:variable_t) = + method private get_num_info_opt_not_excluded (var:variable_t) = try let num_info = List.assoc var#getIndex info_map in if num_info#has_only_excluded then @@ -296,101 +296,100 @@ object (self: 'a) else Some num_info with - | _ -> None + | _ -> None - method get_num_info_ind (ind:int) = + method get_num_info_ind (ind:int) = try Some (List.assoc ind info_map) with - | _ -> None - - method set_num_info (var:variable_t) (num_info:num_info_t) = + | _ -> None + + method set_num_info (var:variable_t) (num_info:num_info_t) = let index = var#getIndex in {< info_map = (index, num_info) :: (List.remove_assoc index info_map) >} method replace_vars (map_v: (variable_t * variable_t) list) - (map: (int * variable_t) list) = + (map: (int * variable_t) list) = let new_info_map = ref [] in - let add_info (old_index, info) = + let add_info (old_index, info) = let new_var = List.assoc old_index map in let new_info = info#replace_vars map_v in new_info_map := (new_var#getIndex, new_info) :: !new_info_map in begin - List.iter add_info info_map ; + List.iter add_info info_map; {< info_map = !new_info_map >} end - - method remove_var (var:variable_t) (interval:interval_t) = + + method remove_var (var:variable_t) (interval:interval_t) = let new_info_map = List.remove_assoc var#getIndex info_map in - let rec remove_vs assocs = - match assocs with - | (ind, num_info) :: rest_assocs -> + let rec remove_vs assocs = + match assocs with + | (ind, num_info) :: rest_assocs -> let new_num_info = num_info#remove_var var interval in if new_num_info#is_empty then - remove_vs rest_assocs + remove_vs rest_assocs else (ind, new_num_info) :: (remove_vs rest_assocs) | _ -> [] in {< info_map = remove_vs new_info_map >} - - method remove_vars (vars:variable_t list) = - let remove_var map var = - List.remove_assoc var#getIndex map in + method remove_vars (vars:variable_t list) = + let remove_var map var = + List.remove_assoc var#getIndex map in let new_info_map = List.fold_left remove_var info_map vars in - let rec remove_vs assocs = - match assocs with - | (ind, num_info) :: rest_assocs -> + let rec remove_vs assocs = + match assocs with + | (ind, num_info) :: rest_assocs -> let new_num_info = num_info#remove_vars vars in if new_num_info#is_empty then - remove_vs rest_assocs + remove_vs rest_assocs else (ind, new_num_info) :: (remove_vs rest_assocs) | _ -> [] in {< info_map = remove_vs new_info_map >} - method change_vars (vars:variable_t list) = - let check_assoc new_map (ind, num_info) = - if (List.exists (fun v -> v#getIndex = ind) vars) then + method change_vars (vars:variable_t list) = + let check_assoc new_map (ind, num_info) = + if (List.exists (fun v -> v#getIndex = ind) vars) then (ind, num_info) :: new_map else new_map in let new_info_map = List.fold_left check_assoc [] info_map in - let rec restrict_to_vs assocs = - match assocs with - | (ind, num_info) :: rest_assocs -> + let rec restrict_to_vs assocs = + match assocs with + | (ind, num_info) :: rest_assocs -> let new_num_info = num_info#change_vars vars in if new_num_info#is_empty then - restrict_to_vs rest_assocs + restrict_to_vs rest_assocs else (ind, new_num_info) :: (restrict_to_vs rest_assocs) | _ -> [] in {< info_map = restrict_to_vs new_info_map >} - method get_excluded_vals (var:variable_t) = - match self#get_num_info_opt var with + method get_excluded_vals (var:variable_t) = + match self#get_num_info_opt var with | Some num_info -> num_info#excluded | None -> [] - method get_excluded_vals_ind (var_ind:int) = - match self#get_num_info_ind var_ind with - | Some num_info -> num_info#excluded - | None -> [] + method get_excluded_vals_ind (var_ind:int) = + match self#get_num_info_ind var_ind with + | Some num_info -> num_info#excluded + | None -> [] - method remove_excluded_val (var:variable_t) (vl:numerical_t) = - match self#get_num_info_opt var with - | Some num_info -> + method remove_excluded_val (var:variable_t) (vl:numerical_t) = + match self#get_num_info_opt var with + | Some num_info -> let new_num_info = num_info#remove_excluded_val vl in if new_num_info#is_empty then self#remove_vars [var] else self#set_num_info var new_num_info - | None -> {< >} + | None -> {< >} - method remove_all_excluded (var:variable_t) = - match self#get_num_info_opt var with - | Some num_info -> + method remove_all_excluded (var:variable_t) = + match self#get_num_info_opt var with + | Some num_info -> let new_num_info = num_info#remove_excluded in if new_num_info#is_empty then self#remove_vars [var] @@ -398,161 +397,161 @@ object (self: 'a) self#set_num_info var new_num_info | None -> {< >} - method add_excluded_val (var:variable_t) (vl:numerical_t) = + method add_excluded_val (var:variable_t) (vl:numerical_t) = let num_info = self#get_num_info var in let new_num_info = num_info#add_excluded_val vl in - self#set_num_info var new_num_info + self#set_num_info var new_num_info - method add_excluded_vals (var:variable_t) (vls:numerical_t list) = + method add_excluded_vals (var:variable_t) (vls:numerical_t list) = let num_info = self#get_num_info var in let new_num_info = num_info#add_excluded_vals vls in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else - self#set_num_info var new_num_info + self#set_num_info var new_num_info - method set_excluded_vals (var:variable_t) (vls:numerical_t list) = + method set_excluded_vals (var:variable_t) (vls:numerical_t list) = let num_info = self#get_num_info var in let new_num_info = num_info#set_excluded_vals vls in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else - self#set_num_info var new_num_info + self#set_num_info var new_num_info - method add_empty_collection (var:variable_t) = + method add_empty_collection (var:variable_t) = let num_info = self#get_num_info var in let new_num_info = num_info#set_empty_collection true in - self#set_num_info var new_num_info + self#set_num_info var new_num_info - method is_empty_collection (var:variable_t) = - match self#get_num_info_opt var with + method is_empty_collection (var:variable_t) = + match self#get_num_info_opt var with | Some num_info -> num_info#is_empty_collection | None -> false - method remove_empty_collection (var:variable_t) = - match self#get_num_info_opt var with - | Some num_info -> + method remove_empty_collection (var:variable_t) = + match self#get_num_info_opt var with + | Some num_info -> let new_num_info = num_info#set_empty_collection false in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else self#set_num_info var new_num_info - | None -> {< >} + | None -> {< >} - method private add_changed_sym_param (a: 'a) (var: variable_t) = + method private add_changed_sym_param (a: 'a) (var: variable_t) = let num_info = a#get_num_info var in let new_num_info = num_info#set_changed_sym_param true in - a#set_num_info var new_num_info + a#set_num_info var new_num_info - method add_changed_sym_params (vars:variable_t list) = + method add_changed_sym_params (vars:variable_t list) = List.fold_left self#add_changed_sym_param self vars - method is_changed_sym_param (var:variable_t) = - match self#get_num_info_opt var with + method is_changed_sym_param (var:variable_t) = + match self#get_num_info_opt var with | Some num_info -> num_info#is_changed_sym_param | None -> false - method get_divisions (var:variable_t) = - match self#get_num_info_opt var with + method get_divisions (var:variable_t) = + match self#get_num_info_opt var with | Some num_info -> num_info#divisions - | None -> [] + | None -> [] method add_field (var:variable_t) (fInfo:field_info_int) = let num_info = self#get_num_info var in let new_num_info = num_info#add_field fInfo in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else - self#set_num_info var new_num_info + self#set_num_info var new_num_info method set_fields (var:variable_t) (fInfos:field_info_int list) = let num_info = self#get_num_info var in let new_num_info = num_info#set_fields fInfos in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else - self#set_num_info var new_num_info + self#set_num_info var new_num_info method remove_field (var:variable_t) (fInfo:field_info_int) = let num_info = self#get_num_info var in let new_num_info = num_info#remove_field fInfo in - if new_num_info#is_empty then + if new_num_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else - self#set_num_info var new_num_info - + self#set_num_info var new_num_info + method has_fields (var:variable_t) = let num_info = self#get_num_info var in - num_info#fields != [] + num_info#fields != [] method get_fields (var:variable_t) = - (self#get_num_info var)#fields + (self#get_num_info var)#fields - method set_same_info (var1:variable_t) (var2:variable_t) = - match self#get_num_info_opt var2 with + method set_same_info (var1:variable_t) (var2:variable_t) = + match self#get_num_info_opt var2 with | Some num_info -> self#set_num_info var1 num_info | None -> {< >} - method meet (a: 'a) = + method meet (a: 'a) = let new_info_map = ref [] in let inds = IntCollections.set_of_list (List.map fst info_map) in - inds#addList (List.map fst a#get_info_map) ; - - let add_info ind = - match (self#get_num_info_ind ind, a#get_num_info_ind ind) with - | (Some info, Some ainfo) -> + inds#addList (List.map fst a#get_info_map); + + let add_info ind = + match (self#get_num_info_ind ind, a#get_num_info_ind ind) with + | (Some info, Some ainfo) -> let meet_info = info#meet ainfo in - if not meet_info#is_empty then + if not meet_info#is_empty then new_info_map := (ind, meet_info) :: !new_info_map | (Some info, _) -> new_info_map := (ind, info) :: !new_info_map | (_, Some ainfo) -> new_info_map := (ind, ainfo) :: !new_info_map | _ -> () in - - inds#iter add_info ; + + inds#iter add_info; {< info_map = !new_info_map >} - method join (a: 'a) = + method join (a: 'a) = let new_info_map = ref [] in let inds = IntCollections.set_of_list (List.map fst info_map) in - inds#addList (List.map fst a#get_info_map) ; - - let add_info ind = - match (self#get_num_info_ind ind, a#get_num_info_ind ind) with - | (Some info, Some ainfo) -> + inds#addList (List.map fst a#get_info_map); + + let add_info ind = + match (self#get_num_info_ind ind, a#get_num_info_ind ind) with + | (Some info, Some ainfo) -> let join_info = info#join ainfo in - if not join_info#is_empty then + if not join_info#is_empty then new_info_map := (ind, join_info) :: !new_info_map | _ -> () in - - inds#iter add_info ; + + inds#iter add_info; {< info_map = !new_info_map >} method remove_out_of_interval_excluded - (var:variable_t) (interval:interval_t) = - match self#get_num_info_opt var with - | Some info -> + (var:variable_t) (interval:interval_t) = + match self#get_num_info_opt var with + | Some info -> if interval#isBottom then self#remove_vars [var] - else + else let new_excluded = List.filter interval#contains info#excluded in let new_info = info#set_excluded_vals new_excluded in - if new_info#is_empty then + if new_info#is_empty then {< info_map = List.remove_assoc var#getIndex info_map >} else self#set_num_info var new_info - | None -> {< >} + | None -> {< >} - method to_pretty (vars:variable_t list) = + method to_pretty (vars:variable_t list) = let pp_info var = - match self#get_num_info_opt var with - | Some num_info -> + match self#get_num_info_opt var with + | Some num_info -> LBLOCK [var#toPretty; STR " -> "; INDENT (5, num_info#toPretty); NL] | _ -> STR "" in LBLOCK (List.map pp_info vars) method to_pretty_no_excluded (vars:variable_t list) = let pp_info var = - match self#get_num_info_opt var with + match self#get_num_info_opt var with | Some num_info -> if num_info#has_only_excluded then STR "" @@ -561,15 +560,14 @@ object (self: 'a) INDENT (5, num_info#to_pretty_no_excluded); NL] | _ -> STR "" in LBLOCK (List.map pp_info vars) - - - method toPretty = + + method toPretty = let pp = ref [] in let pp_info (ind, info) = pp := LBLOCK [INT ind; STR " -> "; INDENT (5, info#toPretty); NL] :: !pp in begin - List.iter pp_info info_map ; + List.iter pp_info info_map; LBLOCK (List.rev !pp) end diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericInfo.mli b/CodeHawk/CHJ/jchpoly/jCHNumericInfo.mli index f8c962f6..eddab0a7 100644 --- a/CodeHawk/CHJ/jchpoly/jCHNumericInfo.mli +++ b/CodeHawk/CHJ/jchpoly/jCHNumericInfo.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -34,8 +35,8 @@ open CHUtils (* jchpre *) open JCHPreAPI - -class num_info_t : + +class num_info_t : object ('a) method add_excluded_val : numerical_t -> 'a method add_excluded_vals : numerical_t list -> 'a @@ -66,26 +67,28 @@ class num_info_t : end class numeric_info_t : - object ('a) + object ('a) method add_changed_sym_params : variable_t list -> 'a method add_div_info : - variable_t VariableCollections.table_t VariableCollections.table_t -> 'a + variable_t VariableCollections.table_t VariableCollections.table_t + -> 'a method add_empty_collection : variable_t -> 'a method add_excluded_val : variable_t -> numerical_t -> 'a method add_excluded_vals : variable_t -> numerical_t list -> 'a method add_field : variable_t -> field_info_int -> 'a method change_vars : variable_t list -> 'a method clone : 'a - method get_divisions : variable_t -> (variable_t * variable_t) list + method get_divisions : variable_t -> (variable_t * variable_t) list method get_excluded_vals : variable_t -> numerical_t list method get_excluded_vals_ind : int -> numerical_t list method get_fields : variable_t -> field_info_int list - method get_info_map : (int * num_info_t) list + method get_info_map : (int * num_info_t) list method get_num_info : variable_t -> num_info_t method get_num_info_ind : int -> num_info_t option method has_fields : variable_t -> bool method initialize : - variable_t VariableCollections.table_t VariableCollections.table_t -> 'a + variable_t VariableCollections.table_t VariableCollections.table_t + -> 'a method is_changed_sym_param : variable_t-> bool method is_empty_collection : variable_t -> bool method join : 'a -> 'a @@ -97,7 +100,8 @@ class numeric_info_t : method remove_out_of_interval_excluded : variable_t -> interval_t -> 'a method remove_vars : variable_t list -> 'a method remove_var : variable_t -> interval_t -> 'a - method replace_vars : (variable_t * variable_t) list -> (int * variable_t) list -> 'a + method replace_vars : + (variable_t * variable_t) list -> (int * variable_t) list -> 'a method set_excluded_vals : variable_t -> numerical_t list -> 'a method set_fields : variable_t -> field_info_int list -> 'a method set_num_info : variable_t -> num_info_t -> 'a @@ -106,4 +110,3 @@ class numeric_info_t : method to_pretty_no_excluded : variable_t list -> pretty_t method toPretty : pretty_t end - diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericUtils.ml b/CodeHawk/CHJ/jchpoly/jCHNumericUtils.ml index 52b95b46..0bbdc28c 100644 --- a/CodeHawk/CHJ/jchpoly/jCHNumericUtils.ml +++ b/CodeHawk/CHJ/jchpoly/jCHNumericUtils.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -25,54 +26,45 @@ SOFTWARE. ============================================================================= *) -open Printf - (* chlib *) open CHBounds open CHIntervals open CHLanguage open CHPretty -open CHUtils open CHNumerical -(* chutil *) -open CHPrettyUtil - (* jchlib *) open JCHBasicTypes open JCHBasicTypesAPI open JCHJTerm (* jchpre *) -open JCHFunctionSummary open JCHPreAPI (* jchsys *) -open JCHGlobals open JCHPrintUtils -let dbg = ref false -let get_constants (jproc_info:JCHProcInfo.jproc_info_t) = +let get_constants (jproc_info:JCHProcInfo.jproc_info_t) = let var_to_const = ref [] in - let add_const (var: variable_t) = + let add_const (var: variable_t) = if JCHSystemUtils.is_return var then - () - else + () + else let jvar_info = jproc_info#get_jvar_info var in - match jvar_info#get_constant with + match jvar_info#get_constant with | Some n -> var_to_const := (var#getIndex, n) :: !var_to_const | _ -> () in begin - List.iter add_const jproc_info#get_variables ; + List.iter add_const jproc_info#get_variables; !var_to_const end - -let mk_var_to_index (vars:variable_t list) = + +let mk_var_to_index (vars:variable_t list) = let counter = ref (-1) in - List.map (fun v -> incr counter; (v#getIndex, !counter)) vars + List.map (fun v -> incr counter; (v#getIndex, !counter)) vars -let pp_var_to_index (var_to_index:(int * int) list) = +let pp_var_to_index (var_to_index:(int * int) list) = pretty_print_list var_to_index (fun (n1, n2) -> LBLOCK [INT n1; STR " -> "; INT n2]) "{" "; " "}" @@ -81,27 +73,27 @@ let pp_var_to_index (var_to_index:(int * int) list) = let interval_to_summary_post_predicates var_index (interval:interval_t) - type_interval = + type_interval = let jterm1 = JLocalVar var_index in let preds = ref [] in - let min = interval#getMin in + let min = interval#getMin in (if min#equal minus_inf_bound || min#equal type_interval#getMin then () else begin let jterm2 = JConstant (min#toNumber) in - preds := [PostRelationalExpr (JGreaterEqual, jterm1, jterm2)] - end) ; + preds := [PostRelationalExpr (JGreaterEqual, jterm1, jterm2)] + end); let max = interval#getMax in (if max#equal CHBounds.plus_inf_bound || max#equal type_interval#getMax then - () - else + () + else begin let jterm2 = JConstant (max#toNumber) in - preds := (PostRelationalExpr (JLessEqual, jterm1, jterm2)) :: !preds - end) ; - !preds - + preds := (PostRelationalExpr (JLessEqual, jterm1, jterm2)) :: !preds + end); + !preds + let interval_to_summary_post_predicates2 ~(is_loc:bool) ~(is_lc:bool) @@ -110,12 +102,12 @@ let interval_to_summary_post_predicates2 ~(is_aux_length:bool) ~(var_index:int) ~(name:string) - ~(interval:interval_t):postcondition_predicate_t list = - let jterm = + ~(interval:interval_t):postcondition_predicate_t list = + let jterm = if is_lc then - JLoopCounter var_index - else if is_length then - JSize (JLocalVar var_index) + JLoopCounter var_index + else if is_length then + JSize (JLocalVar var_index) else if is_loc then JLocalVar var_index else if is_aux then @@ -127,53 +119,53 @@ let interval_to_summary_post_predicates2 let preds = ref [] in begin - (match interval#singleton with - | Some n -> preds := [PostRelationalExpr (JEquals, jterm, JConstant n)] - | _ -> - let min = interval#getMin in + (match interval#singleton with + | Some n -> preds := [PostRelationalExpr (JEquals, jterm, JConstant n)] + | _ -> + let min = interval#getMin in let max = interval#getMax in if min#equal minus_inf_bound || min#equal plus_inf_bound then () else preds := - [PostRelationalExpr (JGreaterEqual, jterm, JConstant (min#toNumber))] ; + [PostRelationalExpr (JGreaterEqual, jterm, JConstant (min#toNumber))]; if max#equal minus_inf_bound || max#equal plus_inf_bound then () else preds := (PostRelationalExpr - (JLessEqual, jterm, JConstant (max#toNumber))) :: !preds ) ; + (JLessEqual, jterm, JConstant (max#toNumber))) :: !preds ); !preds end (* Makes function summary predicates for the excluded values of a signature variable *) let excluded_vals_to_summary_pre_predicates - (arg_index:int) (vals:numerical_t list) = - let add_excluded_val preds vl = + (arg_index:int) (vals:numerical_t list) = + let add_excluded_val preds vl = let jterm1 = JLocalVar arg_index in let jterm2 = JConstant vl in (PreRelationalExpr (JNotEqual, jterm1, jterm2)) :: preds in - List.fold_left add_excluded_val [] vals + List.fold_left add_excluded_val [] vals let excluded_vals_to_summary_post_predicates - (arg_index:int) (vals:numerical_t list) = - let add_excluded_val preds vl = + (arg_index:int) (vals:numerical_t list) = + let add_excluded_val preds vl = let jterm1 = JLocalVar arg_index in let jterm2 = JConstant vl in (PostRelationalExpr (JNotEqual, jterm1, jterm2)) :: preds in - List.fold_left add_excluded_val [] vals - + List.fold_left add_excluded_val [] vals + let equality_to_summary_post_predicate - (arg_index1:int) (arg_index2:int) = + (arg_index1:int) (arg_index2:int) = let jterm1 = JLocalVar arg_index1 in let jterm2 = JLocalVar arg_index2 in PostRelationalExpr (JEquals, jterm1, jterm2) -let rec has_return_expr expr = - match expr with +let rec has_return_expr expr = + match expr with | JLocalVar (-1) -> true | JLocalVar _ - | JAuxiliaryVar _ + | JAuxiliaryVar _ | JLoopCounter _ | JSymbolicConstant _ | JConstant _ -> false @@ -186,52 +178,54 @@ let rec has_return_expr expr = | JStaticFieldValue _ -> false | JPower _ -> false | JUninterpreted _ -> false - -let has_return_pre_predicate (pred:precondition_predicate_t) = - match pred with + +let has_return_pre_predicate (pred:precondition_predicate_t) = + match pred with | PreRelationalExpr (_, t1, t2) -> has_return_expr t1 || has_return_expr t2 - | PreNull t + | PreNull t | PreNotNull t -> has_return_expr t | PreValidString (t, _) -> has_return_expr t -let pre_to_post_predicate (pred:precondition_predicate_t) = - match pred with +let pre_to_post_predicate (pred:precondition_predicate_t) = + match pred with | PreRelationalExpr (op, t1, t2) -> PostRelationalExpr (op, t1, t2) - | PreNull t -> PostNull - | PreNotNull t -> PostNotNull - | PreValidString (t, s) -> PostNull (* This is not processed further so it does not matter *) + | PreNull _ -> PostNull + | PreNotNull _ -> PostNotNull + | PreValidString _ -> PostNull (* This is not processed further so it does not matter *) -let post_predicate_to_relational_expr (post:postcondition_predicate_t) = - let rec jterm_to_expr term = term in - match post with +let post_predicate_to_relational_expr (post:postcondition_predicate_t) = + let jterm_to_expr term = term in + match post with | PostRelationalExpr (op, t1, t2) -> (op, jterm_to_expr t1, jterm_to_expr t2) | _ -> - pr__debug [STR "Analysis failed: programming error: "; - STR "post_predicate_to_relational_expr expected PostRelationalExpr"; NL] ; + pr__debug [ + STR "Analysis failed: programming error: "; + STR "post_predicate_to_relational_expr expected PostRelationalExpr"; NL]; raise (JCHAnalysisUtils.numeric_params#analysis_failed 3 "programming error: post_predicate_to_relational_expr expected PostRelationalExpr") -let var_to_abstract_side (map:(int * int) list) (ind:int) = +let var_to_abstract_side (map:(int * int) list) (ind:int) = let arg_ind = List.assoc ind map in let jterm = JLocalVar arg_ind in NumericAbstract jterm -let postcondition_predicate_to_pretty (p:postcondition_predicate_t) = - match p with +let postcondition_predicate_to_pretty (p:postcondition_predicate_t) = + match p with | PostRelationalExpr (op, t1, t2) -> - LBLOCK [ jterm_to_pretty t1 ; - STR (relational_op_to_string op) ; jterm_to_pretty t2 ] + LBLOCK [ + jterm_to_pretty t1; + STR (relational_op_to_string op); jterm_to_pretty t2] | PostTrue -> STR "post-true" | PostFalse -> STR "post-false" | PostNewObject cn -> LBLOCK [STR "new-object "; cn#toPretty] - | PostObjectClass cn -> LBLOCK [ STR "class-object" ; cn#toPretty ] + | PostObjectClass cn -> LBLOCK [STR "class-object"; cn#toPretty] | PostNull -> STR "post-null" | PostNotNull -> STR "post-not-null" - | PostElement t -> LBLOCK [STR "post "; jterm_to_pretty t] + | PostElement t -> LBLOCK [STR "post "; jterm_to_pretty t] | PostEmptyCollection -> STR "post-empty-collection" - | PostSameCollection t -> LBLOCK [STR "post-same "; jterm_to_pretty t] + | PostSameCollection t -> LBLOCK [STR "post-same "; jterm_to_pretty t] | PostWrapped t -> LBLOCK [STR "post-wrapped "; jterm_to_pretty t] | PostUnwrapped -> STR "post-unwrapped" | PostValidString s -> STR ("post-valid-string "^s) @@ -240,58 +234,59 @@ let get_loop_counter_bounds (rel_exprs:relational_expr_t list) (first_pc:int) = let lbounds = ref [] in let ubounds = ref [] in - - let rec get_bound (jterm:jterm_t) = - match jterm with - | JLoopCounter i -> + + let rec get_bound (jterm:jterm_t) = + match jterm with + | JLoopCounter i -> if i = first_pc then (Some numerical_one, None) else (None, Some jterm) - | JArithmeticExpr (JTimes, JLoopCounter i, JConstant num) - | JArithmeticExpr (JTimes, JConstant num, JLoopCounter i) -> + | JArithmeticExpr (JTimes, JLoopCounter i, JConstant num) + | JArithmeticExpr (JTimes, JConstant num, JLoopCounter i) -> if i = first_pc then (Some num, None) else (None, Some jterm) - | JArithmeticExpr (op, t1, t2) -> + | JArithmeticExpr (op, t1, t2) -> let (coeff_opt1, rest_opt1) = get_bound t1 in let (coeff_opt2, rest_opt2) = get_bound t2 in - let coeff_opt = - match (coeff_opt1, coeff_opt2) with - | (Some num, _) + let coeff_opt = + match (coeff_opt1, coeff_opt2) with + | (Some num, _) | (_, Some num) -> Some num | _ -> None in - let rest_opt = - match (rest_opt1, rest_opt2) with + let rest_opt = + match (rest_opt1, rest_opt2) with | (Some rest1, Some rest2) -> Some (JArithmeticExpr (op, rest1, rest2)) - | (Some rest, _) + | (Some rest, _) | (_, Some rest) -> Some rest | _ -> None in (coeff_opt, rest_opt) | _ -> (None, Some jterm) in - let rec change_signs jt = - match jt with - | JArithmeticExpr (JTimes, JConstant num, jt1) -> + let rec change_signs jt = + match jt with + | JArithmeticExpr (JTimes, JConstant num, jt1) -> let num_neg = num#neg in if num_neg#equal numerical_one then jt1 else JArithmeticExpr (JTimes, JConstant num_neg, jt1) | JArithmeticExpr (JDivide, jt, JConstant num) -> - JArithmeticExpr (JDivide, change_signs jt, JConstant num) - | JArithmeticExpr (op, t1, t2) -> JArithmeticExpr (op, change_signs t1, change_signs t2) + JArithmeticExpr (JDivide, change_signs jt, JConstant num) + | JArithmeticExpr (op, t1, t2) -> + JArithmeticExpr (op, change_signs t1, change_signs t2) | JConstant num -> JConstant num#neg | _ -> jt in let add_rel_expr re = - match re with + match re with | (JEquals, JLoopCounter i, jterm) -> if i = first_pc then begin - lbounds := jterm :: !lbounds ; + lbounds := jterm :: !lbounds; ubounds := jterm :: !ubounds end - | (JLessEqual, JLoopCounter i, jterm) -> + | (JLessEqual, JLoopCounter i, jterm) -> if i = first_pc then begin ubounds := jterm :: !ubounds @@ -300,11 +295,11 @@ let get_loop_counter_bounds if i = first_pc then begin lbounds := jterm :: !lbounds - end - | (JEquals, jterm, _) -> - let bound = - match get_bound jterm with - | (Some num, None) -> JConstant numerical_zero + end + | (JEquals, jterm, _) -> + let bound = + match get_bound jterm with + | (Some _, None) -> JConstant numerical_zero | (Some num, Some rest) -> let abs_num = num#abs in let bound = @@ -319,13 +314,13 @@ let get_loop_counter_bounds | _ -> raise (JCH_failure (STR "Error in add_rel_expr")) in begin - lbounds := bound :: !lbounds ; + lbounds := bound :: !lbounds; ubounds := bound :: !ubounds end - | (JGreaterEqual, jterm, _) -> (* from poly; assumes the second jterm = 0 *) + | (JGreaterEqual, jterm, _) -> (* from poly; assumes the second jterm = 0 *) begin match get_bound jterm with - | (Some num, None) -> + | (Some _, None) -> lbounds := (JConstant numerical_zero) :: !lbounds | (Some num, Some rest) -> let abs_num = num#abs in @@ -344,19 +339,19 @@ let get_loop_counter_bounds let add_rel_expr_no_exc re = try add_rel_expr re with _ -> () in begin - List.iter add_rel_expr_no_exc rel_exprs ; + List.iter add_rel_expr_no_exc rel_exprs; (!lbounds, !ubounds) end - + (* It assumes jterm is a sum of products *) -let get_bound target_jterm jterm = - let rec get_bound jterm = +let get_bound target_jterm jterm = + let rec get_bound jterm = match jterm with | JAuxiliaryVar _ | JSymbolicConstant _ | JLocalVar _ | JLoopCounter _ - | JSize _ -> + | JSize _ -> if jterm_compare jterm target_jterm = 0 then (Some numerical_one, None) else @@ -366,35 +361,35 @@ let get_bound target_jterm jterm = (Some num, None) else (None, Some jterm) - | JArithmeticExpr (op, t1, t2) -> + | JArithmeticExpr (op, t1, t2) -> let (coeff_opt1, rest_opt1) = get_bound t1 in let (coeff_opt2, rest_opt2) = get_bound t2 in - let coeff_opt = - match (coeff_opt1, coeff_opt2) with - | (Some num, _) + let coeff_opt = + match (coeff_opt1, coeff_opt2) with + | (Some num, _) | (_, Some num) -> Some num | _ -> None in - let rest_opt = - match (rest_opt1, rest_opt2) with + let rest_opt = + match (rest_opt1, rest_opt2) with | (Some rest1, Some rest2) -> Some (JArithmeticExpr (op, rest1, rest2)) - | (Some rest, _) + | (Some rest, _) | (_, Some rest) -> Some rest | _ -> None in (coeff_opt, rest_opt) (* TBA: JPower (t,n) ?? *) | _ -> (None, Some jterm) in - - match get_bound jterm with + + match get_bound jterm with | (Some num, None) -> if num#gt numerical_zero then (Some (JConstant numerical_zero), None) else (None, Some (JConstant numerical_zero)) - | (Some num, Some rest) -> - let rec change_signs jt = + | (Some num, Some rest) -> + let rec change_signs jt = match jt with (* TBA: JPower (t,n) ?? *) - | JArithmeticExpr (JTimes, JConstant num, jt1) -> + | JArithmeticExpr (JTimes, JConstant num, jt1) -> let num_neg = num#neg in if num_neg#equal numerical_one then jt1 @@ -404,7 +399,7 @@ let get_bound target_jterm jterm = JArithmeticExpr (op, change_signs t1, change_signs t2) | JConstant num -> JConstant num#neg | _ -> jt in - if num#gt numerical_zero then + if num#gt numerical_zero then let changed_rest = change_signs rest in if num#equal numerical_one then (Some changed_rest, None) @@ -416,37 +411,37 @@ let get_bound target_jterm jterm = else (None, Some (JArithmeticExpr (JDivide, rest, JConstant num#neg))) | _ -> (None, None) - -let get_bounds target_jterm rel_exprs = + +let _get_bounds target_jterm rel_exprs = let lbounds = ref [] in let ubounds = ref [] in let add_rel_expr re = - match re with + match re with | (JEquals, jterm1, jterm2) -> if jterm_compare jterm1 target_jterm = 0 then begin - lbounds := jterm2 :: !lbounds ; + lbounds := jterm2 :: !lbounds; ubounds := jterm2 :: !ubounds end else begin - match get_bound target_jterm jterm1 with (* from poly; assumes the second jterm = 0 *) - | (Some bound, _) + match get_bound target_jterm jterm1 with (* from poly; assumes the second jterm = 0 *) + | (Some bound, _) | (_, Some bound) -> - lbounds := bound :: !lbounds ; + lbounds := bound :: !lbounds; ubounds := bound :: !ubounds | _ -> () end | (JLessEqual, jterm1, jterm2) -> if jterm_compare jterm1 target_jterm = 0 then - ubounds := jterm2 :: !ubounds + ubounds := jterm2 :: !ubounds | (JGreaterEqual, jterm1, jterm2) -> (* from interval *) if jterm_compare jterm1 target_jterm = 0 then lbounds := jterm2 :: !lbounds - else (* from poly; assumes the second jterm = 0 *) + else (* from poly; assumes the second jterm = 0 *) begin - match get_bound target_jterm jterm2 with - | (Some bound, _) -> + match get_bound target_jterm jterm2 with + | (Some bound, _) -> lbounds := bound :: !lbounds | (_, Some bound) -> ubounds := bound :: !ubounds @@ -454,40 +449,40 @@ let get_bounds target_jterm rel_exprs = end | _ -> () in begin - List.iter add_rel_expr rel_exprs ; + List.iter add_rel_expr rel_exprs; (!lbounds, !ubounds) end - + (* Assumes linear jterm *) let rec negate_jterm jterm = match jterm with (* TBA: JPower (t,n) ?? *) | JConstant n -> JConstant n#neg | JArithmeticExpr (JTimes, JConstant c, jterm) -> - JArithmeticExpr (JTimes, JConstant c#neg, jterm) + JArithmeticExpr (JTimes, JConstant c#neg, jterm) | JArithmeticExpr (JTimes, jterm, JConstant c) -> JArithmeticExpr (JTimes, jterm, JConstant c#neg) - | JArithmeticExpr (JPlus, jterm1, jterm2) -> + | JArithmeticExpr (JPlus, jterm1, jterm2) -> JArithmeticExpr (JPlus, negate_jterm jterm1, negate_jterm jterm2) - | JArithmeticExpr (JMinus, jterm1, jterm2) -> + | JArithmeticExpr (JMinus, jterm1, jterm2) -> JArithmeticExpr (JMinus, negate_jterm jterm1, negate_jterm jterm2) - | JLocalVar _ + | JLocalVar _ | JAuxiliaryVar _ - | JSymbolicConstant _ - | JLoopCounter _ - | JSize _ -> + | JSymbolicConstant _ + | JLoopCounter _ + | JSize _ -> JArithmeticExpr (JTimes, JConstant (numerical_one#neg), jterm) | _ -> jterm -(* gets vars and length of vars *) +(* gets vars and length of vars *) let get_jterm_vars jterm = - let rec get_vars vars jterm = + let rec get_vars vars jterm = match jterm with - | JLocalVar _ + | JLocalVar _ | JAuxiliaryVar _ | JSymbolicConstant _ - | JLoopCounter _ + | JLoopCounter _ | JSize _ -> jterm :: vars | JArithmeticExpr (_, jterm1, jterm2) -> get_vars (get_vars vars jterm1) jterm2 @@ -500,30 +495,30 @@ let get_field_term (cmsix:int) (fInfo:field_info_int) = if fInfo#is_static then JStaticFieldValue (cnix, field_name) else - JObjectFieldValue (cmsix, -1, cnix, field_name) - - + JObjectFieldValue (cmsix, -1, cnix, field_name) + + let change_to_fields (cmsix:int) (var_to_field:(variable_t * field_info_int) list) - (post:postcondition_predicate_t) = + (post:postcondition_predicate_t) = let get_field_term str = let ind = int_of_string (String.sub str 4 ((String.length str) - 4)) in let is_var (var, _) = var#getIndex = ind in let (var, field_info) = List.find is_var var_to_field in let field_term = get_field_term cmsix field_info in - let term = + let term = if JCHSystemUtils.is_length var then JSize field_term else field_term in term in - let rec change_jterm jterm = + let rec change_jterm jterm = match jterm with | JAuxiliaryVar str -> begin try - get_field_term str + get_field_term str with _ -> jterm end | JSize jterm -> @@ -541,7 +536,7 @@ let change_to_fields | _ -> pred in change_post post - + let is_numeric (fInfo:field_info_int) = let cfs = fInfo#get_class_signature in @@ -556,13 +551,13 @@ let is_numeric (fInfo:field_info_int) = | TBasic Float | TBasic Double -> true | TBasic _ -> false - | TObject TClass cn -> + | TObject TClass cn -> begin - match cn#name with + match cn#name with | "java.lang.Integer" - | "java.lang.Short" + | "java.lang.Short" | "java.lang.Character" - | "java.lang.Byte" + | "java.lang.Byte" | "java.lang.Long" | "java.lang.Float" | "java.lang.Double" diff --git a/CodeHawk/CHJ/jchpoly/jCHNumericUtils.mli b/CodeHawk/CHJ/jchpoly/jCHNumericUtils.mli index 5b6d61f5..e908fbea 100644 --- a/CodeHawk/CHJ/jchpoly/jCHNumericUtils.mli +++ b/CodeHawk/CHJ/jchpoly/jCHNumericUtils.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -37,17 +38,17 @@ open JCHBasicTypesAPI (* jchpre *) open JCHPreAPI -val get_constants : - JCHProcInfo.jproc_info_t -> (int * numerical_t) list +val get_constants : + JCHProcInfo.jproc_info_t -> (int * numerical_t) list val mk_var_to_index : variable_t list -> (int * int) list val pp_var_to_index : (int * int) list -> pretty_t -val interval_to_summary_post_predicates : +val interval_to_summary_post_predicates : int -> interval_t -> interval_t -> postcondition_predicate_t list -val interval_to_summary_post_predicates2 : +val interval_to_summary_post_predicates2 : is_loc:bool -> is_lc:bool -> is_length:bool @@ -58,10 +59,10 @@ val interval_to_summary_post_predicates2 : -> interval:interval_t -> postcondition_predicate_t list -val excluded_vals_to_summary_pre_predicates : +val excluded_vals_to_summary_pre_predicates : int -> numerical_t list -> precondition_predicate_t list -val excluded_vals_to_summary_post_predicates : +val excluded_vals_to_summary_post_predicates : int -> numerical_t list -> postcondition_predicate_t list val equality_to_summary_post_predicate : int -> int -> postcondition_predicate_t @@ -70,7 +71,7 @@ val has_return_pre_predicate : precondition_predicate_t -> bool val pre_to_post_predicate : precondition_predicate_t -> postcondition_predicate_t - + val post_predicate_to_relational_expr : postcondition_predicate_t -> relational_expr_t diff --git a/CodeHawk/CHJ/jchpoly/jCHPoly.ml b/CodeHawk/CHJ/jchpoly/jCHPoly.ml index a78da657..1fefa13c 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPoly.ml +++ b/CodeHawk/CHJ/jchpoly/jCHPoly.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -30,7 +31,6 @@ open Big_int_Z (* chlib *) open CHBounds open CHIntervals -open CHLanguage open CHNumerical open CHPretty open CHUtils @@ -40,54 +40,48 @@ open CHPrettyUtil (* jchlib *) open JCHBasicTypes -open JCHBasicTypesAPI - -(* jchpre *) -open JCHPreAPI (* jchsys *) -open JCHSystemUtils open JCHPrintUtils (* jchpoly *) -open JCHNumericUtils open JCHLinearConstraint let dbg = ref false -let params = JCHAnalysisUtils.numeric_params +let params = JCHAnalysisUtils.numeric_params (* No projections, just removes the columns *) let remove_dimensions - (new_nvars:int) (m:big_int array array) unsorted_cs = + (new_nvars:int) (m:big_int array array) unsorted_cs = let new_ncols = succ new_nvars in let sorted_cs = List.sort compare unsorted_cs in - let remove_dim_a a new_a = - new_a.(new_nvars) <- a.(pred (Array.length a)) ; - let rec remove old_c new_c cs = - if new_c < new_nvars then - match cs with - | c :: rest_cs -> + let remove_dim_a a new_a = + new_a.(new_nvars) <- a.(pred (Array.length a)); + let rec remove old_c new_c cs = + if new_c < new_nvars then + match cs with + | c :: rest_cs -> if old_c = c then remove (succ old_c) new_c rest_cs - else + else begin - new_a.(new_c) <- a.(old_c) ; - remove (succ old_c) (succ new_c) cs + new_a.(new_c) <- a.(old_c); + remove (succ old_c) (succ new_c) cs end - | _ -> - new_a.(new_c) <- a.(old_c) ; + | _ -> + new_a.(new_c) <- a.(old_c); remove (succ old_c) (succ new_c) [] in remove 0 0 sorted_cs in let nrows = Array.length m in let new_m = Array.make_matrix nrows new_ncols zero_big_int in begin for i = 0 to pred nrows do - remove_dim_a m.(i) new_m.(i) - done ; + remove_dim_a m.(i) new_m.(i) + done; new_m end -let add_dims_and_embed (dimsup:int) (m:big_int array array) = +let add_dims_and_embed (dimsup:int) (m:big_int array array) = let nrows = Array.length m in if dimsup < 0 then raise (JCHAnalysisUtils.numeric_params#analysis_failed @@ -96,80 +90,81 @@ let add_dims_and_embed (dimsup:int) (m:big_int array array) = m else if nrows = 0 then m - else + else let ncols = Array.length m.(0) in let new_ncols = ncols + dimsup in let new_m = Array.make_matrix nrows new_ncols zero_big_int in begin - for i = 0 to pred nrows do + for i = 0 to pred nrows do let a = m.(i) in let new_a = new_m.(i) in - for j = 0 to ncols - 2 do - new_a.(j) <- a.(j) - done ; - new_a.(pred new_ncols) <- a.(pred ncols) - done ; + for j = 0 to ncols - 2 do + new_a.(j) <- a.(j) + done; + new_a.(pred new_ncols) <- a.(pred ncols) + done; new_m end -(* map is a list of (old_col, new_col) and the result switches the columns +(* map is a list of (old_col, new_col) and the result switches the columns * old_index with new_index *) -let remap_m nvars (map: (int * int) list) m = - let remap_a (a: big_int array) (new_a: big_int array) = - let change (old_i, new_i) = +let remap_m nvars (map: (int * int) list) m = + let remap_a (a: big_int array) (new_a: big_int array) = + let change (old_i, new_i) = new_a.(new_i) <- a.(old_i) in - List.iter change map ; + List.iter change map; new_a.(nvars) <- a.(nvars) in (* set the constant *) let nrows = Array.length m in let new_m = Array.make_matrix nrows (succ nvars) zero_big_int in begin for i = 0 to pred nrows do - remap_a m.(i) new_m.(i) ; - done ; + remap_a m.(i) new_m.(i); + done; new_m end - + (* remove last n variable columns. *) -let remove_last_cols_m n m = +let remove_last_cols_m n m = let nrows = Array.length m in if n = 0 || nrows = 0 then m - else + else let nvars = pred (Array.length m.(0)) in let new_nvars = nvars - n in let new_m = Array.make_matrix nrows (succ new_nvars) zero_big_int in begin - for i = 0 to pred nrows do + for i = 0 to pred nrows do let a = m.(i) in let new_a = new_m.(i) in - for j = 0 to pred new_nvars do - new_a.(j) <- a.(j) - done ; + for j = 0 to pred new_nvars do + new_a.(j) <- a.(j) + done; new_a.(new_nvars) <- a.(nvars) (* constant column *) - done ; + done; new_m end (* var = var + const *) (* Add (coeff of var) * (-const) to the constant *) -let increment_m m c const = +let increment_m m c const = let nrows = Array.length m in if nrows = 0 then m - else + else let ncols = Array.length m.(0) in let neg_const = minus_big_int const in let const_col = pred ncols in let new_m = Array.make_matrix nrows ncols zero_big_int in begin - for i = 0 to pred nrows do + for i = 0 to pred nrows do let a = m.(i) in - new_m.(i) <- Array.copy a ; + new_m.(i) <- Array.copy a; let coeff = a.(c) in - if not (eq_big_int coeff zero_big_int) then - let new_const = add_big_int (mult_big_int coeff neg_const) a.(const_col) in + if not (eq_big_int coeff zero_big_int) then + let new_const = + add_big_int (mult_big_int coeff neg_const) a.(const_col) in new_m.(i).(const_col) <- new_const - done ; + done; new_m end @@ -177,8 +172,8 @@ let increment_m m c const = let empty_matrix = Array.make_matrix 0 0 zero_big_int let poly_index = ref (-1) -let get_poly_index () = - incr poly_index ; +let get_poly_index () = + incr poly_index; !poly_index module ConstraintCollections = CHCollections.Make ( @@ -190,214 +185,215 @@ module ConstraintCollections = CHCollections.Make ( (* It keeps the size minimal by removing columns that are not used * The only exception when poly_inds is larger is for polys used in a call - * or in intermediate stages: after an augment operation, ... *) -class poly_t = - object (self: 'a) - - val bottom = false + * or in intermediate stages: after an augment operation, ... *) +class poly_t = + object (self: 'a) + + val bottom = false val top = true - (* list of indices used in poly, sorted from small_to large *) + (* list of indices used in poly, sorted from small_to large *) val poly_inds = [] - (* list of pairs of indices (poly column -> PolyIntervalArray index) ; sorted *) - val index_map = [] - val eq_matrix = empty_matrix + (* list of pairs of indices (poly column -> PolyIntervalArray index); sorted *) + val index_map = [] + val eq_matrix = empty_matrix val ineq_matrix = empty_matrix - val poly_ind = get_poly_index() + val poly_ind = get_poly_index() method is_bottom = bottom method is_top = top - method get_poly_inds = poly_inds + method get_poly_inds = poly_inds method get_index_map = index_map method get_eq_matrix = eq_matrix method get_ineq_matrix = ineq_matrix - method private get_poly_dim = List.length index_map - method private get_column ind = - try - fst (List.find (fun (_, j) -> j = ind) index_map) + method private get_poly_dim = List.length index_map + method private get_column ind = + try + fst (List.find (fun (_, j) -> j = ind) index_map) with Not_found -> raise (JCH_failure - (LBLOCK [ STR "Column " ; INT ind ; - STR " not found in JCHPoly.get_column" ])) - - method private is_in_poly ind = - let rec find is = - match is with - | i :: rest_is -> - if i < ind then find rest_is - else i = ind + (LBLOCK [STR "Column "; INT ind; + STR " not found in JCHPoly.get_column"])) + + method private is_in_poly ind = + let rec find is = + match is with + | i :: rest_is -> + if i < ind then find rest_is + else i = ind | [] -> false in find poly_inds - method mk_poly poly_inds index_map eq_m ineq_m = - {< poly_inds = poly_inds; - index_map = index_map ; - bottom = false ; top = false; - eq_matrix = eq_m ; ineq_matrix = ineq_m ; + method mk_poly poly_inds index_map eq_m ineq_m = + {< poly_inds = poly_inds; + index_map = index_map; + bottom = false; top = false; + eq_matrix = eq_m; ineq_matrix = ineq_m; poly_ind = get_poly_index() >} - method remove_trivial_ineqs = + method remove_trivial_ineqs = let constrs = self#get_constraints in let red_constrs = List.filter (fun c -> not c#is_0_geq_0) constrs in self#mk_poly_from_constraints false red_constrs - method copy = - {< eq_matrix = JCHArrayUtils.copy_m eq_matrix ; - ineq_matrix = JCHArrayUtils.copy_m ineq_matrix ; + method copy = + {< eq_matrix = JCHArrayUtils.copy_m eq_matrix; + ineq_matrix = JCHArrayUtils.copy_m ineq_matrix; poly_ind = get_poly_index() >} method clone = {< >} - method private _record_number_constraints constrs = - JCHAnalysisUtils.numeric_params#record_number_constraints (List.length constrs) + method private _record_number_constraints constrs = + JCHAnalysisUtils.numeric_params#record_number_constraints + (List.length constrs) - method get_constraints = - if top || bottom then [] + method get_constraints = + if top || bottom then [] else let constrs = (linear_constraints_of_matrix true eq_matrix) @ (linear_constraints_of_matrix false ineq_matrix) in - self#_record_number_constraints constrs ; + self#_record_number_constraints constrs; List.map (fun constr -> constr#remap index_map) constrs - method change_inds old_ind_to_new_ind = + method change_inds old_ind_to_new_ind = let new_index_map = List.map (fun (c,i) -> (c, List.assoc i old_ind_to_new_ind)) index_map in let new_poly_inds = List.sort compare (List.map snd new_index_map) in - {< poly_inds = new_poly_inds ; - index_map = new_index_map ; + {< poly_inds = new_poly_inds; + index_map = new_index_map; poly_ind = get_poly_index() >} - method mk_bottom = + method mk_bottom = {< bottom = true; top = false; poly_inds = []; index_map = []; - eq_matrix = empty_matrix ; - ineq_matrix = empty_matrix ; + eq_matrix = empty_matrix; + ineq_matrix = empty_matrix; poly_ind = get_poly_index() >} - method mk_top = + method mk_top = {< bottom = false; top = true; poly_inds = []; - index_map = []; - eq_matrix = empty_matrix ; - ineq_matrix = empty_matrix ; + index_map = []; + eq_matrix = empty_matrix; + ineq_matrix = empty_matrix; poly_ind = get_poly_index() >} - (* This is just for calls which have more variables than the ones with + (* This is just for calls which have more variables than the ones with * constraints in chpoly *) - method mk_top_large new_poly_inds new_index_map = + method mk_top_large new_poly_inds new_index_map = {< bottom = false; top = true; poly_inds = new_poly_inds; - index_map = new_index_map; - eq_matrix = empty_matrix ; - ineq_matrix = empty_matrix ; + index_map = new_index_map; + eq_matrix = empty_matrix; + ineq_matrix = empty_matrix; poly_ind = get_poly_index() >} method private mk_poly_ - new_poly_inds new_index_map new_eq_matrix new_ineq_matrix = + new_poly_inds new_index_map new_eq_matrix new_ineq_matrix = if List.length new_poly_inds <> List.length new_index_map then raise (JCHAnalysisUtils.numeric_params#analysis_failed - 2 "programming error: mk_top_large - index_map and poly_inds of different lengths") ; + 2 "programming error: mk_top_large - index_map and poly_inds of different lengths"); {< bottom = false; top = false; poly_inds = new_poly_inds; - index_map = new_index_map; - eq_matrix = new_eq_matrix ; - ineq_matrix = new_ineq_matrix ; + index_map = new_index_map; + eq_matrix = new_eq_matrix; + ineq_matrix = new_ineq_matrix; poly_ind = get_poly_index() >} - method private get_used_indices' (a: 'a) = + method private get_used_indices' (a: 'a) = let map = a#get_index_map in List.map snd map - method private get_poly_dim' (a: 'a) = + method private get_poly_dim' (a: 'a) = let map = a#get_index_map in - List.length map + List.length map - method private get_column_ index_map' ind = + method private get_column_ index_map' ind = try - fst (List.find (fun (_, j) -> j = ind) index_map') + fst (List.find (fun (_, j) -> j = ind) index_map') with Not_found -> raise (JCH_failure - (LBLOCK [ STR "Column " ; INT ind ; - STR " not found in JCHPoly.get_column" ])) + (LBLOCK [STR "Column "; INT ind; + STR " not found in JCHPoly.get_column"])) - method private make_index_map inds = + method private make_index_map inds = let inds = List.sort compare inds in let add_index_to_map (i, res) ind = (i + 1, (i, ind) :: res) in let (_, map) = List.fold_left add_index_to_map (0, []) inds in - List.rev map + List.rev map - method private get_used_indices_in_constrs constrs = + method private get_used_indices_in_constrs constrs = let used_indices = new IntCollections.set_t in - let add_constr constr = + let add_constr constr = used_indices#addList constr#get_used_indices in - List.iter add_constr constrs ; - used_indices#toList + List.iter add_constr constrs; + used_indices#toList (* used cols sorted *) - method private get_used_cols (a: 'a) = + method private get_used_cols (a: 'a) = let eq_m = a#get_eq_matrix in let ineq_m = a#get_ineq_matrix in let used_cols = new IntCollections.set_t in - let add_used_cols_a a = - for i = 0 to (Array.length a) - 2 do + let add_used_cols_a a = + for i = 0 to (Array.length a) - 2 do if not (eq_big_int a.(i) zero_big_int) then used_cols#add i done in - for i = 0 to pred (Array.length eq_m) do - add_used_cols_a eq_m.(i) - done ; - for i = 0 to pred (Array.length ineq_m) do - add_used_cols_a ineq_m.(i) - done ; + for i = 0 to pred (Array.length eq_m) do + add_used_cols_a eq_m.(i) + done; + for i = 0 to pred (Array.length ineq_m) do + add_used_cols_a ineq_m.(i) + done; List.sort compare used_cols#toList method is_used_ind ind = try let col = self#get_column ind in - try - for i = 0 to pred (Array.length eq_matrix) do + try + for i = 0 to pred (Array.length eq_matrix) do if not (eq_big_int eq_matrix.(i).(col) zero_big_int) then raise Exit - done ; - for i = 0 to pred (Array.length ineq_matrix) do + done; + for i = 0 to pred (Array.length ineq_matrix) do if not (eq_big_int ineq_matrix.(i).(col) zero_big_int) then raise Exit - done ; + done; false with Exit -> true with _ -> false - + (* It removes columns that are not used *) - method private reduce (a: 'a) = + method private reduce (a: 'a) = if a#is_bottom then a#mk_bottom else if a#is_top then a#mk_top - else - let used_cols = self#get_used_cols a in + else + let used_cols = self#get_used_cols a in let new_poly_inds = List.map (fun c -> List.assoc c a#get_index_map) used_cols in let new_poly_dim = List.length new_poly_inds in if new_poly_dim = self#get_poly_dim' a then a#clone - else - begin - let unused_cols = - let add_unused res (i,_) = + else + begin + let unused_cols = + let add_unused res (i,_) = if List.mem i used_cols then res else i :: res in - List.fold_left add_unused [] a#get_index_map + List.fold_left add_unused [] a#get_index_map in let new_index_map = self#make_index_map new_poly_inds in let new_eq_matrix = @@ -412,33 +408,33 @@ class poly_t = {< bottom = false; top = false; poly_inds = new_poly_inds; - index_map = new_index_map; + index_map = new_index_map; eq_matrix = new_eq_matrix; - ineq_matrix = new_ineq_matrix ; + ineq_matrix = new_ineq_matrix; poly_ind = get_poly_index() >} - end + end (* It adds columns to the handle - * These columns correspod to variables in the poly but which are not in + * These columns correspod to variables in the poly but which are not in * the handle * new_inds is a super-set of the used indices in index_map *) - method private augment new_poly_inds new_index_map (a: 'a) = + method private augment new_poly_inds new_index_map (a: 'a) = if a#is_bottom then a#mk_bottom - else - let res_dim = List.length new_index_map in + else + let res_dim = List.length new_index_map in let aindex_map = a#get_index_map in let adim = List.length aindex_map in let extra_dim = res_dim - adim in - let add_to_map (i, map) (new_col, index) = - try + let add_to_map (i, map) (new_col, index) = + try let old_col = self#get_column_ aindex_map index in (i, (old_col, new_col) :: map) with _ -> (i+1, (i, new_col) :: map) in let (_, map) = List.fold_left add_to_map (adim, []) new_index_map in let big_eq_matrix = add_dims_and_embed extra_dim a#get_eq_matrix in let big_ineq_matrix = add_dims_and_embed extra_dim a#get_ineq_matrix in - + let new_eq_matrix = remap_m res_dim map big_eq_matrix in let new_ineq_matrix = remap_m res_dim map big_ineq_matrix in {< bottom = false; @@ -446,94 +442,96 @@ class poly_t = poly_inds = new_poly_inds; index_map = new_index_map; eq_matrix = new_eq_matrix; - ineq_matrix = new_ineq_matrix ; + ineq_matrix = new_ineq_matrix; poly_ind = get_poly_index() >} (* inds1 and inds2 are sorted lists * It produces a sorted list *) - method private find_common_inds inds1 inds2 = - let rec add_ind res is1 is2 = - match (is1, is2) with - | (i1 :: rest_is1, i2 :: rest_is2) -> - if i1 = i2 then add_ind (i1 :: res) rest_is1 rest_is2 - else if i1 < i2 then add_ind (i1 :: res) rest_is1 is2 - else add_ind (i2 :: res) is1 rest_is2 + method private find_common_inds inds1 inds2 = + let rec add_ind res is1 is2 = + match (is1, is2) with + | (i1 :: rest_is1, i2 :: rest_is2) -> + if i1 = i2 then add_ind (i1 :: res) rest_is1 rest_is2 + else if i1 < i2 then add_ind (i1 :: res) rest_is1 is2 + else add_ind (i2 :: res) is1 rest_is2 | (i1 :: rest_is1, []) -> add_ind (i1 :: res) rest_is1 [] | ([], i2 :: rest_is2) -> add_ind (i2 :: res) [] rest_is2 | ([], []) -> List.rev res in add_ind [] inds1 inds2 - method private augment_both (s: 'a) (a: 'a) = + method private augment_both (s: 'a) (a: 'a) = let common_inds = - self#find_common_inds (self#get_used_indices' s) (self#get_used_indices' a) in + self#find_common_inds + (self#get_used_indices' s) (self#get_used_indices' a) in let new_index_map = self#make_index_map common_inds in let s_aug = self#augment common_inds new_index_map s in let a_aug = self#augment common_inds new_index_map a in - (common_inds, new_index_map, s_aug, a_aug) + (common_inds, new_index_map, s_aug, a_aug) - method private is_included_in a b = + method private is_included_in a b = let a_eqs = a#get_eq_matrix in let a_ineqs = a#get_ineq_matrix in let b_eqs = b#get_eq_matrix in let b_ineqs = b#get_ineq_matrix in try - for i = 0 to pred (Array.length b_eqs) do + for i = 0 to pred (Array.length b_eqs) do let res = JCHArrayUtils.implies_constraint a_eqs a_ineqs b_eqs.(i) true in if not (fst res) then raise Exit - done ; - for i = 0 to pred (Array.length b_ineqs) do - let res = JCHArrayUtils.implies_constraint a_eqs a_ineqs b_ineqs.(i) false in - if not (fst res) then + done; + for i = 0 to pred (Array.length b_ineqs) do + let res = + JCHArrayUtils.implies_constraint a_eqs a_ineqs b_ineqs.(i) false in + if not (fst res) then raise Exit - done ; + done; true - with _ -> false + with _ -> false - method equal (a: 'a) = - match (bottom, a#is_bottom, top, a#is_top) with + method equal (a: 'a) = + match (bottom, a#is_bottom, top, a#is_top) with | (true, true, _, _) -> true | (_, _, true, true) -> true - | (false, false, false, false) -> + | (false, false, false, false) -> let (_, _, s_aug, a_aug) = self#augment_both self a in - self#is_included_in s_aug a_aug && self#is_included_in a_aug s_aug + self#is_included_in s_aug a_aug && self#is_included_in a_aug s_aug | _ -> false - method leq (a: 'a) = - match (bottom, a#is_bottom, top, a#is_top) with + method leq (a: 'a) = + match (bottom, a#is_bottom, top, a#is_top) with | (true, _, _, _) -> true | (_, true, _, _) -> false | (_, _, _, true) -> true | (_, _, true, _) -> false - | _ -> + | _ -> let (_, _, s_aug, a_aug) = self#augment_both self a in self#is_included_in s_aug a_aug - method private minimize_ new_poly_inds new_index_map eq_m ineq_m = + method private minimize_ new_poly_inds new_index_map eq_m ineq_m = if Array.length eq_m = 0 && Array.length ineq_m = 0 then self#mk_top - else - match JCHArrayUtils.minimize_m eq_m ineq_m with - | Some (eq'_m, ineq'_m) -> + else + match JCHArrayUtils.minimize_m eq_m ineq_m with + | Some (eq'_m, ineq'_m) -> if Array.length eq'_m = 0 && Array.length ineq'_m = 0 then self#mk_top else {< bottom = false; top = false; poly_inds = new_poly_inds; - index_map = new_index_map; + index_map = new_index_map; eq_matrix = eq'_m; - ineq_matrix = ineq'_m ; + ineq_matrix = ineq'_m; poly_ind = get_poly_index() >} - | _ -> self#mk_bottom + | _ -> self#mk_bottom - method minimize = + method minimize = self#minimize_ poly_inds index_map eq_matrix ineq_matrix - method meet (a: 'a) : 'a = - match (bottom, a#is_bottom, top, a#is_top) with - | (true, _, _, _) - | (_, true, _, _) -> self#mk_bottom + method meet (a: 'a) : 'a = + match (bottom, a#is_bottom, top, a#is_top) with + | (true, _, _, _) + | (_, true, _, _) -> self#mk_bottom | (_, _, true, _) -> a#copy | (_, _, _, true) -> self#copy | _ -> @@ -542,12 +540,12 @@ class poly_t = let new_eq_m = Array.append s_aug#get_eq_matrix a_aug#get_eq_matrix in let new_ineq_m = Array.append s_aug#get_ineq_matrix a_aug#get_ineq_matrix in - self#minimize_ new_poly_inds new_index_map new_eq_m new_ineq_m + self#minimize_ new_poly_inds new_index_map new_eq_m new_ineq_m - method meet_simple (a: 'a) : 'a = - match (bottom, a#is_bottom, top, a#is_top) with - | (true, _, _, _) - | (_, true, _, _) -> self#mk_bottom + method meet_simple (a: 'a) : 'a = + match (bottom, a#is_bottom, top, a#is_top) with + | (true, _, _, _) + | (_, true, _, _) -> self#mk_bottom | (_, _, true, _) -> a#copy | (_, _, _, true) -> self#copy | _ -> @@ -559,11 +557,11 @@ class poly_t = {< bottom = false; top = false; poly_inds = new_poly_inds; - index_map = new_index_map; + index_map = new_index_map; eq_matrix = new_eq_m; - ineq_matrix = new_ineq_m ; + ineq_matrix = new_ineq_m; poly_ind = get_poly_index() - >} + >} method private join_same_vars (s_aug: 'a) (a_aug: 'a) = let (sbrays, surays, _) = @@ -579,41 +577,41 @@ class poly_t = let join_ineqs = JCHArrayUtils.remove_trivial_rows join_ineqs in (join_eqs, JCHArrayUtils.remove_trivial_rows join_ineqs) - method join (a: 'a) = - match (bottom, a#is_bottom, top, a#is_top) with + method join (a: 'a) = + match (bottom, a#is_bottom, top, a#is_top) with | (true, _, _, _) -> a#copy | (_, true, _, _) -> self#copy - | (_, _, true, _) + | (_, _, true, _) | (_, _, _, true) -> self#mk_top - | _ -> + | _ -> let (new_poly_inds, new_index_map, s_aug, a_aug) = self#augment_both self a in let (join_eqs, join_ineqs) = self#join_same_vars s_aug a_aug in if Array.length join_eqs = 0 && Array.length join_ineqs = 0 then - self#mk_top - else + self#mk_top + else let p = {< poly_inds = new_poly_inds; index_map = new_index_map; eq_matrix = join_eqs; - ineq_matrix = join_ineqs ; + ineq_matrix = join_ineqs; poly_ind = get_poly_index() >} in self#reduce p - method widening (a: 'a) = - match (bottom, a#is_bottom, top, a#is_top) with + method widening (a: 'a) = + match (bottom, a#is_bottom, top, a#is_top) with | (true, _, _, _) -> a#copy | (_, true, _, _) -> self#copy - | (_, _, true, _) + | (_, _, true, _) | (_, _, _, true) -> self#mk_top - | _ -> + | _ -> let (new_poly_inds, new_index_map, s_aug, a_aug) = self#augment_both self a in - + let (j_eqs, j_ineqs) = self#join_same_vars s_aug a_aug in if Array.length j_eqs = 0 && Array.length j_ineqs = 0 then - self#mk_top - else + self#mk_top + else begin let s_aug_eqs = s_aug#get_eq_matrix in let s_aug_ineqs = s_aug#get_ineq_matrix in @@ -621,88 +619,96 @@ class poly_t = let a_aug_ineqs = a_aug#get_ineq_matrix in let new_eqs = ref [] in let new_ineqs = ref [] in - let check_constraint is_eq eqs ineqs r c = + let check_constraint is_eq eqs ineqs _r c = let (implies, res_opt) = JCHArrayUtils.implies_constraint eqs ineqs c is_eq in - if not implies then + if not implies then begin - if JCHArrayUtils.has_row eqs c then + if JCHArrayUtils.has_row eqs c then begin let (eq_err, ineq_err) = Option.get res_opt in - pr__debug [STR "FOUND check_constraint problem with eqs: "; - pp_array_big_int c; STR " "; - INT (Array.length eqs + Array.length ineqs); NL; - pp_matrix_big_int eqs; NL; STR " result: "; NL; - pp_matrix_big_int eq_err; NL; - pp_matrix_big_int ineq_err; NL]; - JCHArrayUtils.implies_constraint_error eqs ineqs c is_eq - end - else if not is_eq && JCHArrayUtils.has_row ineqs c then + pr__debug [ + STR "FOUND check_constraint problem with eqs: "; + pp_array_big_int c; STR " "; + INT (Array.length eqs + Array.length ineqs); NL; + pp_matrix_big_int eqs; NL; STR " result: "; NL; + pp_matrix_big_int eq_err; NL; + pp_matrix_big_int ineq_err; NL]; + JCHArrayUtils.implies_constraint_error eqs ineqs c is_eq + end + else if not is_eq && JCHArrayUtils.has_row ineqs c then begin let (eq_err, ineq_err) = Option.get res_opt in - pr__debug [STR "FOUND check_constraint problem with ineqs: "; - pp_array_big_int c; STR " "; - INT (Array.length eqs + Array.length ineqs); NL; - pp_matrix_big_int ineqs; NL; - STR " result: "; NL; - pp_matrix_big_int eq_err; NL; - pp_matrix_big_int ineq_err; NL]; - JCHArrayUtils.implies_constraint_error eqs ineqs c is_eq - end ; - if is_eq then + pr__debug [ + STR "FOUND check_constraint problem with ineqs: "; + pp_array_big_int c; STR " "; + INT (Array.length eqs + Array.length ineqs); NL; + pp_matrix_big_int ineqs; NL; + STR " result: "; NL; + pp_matrix_big_int eq_err; NL; + pp_matrix_big_int ineq_err; NL]; + JCHArrayUtils.implies_constraint_error eqs ineqs c is_eq + end; + if is_eq then begin - if fst (JCHArrayUtils.implies_constraint eqs ineqs c false) then + if fst (JCHArrayUtils.implies_constraint + eqs ineqs c false) then begin new_ineqs := c :: !new_ineqs; end - else + else let neg_c = Array.map minus_big_int c in - if fst (JCHArrayUtils.implies_constraint eqs ineqs neg_c false) then + if fst (JCHArrayUtils.implies_constraint + eqs ineqs neg_c false) then begin - new_ineqs := neg_c :: !new_ineqs ; + new_ineqs := neg_c :: !new_ineqs; end end - end + end else begin if is_eq then new_eqs := c :: !new_eqs else new_ineqs := c :: !new_ineqs end in - Array.iteri (check_constraint true a_aug_eqs a_aug_ineqs) s_aug_eqs ; - Array.iteri (check_constraint false a_aug_eqs a_aug_ineqs) s_aug_ineqs; - if params#analysis_level > 1 then + Array.iteri (check_constraint true a_aug_eqs a_aug_ineqs) s_aug_eqs; + Array.iteri + (check_constraint false a_aug_eqs a_aug_ineqs) s_aug_ineqs; + if params#analysis_level > 1 then begin - Array.iteri (check_constraint true s_aug_eqs s_aug_ineqs) a_aug_eqs ; - Array.iteri (check_constraint false s_aug_eqs s_aug_ineqs) a_aug_ineqs; - end ; + Array.iteri + (check_constraint true s_aug_eqs s_aug_ineqs) a_aug_eqs; + Array.iteri + (check_constraint false s_aug_eqs s_aug_ineqs) a_aug_ineqs; + end; if !new_eqs = [] && !new_ineqs = [] then self#mk_top - else - let p = self#mk_poly - new_poly_inds - new_index_map - (Array.of_list !new_eqs) - (Array.of_list !new_ineqs) in - p#remove_duplicates#minimize ; + else + let p = + self#mk_poly + new_poly_inds + new_index_map + (Array.of_list !new_eqs) + (Array.of_list !new_ineqs) in + p#remove_duplicates#minimize; end - method narrowing (a: 'a) = + method narrowing (a: 'a) = self#meet a (* Reorders the columns of the handle to be consistent with the new order * map : old index -> new index *) - method remap_indices old_ind_to_new_ind = + method remap_indices old_ind_to_new_ind = if bottom || top then {< >} - else + else let changed_index_map = - (* old columns -> new index *) - List.map (fun (i, j) -> (i, List.assoc j old_ind_to_new_ind)) index_map in + (* old columns -> new index *) + List.map (fun (i, j) -> (i, List.assoc j old_ind_to_new_ind)) index_map in let new_poly_inds = List.sort compare (List.map snd changed_index_map) in (* new columns -> new index *) - let new_index_map = self#make_index_map new_poly_inds in + let new_index_map = self#make_index_map new_poly_inds in let get_new_col ind = self#get_column_ new_index_map ind in let old_to_new_map = - (* old column -> new column *) - List.map (fun (i, j) -> (i, get_new_col j)) changed_index_map in + (* old column -> new column *) + List.map (fun (i, j) -> (i, get_new_col j)) changed_index_map in let nvars = List.length index_map in let new_eq_matrix = remap_m nvars old_to_new_map eq_matrix in let new_ineq_matrix = remap_m nvars old_to_new_map ineq_matrix in @@ -715,8 +721,8 @@ class poly_t = (* row.(c) <> 0 *) - method private combine_eq m row c = - let lv1 = row.(c) in + method private combine_eq m row c = + let lv1 = row.(c) in let is_pos = gt_big_int lv1 zero_big_int in let combine_row coeff = not (eq_big_int coeff zero_big_int) in let new_m = JCHArrayUtils.copy_m m in @@ -724,36 +730,38 @@ class poly_t = begin for i = 0 to pred (Array.length m) do let lv2 = m.(i).(c) in - if combine_row lv2 then - for j = 0 to pred ncols do + if combine_row lv2 then + for j = 0 to pred ncols do if is_pos then new_m.(i).(j) <- - sub_big_int (mult_big_int lv1 m.(i).(j)) (mult_big_int lv2 row.(j)) + sub_big_int + (mult_big_int lv1 m.(i).(j)) (mult_big_int lv2 row.(j)) else new_m.(i).(j) <- - sub_big_int (mult_big_int lv2 row.(j)) (mult_big_int lv1 m.(i).(j)) ; - done ; - done ; + sub_big_int + (mult_big_int lv2 row.(j)) (mult_big_int lv1 m.(i).(j)); + done; + done; new_m end - method private project_out_col_eq m c = + method private project_out_col_eq m c = let rows = ref [] in - let rec proj m' = + let rec proj m' = let nrows = Array.length m' in if nrows = 0 then (!rows, m') - else + else begin let r = ref 0 in - while !r < nrows && eq_big_int m'.(!r).(c) zero_big_int do + while !r < nrows && eq_big_int m'.(!r).(c) zero_big_int do incr r - done ; + done; if !r = nrows then - (!rows, m') - else + (!rows, m') + else let row = m'.(!r) in - rows := row :: !rows ; + rows := row :: !rows; let new_m = self#combine_eq m' row c in let small_m = JCHArrayUtils.remove_row_m new_m !r in proj small_m @@ -761,27 +769,27 @@ class poly_t = proj m (* row.(c) <> 0 *) - method private combine_ineq m row c = - let lv1 = row.(c) in + method private combine_ineq m row c = + let lv1 = row.(c) in let is_pos = gt_big_int lv1 zero_big_int in - let combine_row coeff = + let combine_row coeff = if eq_big_int coeff zero_big_int then - false + false else (is_pos && lt_big_int coeff zero_big_int) || ((not is_pos) && gt_big_int coeff zero_big_int) in let ncols = Array.length row in let new_rows : big_int array list ref = ref [] in - for i = 0 to pred (Array.length m) do + for i = 0 to pred (Array.length m) do let r = m.(i) in - let lv2 = r.(c) in - if combine_row lv2 then + let lv2 = r.(c) in + if combine_row lv2 then begin let new_row = Array.make ncols zero_big_int in let non_zero_coeffs = ref 0 in try - for j = 0 to pred ncols do - let new_coeff = + for j = 0 to pred ncols do + let new_coeff = if is_pos then sub_big_int (mult_big_int lv1 r.(j)) (mult_big_int lv2 row.(j)) @@ -791,36 +799,37 @@ class poly_t = if not (eq_big_int new_coeff zero_big_int) then incr non_zero_coeffs; if (lt_big_int new_coeff params#max_poly_coefficient) - || j = pred ncols then + || j = pred ncols then new_row.(j) <- new_coeff else raise Exit - done ; + done; if !non_zero_coeffs > 2 - && ge_big_int new_row.(pred ncols) params#max_poly_coefficient then + && ge_big_int + new_row.(pred ncols) params#max_poly_coefficient then raise Exit; - new_rows := r :: new_row :: !new_rows ; + new_rows := r :: new_row :: !new_rows; with _ -> new_rows := r :: !new_rows end - else + else begin - new_rows := r :: !new_rows ; + new_rows := r :: !new_rows; end - done ; + done; JCHArrayUtils.remove_trivial_rows (Array.of_list !new_rows) - method private project_out_col_ineq m c = - let rec proj m' = + method private project_out_col_ineq m c = + let rec proj m' = let nrows = Array.length m' in - if nrows = 0 then m' - else + if nrows = 0 then m' + else begin let r = ref 0 in - while !r < nrows && eq_big_int m'.(!r).(c) zero_big_int do + while !r < nrows && eq_big_int m'.(!r).(c) zero_big_int do incr r - done ; + done; if !r = nrows then m' - else + else let row = m'.(!r) in let new_m' = self#combine_ineq (JCHArrayUtils.remove_row_m m' !r) row c in @@ -828,54 +837,55 @@ class poly_t = end in proj m - method private project_out_col (a: 'a) (c: int) = + method private project_out_col (a: 'a) (c: int) = let eq_m = a#get_eq_matrix in let ineq_m = a#get_ineq_matrix in let apoly_dim = List.length a#get_index_map in - let mk_poly eqs ineqs = + let mk_poly eqs ineqs = let constrs = (linear_constraints_of_matrix true eqs) @ (linear_constraints_of_matrix false ineqs) in let constrs' = List.sort_uniq (fun c1 c2 -> c1#compare c2) constrs in let (eqs', ineqs') = linear_constraints_to_matrices apoly_dim constrs' in self#mk_poly a#get_poly_inds a#get_index_map eqs' ineqs' in - match self#project_out_col_eq eq_m c with - | (r::rs, new_eq_m) -> + match self#project_out_col_eq eq_m c with + | (r :: _rs, new_eq_m) -> let new_ineq_m = self#combine_eq ineq_m r c in mk_poly new_eq_m new_ineq_m - | (_, new_eq_m) -> + | (_, new_eq_m) -> let new_ineq_m = self#project_out_col_ineq ineq_m c in mk_poly new_eq_m new_ineq_m (* Projects out indices inds and removes them *) - method project_out inds = + method project_out inds = if bottom then self#mk_bottom - else if top then self#mk_top - else - let add_used_col cs_to_remove (i, j) = + else if top then self#mk_top + else + let add_used_col cs_to_remove (i, j) = if List.mem j inds then i :: cs_to_remove else cs_to_remove in - let cs_to_remove = List.fold_left add_used_col [] index_map in - if cs_to_remove = [] then {< >} - else + let cs_to_remove = List.fold_left add_used_col [] index_map in + if cs_to_remove = [] then {< >} + else begin - let cs_to_remove = List.sort (fun i j -> compare j i) cs_to_remove in + let cs_to_remove = List.sort (fun i j -> compare j i) cs_to_remove in let old_dim = List.length poly_inds in let new_dim = old_dim - (List.length cs_to_remove) in let permutation = Array.make old_dim 0 in (* old col -> new col *) let old_col_to_new_col = ref [] in - let rec add_col new_index_map new_col extra_col old_col ind = + let rec add_col new_index_map new_col extra_col old_col ind = let largest_ind = snd (List.hd (List.rev index_map)) in - if ind > largest_ind then new_index_map + if ind > largest_ind then new_index_map else if List.mem ind inds then (* has to be projected out*) begin if List.mem ind poly_inds then (* has to be removed *) begin - permutation.(old_col) <- extra_col ; + permutation.(old_col) <- extra_col; old_col_to_new_col := - (old_col, extra_col) :: !old_col_to_new_col ; + (old_col, extra_col) :: !old_col_to_new_col; add_col - new_index_map new_col (succ extra_col) (succ old_col) (succ ind) + new_index_map + new_col (succ extra_col) (succ old_col) (succ ind) end else (* continue *) begin @@ -884,11 +894,13 @@ class poly_t = end else (* does not have to be removed *) begin - if List.mem ind poly_inds then + if List.mem ind poly_inds then begin - permutation.(old_col) <- new_col ; - old_col_to_new_col := (old_col, new_col) :: !old_col_to_new_col ; - add_col ((new_col, List.assoc old_col index_map) :: new_index_map) + permutation.(old_col) <- new_col; + old_col_to_new_col := + (old_col, new_col) :: !old_col_to_new_col; + add_col + ((new_col, List.assoc old_col index_map) :: new_index_map) (succ new_col) extra_col (succ old_col) (succ ind) end else @@ -910,25 +922,25 @@ class poly_t = let reduced_ineq_m = remove_last_cols_m number_cols_removed new_ineq_m in self#minimize_ - new_poly_inds new_index_map reduced_eq_m reduced_ineq_m + new_poly_inds new_index_map reduced_eq_m reduced_ineq_m end - (* Projects out the inds and then removes those inds by remapping *) + (* Projects out the inds and then removes those inds by remapping *) method project_out_and_remove inds = - if bottom || top then {< >} - else + if bottom || top then {< >} + else begin let poly = self#remove_trivial_ineqs in if poly#is_bottom || poly#is_top then poly - else + else begin let largest_ind = snd (List.hd (List.rev poly#get_index_map)) in - let rec add_to_map (old_ind, new_ind, map) = + let rec add_to_map (old_ind, new_ind, map) = if old_ind > largest_ind then - map + map else if List.mem old_ind inds then - add_to_map (old_ind+1, new_ind, map) + add_to_map (old_ind+1, new_ind, map) else add_to_map (old_ind+1, new_ind+1, (old_ind, new_ind) :: map) in let old_to_new_ind = add_to_map (0,0,[]) in @@ -936,82 +948,86 @@ class poly_t = end end - method add_constraints (constrs: linear_constraint_t list) = + method add_constraints (constrs: linear_constraint_t list) = if constrs = [] || bottom then {< >} - else + else begin let constr_used_inds = self#get_used_indices_in_constrs constrs in - let (new_poly_inds, new_index_map, big_poly) = - if top then + let (new_poly_inds, new_index_map, big_poly) = + if top then begin let new_index_map = self#make_index_map constr_used_inds in (constr_used_inds, new_index_map, self#mk_top_large constr_used_inds new_index_map) end - else + else begin - let common_inds = self#find_common_inds poly_inds constr_used_inds in + let common_inds = + self#find_common_inds poly_inds constr_used_inds in let new_index_map = self#make_index_map common_inds in let s_aug = self#augment common_inds new_index_map self in - (common_inds, new_index_map, s_aug) + (common_inds, new_index_map, s_aug) end in - let new_constrs = + let new_constrs = let rev_map = List.map (fun (i,j) -> (j,i)) new_index_map in List.map (fun c -> c#remap rev_map) constrs in let new_nvars = List.length new_poly_inds in - let (eq_m, ineq_m) = linear_constraints_to_matrices new_nvars new_constrs in + let (eq_m, ineq_m) = + linear_constraints_to_matrices new_nvars new_constrs in let new_eq_m = Array.append big_poly#get_eq_matrix eq_m in let new_ineq_m = Array.append big_poly#get_ineq_matrix ineq_m in (self#mk_poly new_poly_inds new_index_map new_eq_m new_ineq_m)#remove_duplicates - end + end - method remove_duplicates = + method remove_duplicates = let constrs = List.sort_uniq (fun c1 c2 -> c1#compare c2) self#get_constraints in self#mk_poly_from_constraints false constrs - method add_constrs_from_interval col (interval:interval_t) = + method add_constrs_from_interval col (interval:interval_t) = if bottom || interval#isTop then {< >} else if interval#isBottom then self#mk_bottom - else + else let constrs = mk_constraints_from_interval true col interval in - self#add_constraints constrs + self#add_constraints constrs (* constrs should not be an empty list here *) method mk_poly_from_constraints minimize constrs = let new_poly_inds = self#get_used_indices_in_constrs constrs in let new_index_map = self#make_index_map new_poly_inds in let new_poly_dim = List.length new_index_map in - let new_constrs = + let new_constrs = let rev_map = List.map (fun (i,j) -> (j,i)) new_index_map in List.map (fun c -> c#remap rev_map) constrs in - let (eq_m, ineq_m) = linear_constraints_to_matrices new_poly_dim new_constrs in + let (eq_m, ineq_m) = + linear_constraints_to_matrices new_poly_dim new_constrs in if minimize then - self#minimize_ new_poly_inds new_index_map eq_m ineq_m + self#minimize_ new_poly_inds new_index_map eq_m ineq_m else {< bottom = false; top = false; poly_inds = new_poly_inds; - index_map = new_index_map; + index_map = new_index_map; eq_matrix = eq_m; - ineq_matrix = ineq_m ; + ineq_matrix = ineq_m; poly_ind = get_poly_index() >} - method affine_image ind coeff pairs const (interval: CHIntervals.interval_t) = + method affine_image ind coeff pairs const (interval: CHIntervals.interval_t) = if bottom then {< >} - else + else let used_inds = List.sort compare (List.map fst pairs) in - if List.mem ind used_inds then (* This can only be the loop counter increment *) + if List.mem ind used_inds then + (* This can only be the loop counter increment *) begin if top then - self#mk_top + self#mk_top else - match pairs with - | [(_, _)] -> + match pairs with + | [(_, _)] -> let new_poly_inds = self#find_common_inds poly_inds (self#find_common_inds [ind] used_inds) in @@ -1023,28 +1039,28 @@ class poly_t = let new_eq_matrix = Array.copy s_aug#get_eq_matrix in let ineq_nrows = Array.length s_aug#get_ineq_matrix in let new_ineq_matrix = Array.copy s_aug#get_ineq_matrix in - let increment_a a = + let increment_a a = let c = a.(new_col) in - if not (eq_big_int coeff zero_big_int) then + if not (eq_big_int coeff zero_big_int) then a.(new_nvars) <- sub_big_int a.(new_nvars) (mult_big_int c const) in for i = 0 to pred eq_nrows do increment_a new_eq_matrix.(i) - done ; + done; for i = 0 to pred ineq_nrows do increment_a new_ineq_matrix.(i) - done ; + done; self#minimize_ - new_poly_inds new_index_map new_eq_matrix new_ineq_matrix - | _ -> + new_poly_inds new_index_map new_eq_matrix new_ineq_matrix + | _ -> raise (JCHAnalysisUtils.numeric_params#analysis_failed 2 "affine_image expected pairs = [(ind,coeff)]") end - else + else begin - let red_poly = + let red_poly = if top then - {< >} + {< >} else let interval_constraints = mk_constraints_from_interval true ind interval in @@ -1052,17 +1068,17 @@ class poly_t = big_poly#project_out [ind] in let all_pairs = (ind, minus_big_int coeff) :: pairs in let constr = new linear_constraint_t true all_pairs const in - red_poly#add_constraints [constr] + red_poly#add_constraints [constr] end (* var = var + const *) - method affine_increment ind const = + method affine_increment ind const = if bottom || top then {< >} - else if self#is_in_poly ind then + else if self#is_in_poly ind then let c = self#get_column ind in - {< eq_matrix = increment_m eq_matrix c const ; - ineq_matrix = increment_m ineq_matrix c const ; + {< eq_matrix = increment_m eq_matrix c const; + ineq_matrix = increment_m ineq_matrix c const; poly_ind = get_poly_index() >} else @@ -1072,78 +1088,78 @@ class poly_t = (* We can do better for the loop increment case *) method affine_preimage (ind:int) - (coeff: big_int) - (pairs: (int * big_int) list) - (const: big_int) = + (_coeff: big_int) + (_pairs: (int * big_int) list) + (_const: big_int) = self#project_out [ind] (* copies all the constraints on col1 to col2 as well *) - method copy_other_col_constrs ind1 ind2 = + method copy_other_col_constrs ind1 ind2 = if bottom || top then {< >} - else if List.exists (fun (_,j) -> j = ind1) index_map then + else if List.exists (fun (_,j) -> j = ind1) index_map then let new_poly_inds = List.sort compare (ind2 :: (List.map snd index_map)) in let new_index_map = self#make_index_map new_poly_inds in let s_aug = self#augment new_poly_inds new_index_map self in let new_col1 = self#get_column_ new_index_map ind1 in let new_col2 = self#get_column_ new_index_map ind2 in - let copy_col_m m = - let new_m = Array.copy m in + let copy_col_m m = + let new_m = Array.copy m in let copy_col_a a = a.(new_col2) <- a.(new_col1) in - for i = 0 to pred (Array.length new_m) do + for i = 0 to pred (Array.length new_m) do copy_col_a new_m.(i) - done ; + done; new_m in let new_eq_m = copy_col_m s_aug#get_eq_matrix in let new_ineq_m = copy_col_m s_aug#get_ineq_matrix in self#mk_poly_ new_poly_inds new_index_map new_eq_m new_ineq_m else {< >} - method get_interval ind = + method get_interval ind = if bottom then bottomInterval else if top then - topInterval - else if List.mem ind poly_inds then + topInterval + else if List.mem ind poly_inds then begin let other_inds = List.filter (fun i -> i <> ind) poly_inds in let red_poly = self#project_out other_inds in let red_eq_m = red_poly#get_eq_matrix in let red_ineq_m = red_poly#get_ineq_matrix in let interval = ref CHIntervals.topInterval in - let add_constr is_eq a = + let add_constr is_eq a = let coeff = a.(0) in let const = a.(1) in - if eq_big_int coeff zero_big_int then () - else + if eq_big_int coeff zero_big_int then () + else begin let c = mkNumerical_big (minus_big_int (div_big_int const coeff)) in - let c_int = + let c_int = if is_eq then - mkSingletonInterval c + mkSingletonInterval c else if gt_big_int coeff zero_big_int then - new interval_t (bound_of_num c) plus_inf_bound + new interval_t (bound_of_num c) plus_inf_bound else new interval_t minus_inf_bound (bound_of_num c) in interval := !interval#meet c_int end in for i = 0 to pred (Array.length red_eq_m) do add_constr true red_eq_m.(i) - done ; + done; for i = 0 to pred (Array.length red_ineq_m) do add_constr false red_ineq_m.(i) - done ; + done; !interval end - else CHIntervals.topInterval + else CHIntervals.topInterval - (* v = x * y and s = m / y + (* v = x * y and s = m / y * Adds v <= m or v >= m if y is positive or negative and * there is a relationship between x and s *) - method add_mult_constr v_ind x_ind s_ind m_ind_opt const_opt y_pos = + method add_mult_constr v_ind x_ind s_ind m_ind_opt const_opt y_pos = if bottom || top then {< >} - else + else begin let mk_var_geq_var ind1 ind2 = new linear_constraint_t @@ -1160,110 +1176,112 @@ class poly_t = self#mk_poly_from_constraints false [mk_var_geq_var x_ind s_ind] in let s_geq_x : 'a = self#mk_poly_from_constraints false [mk_var_geq_var s_ind x_ind] in - let add_leq ind1_opt ind2_opt const_opt = - let constrs = - match (ind1_opt, ind2_opt, const_opt) with + let add_leq ind1_opt ind2_opt const_opt = + let constrs = + match (ind1_opt, ind2_opt, const_opt) with | (Some ind1, Some ind2, _) -> [mk_var_geq_var ind2 ind1] | (Some ind1, None, Some const) -> [mk_const_geq_var ind1 const] | (None, Some ind2, Some const) -> [mk_var_geq_const ind2 const] | _ -> [] in self#add_constraints constrs in - if y_pos then - if self#is_included_in self s_geq_x then + if y_pos then + if self#is_included_in self s_geq_x then add_leq (Some v_ind) m_ind_opt const_opt else if self#is_included_in self x_geq_s then add_leq m_ind_opt (Some v_ind) const_opt else {< >} - else - if self#is_included_in self s_geq_x then + else + if self#is_included_in self s_geq_x then add_leq m_ind_opt (Some v_ind) const_opt - else if self#is_included_in self x_geq_s then + else if self#is_included_in self x_geq_s then add_leq (Some v_ind) m_ind_opt const_opt else {< >} end - method get_pair_combinations = + method get_pair_combinations = if self#is_top || self#is_bottom then [] - else + else begin let dim = List.length index_map in let all_constraints = ref [] in - for i = 0 to pred dim do + for i = 0 to pred dim do let proj_poly = self#project_out [i] in - if not proj_poly#is_top then + if not proj_poly#is_top then all_constraints := !all_constraints @ proj_poly#get_constraints done; !all_constraints end - - method to_string = + + method to_string = if bottom then "_|_" - else if top then - "T " ^ (String.concat "\n" (List.map (fun c -> c#to_string) self#get_constraints)) - else + else if top then + "T " + ^ (String.concat + "\n" (List.map (fun c -> c#to_string) self#get_constraints)) + else String.concat "\n" (List.map (fun c -> c#to_string) self#get_constraints) - method toPretty = + method toPretty = if bottom then STR "_|_" - else if top then - LBLOCK [STR "T " ; - STR "dim: " ; INT (self#get_poly_dim); NL; - STR "poly_inds: "; pp_list_int poly_inds; NL; - STR "index_map: "; pp_assoc_list_ints index_map; NL; - STR "eq_matrix: "; pp_matrix_big_int eq_matrix; NL; - STR "ineq_matrix: "; pp_matrix_big_int ineq_matrix; NL] + else if top then + LBLOCK [STR "T "; + STR "dim: "; INT (self#get_poly_dim); NL; + STR "poly_inds: "; pp_list_int poly_inds; NL; + STR "index_map: "; pp_assoc_list_ints index_map; NL; + STR "eq_matrix: "; pp_matrix_big_int eq_matrix; NL; + STR "ineq_matrix: "; pp_matrix_big_int ineq_matrix; NL] else - LBLOCK [INT poly_ind; STR " dim: " ; INT (self#get_poly_dim); NL; - STR "poly_inds: "; pp_list_int poly_inds; NL; - STR "index_map: "; pp_assoc_list_ints index_map; NL; - STR "eq_matrix: "; pp_matrix_big_int eq_matrix; NL; - STR "ineq_matrix: "; pp_matrix_big_int ineq_matrix; NL] + LBLOCK [INT poly_ind; STR " dim: "; INT (self#get_poly_dim); NL; + STR "poly_inds: "; pp_list_int poly_inds; NL; + STR "index_map: "; pp_assoc_list_ints index_map; NL; + STR "eq_matrix: "; pp_matrix_big_int eq_matrix; NL; + STR "ineq_matrix: "; pp_matrix_big_int ineq_matrix; NL] - method private get_used_in_list ls = - let rec add_to_list (res, ind) (map, ls) = - match (map, ls) with - | ((_, j) :: rest_map, l :: rest_ls) -> + method private get_used_in_list ls = + let rec add_to_list (res, ind) (map, ls) = + match (map, ls) with + | ((_, j) :: rest_map, l :: rest_ls) -> if j = ind then add_to_list (l :: res, ind+1) (rest_map, rest_ls) else add_to_list (res, ind + 1) (map, rest_ls) | _ -> List.rev res in - add_to_list ([], 0) (index_map, ls) - + add_to_list ([], 0) (index_map, ls) + - method restrict_number_constraints = + method restrict_number_constraints = if bottom || top then ({< >}, false) - else + else begin let constrs = self#get_constraints in let constrs = List.sort_uniq (fun c1 c2 -> c1#compare c2) constrs in let removed = ref false in let max_constr_pairs = List.map (fun c -> (c#get_max_and_nr_coeffs, c)) constrs in - let ordered_constrs = - let is_larger_constr ((m1,n1),c1) ((m2,n2),c2) = - match (c1#is_equality, c2#is_equality) with + let ordered_constrs = + let is_larger_constr ((m1,n1),c1) ((m2,n2),c2) = + match (c1#is_equality, c2#is_equality) with | (true, false) -> -1 | (false, true) -> 1 - | _ -> - if eq_big_int m1 m2 then n1 - n2 - else if gt_big_int m1 m2 then 1 + | _ -> + if eq_big_int m1 m2 then n1 - n2 + else if gt_big_int m1 m2 then 1 else (-1) in List.sort is_larger_constr max_constr_pairs in - let rec add_to_list (n, res) constrs = - match constrs with - | ((max, nr), constr) :: rest_constrs -> - let is_good constr = + let rec add_to_list (n, res) constrs = + match constrs with + | ((max, nr), constr) :: rest_constrs -> + let is_good constr = constr#is_equality || n < params#max_number_constraints_allowed && lt_big_int max params#max_poly_coefficient && nr <= params#max_number_vars_in_constraint_allowed in - if is_good constr then + if is_good constr then add_to_list (n+1, constr :: res) rest_constrs - else + else begin - removed := true ; + removed := true; res end | _ -> res in @@ -1277,45 +1295,46 @@ class poly_t = ({< >}, false) end - - method restrict_number_vars = + + method restrict_number_vars = if bottom || top then ({< >}, false) - else + else begin let removed = ref false in let good_constrs = new ConstraintCollections.set_t in let inds_in_bad_constrs = new CHUtils.IntCollections.set_t in - let add_constr is_self (p: 'a) = + let add_constr is_self (p: 'a) = let constrs = p#get_constraints in let max_constr_pairs = List.map (fun c -> (c#get_max_and_nr_coeffs, c)) constrs in - let add_to_list (((max, nr), constr):(big_int * int) * linear_constraint_t) = + let add_to_list + (((_max, nr), constr):(big_int * int) * linear_constraint_t) = if constr#is_const then () - else if nr <= params#max_number_vars_in_constraint_allowed then + else if nr <= params#max_number_vars_in_constraint_allowed then good_constrs#add constr - else if is_self then + else if is_self then let (pairs, _) = constr#get_pairs_const in begin - inds_in_bad_constrs#addList (List.map fst pairs) ; - removed := true + inds_in_bad_constrs#addList (List.map fst pairs); + removed := true end in List.iter add_to_list max_constr_pairs in - add_constr true self; + add_constr true self; let proj_ind ind = add_constr false (self#project_out [ind]) in - inds_in_bad_constrs#iter proj_ind ; - + inds_in_bad_constrs#iter proj_ind; + let reduced_constrs = new ConstraintCollections.set_t in - let remove_redundant_ineqs c = + let remove_redundant_ineqs c = if c#is_equality then - reduced_constrs#add c + reduced_constrs#add c else begin let (pairs, const) = c#get_pairs_const in let eq = new linear_constraint_t true pairs const in - if not (good_constrs#has eq) then reduced_constrs#add c + if not (good_constrs#has eq) then reduced_constrs#add c end in - good_constrs#iter remove_redundant_ineqs ; + good_constrs#iter remove_redundant_ineqs; if !removed then if reduced_constrs#isEmpty then (self#mk_top, true) @@ -1325,88 +1344,89 @@ class poly_t = (self#mk_poly_from_constraints false reduced_constrs#toList, false) end - method to_pretty vars = + method to_pretty vars = if bottom then STR "_|_" - else if top then + else if top then let vars_a = Array.of_list vars in LBLOCK [STR "T "; - STR "dim: " ; INT (self#get_poly_dim); NL; + STR "dim: "; INT (self#get_poly_dim); NL; STR "poly_inds: "; pp_list_int poly_inds; NL; STR "index_map: "; pp_assoc_list_ints index_map; NL; pretty_print_list self#get_constraints - (fun c -> LBLOCK [c#to_pretty vars_a; NL]) "" "" ""] + (fun c -> LBLOCK [c#to_pretty vars_a; NL]) "" "" ""] - else + else let vars_a = Array.of_list vars in - LBLOCK [INT poly_ind; STR " dim: " ; INT (self#get_poly_dim); NL; + LBLOCK [INT poly_ind; STR " dim: "; INT (self#get_poly_dim); NL; STR "poly_inds: "; pp_list_int poly_inds; NL; STR "index_map: "; pp_assoc_list_ints index_map; NL; pretty_print_list self#get_constraints - (fun c -> LBLOCK [c#to_pretty vars_a; NL]) "" "" ""] + (fun c -> LBLOCK [c#to_pretty vars_a; NL]) "" "" ""] end -let top_poly = new poly_t +let top_poly = new poly_t -let top_poly_large poly_inds = +let top_poly_large poly_inds = let sorted_inds = List.sort compare poly_inds in let add_index_to_map (i, res) ind = (i + 1, (i, ind) :: res) in let (_, map) = List.fold_left add_index_to_map (0, []) sorted_inds in let index_map = List.rev map in (new poly_t)#mk_top_large sorted_inds index_map -let bottom_poly = (new poly_t)#mk_bottom +let bottom_poly = (new poly_t)#mk_bottom -let mk_poly_from_constraints minimize (constrs: linear_constraint_t list) = +let mk_poly_from_constraints minimize (constrs: linear_constraint_t list) = if constrs = [] then - (new poly_t) + (new poly_t) else - (new poly_t)#mk_poly_from_constraints minimize constrs + (new poly_t)#mk_poly_from_constraints minimize constrs (* move simple ineqs from the poly into the interval array. * Also eliminate variables that are constant from the poly *) let move_simple_ineqs_to_intervals - (poly: poly_t) (interval_array:JCHIntervalArray.interval_array_t) = + (poly: poly_t) (interval_array:JCHIntervalArray.interval_array_t) = if poly#is_top || poly#is_bottom then (poly, interval_array) - else + else begin let const_vars = interval_array#get_singletons in - let constrs = - List.map (fun constr -> constr#replace_consts const_vars) poly#get_constraints in + let constrs = + List.map + (fun constr -> constr#replace_consts const_vars) poly#get_constraints in let restr_array = interval_array#copy in - let meet_interval (i: int) (interval: CHIntervals.interval_t) = - let int = restr_array#get i in - if int#isBottom then + let meet_interval (i: int) (interval: CHIntervals.interval_t) = + let int = restr_array#get i in + if int#isBottom then begin - restr_array#set i (interval#meet (restr_array#get_type_interval i)) ; + restr_array#set i (interval#meet (restr_array#get_type_interval i)); None end - else + else begin let new_interval = int#meet interval in - restr_array#set i new_interval ; - match (int#singleton, new_interval#singleton) with - | (None, Some n) -> Some (i, n#getNum) + restr_array#set i new_interval; + match (int#singleton, new_interval#singleton) with + | (None, Some n) -> Some (i, n#getNum) | _ -> None end in let rec move_constr (non_interval_constrs:linear_constraint_t list) - (not_seen_constrs: linear_constraint_t list) = - match not_seen_constrs with - | constr :: rest_not_seen_constrs -> + (not_seen_constrs: linear_constraint_t list) = + match not_seen_constrs with + | constr :: rest_not_seen_constrs -> if constr#get_used_indices = [] then move_constr non_interval_constrs rest_not_seen_constrs else begin - match constr#get_v_interval with - | Some (c, interval) -> + match constr#get_v_interval with + | Some (c, interval) -> begin - match meet_interval c interval with - | Some pair -> + match meet_interval c interval with + | Some pair -> let new_constrs = non_interval_constrs @ rest_not_seen_constrs in let new_constrs = @@ -1417,17 +1437,15 @@ let move_simple_ineqs_to_intervals | _ -> move_constr non_interval_constrs rest_not_seen_constrs end - | _ -> + | _ -> move_constr (constr :: non_interval_constrs) rest_not_seen_constrs end | [] -> non_interval_constrs in let restr_constrs = move_constr [] constrs in - let restr_poly = + let restr_poly = match restr_constrs with - | [] -> top_poly + | [] -> top_poly | _ -> mk_poly_from_constraints false restr_constrs in (restr_poly, restr_array) - end - - + end diff --git a/CodeHawk/CHJ/jchpoly/jCHPoly.mli b/CodeHawk/CHJ/jchpoly/jCHPoly.mli index 4706c517..f492be0b 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPoly.mli +++ b/CodeHawk/CHJ/jchpoly/jCHPoly.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -32,15 +33,13 @@ open CHIntervals open CHLanguage open CHPretty -(* jchpre *) -open JCHPreAPI class poly_t : object ('a) method add_constraints : JCHLinearConstraint.linear_constraint_t list -> 'a method add_constrs_from_interval : int -> interval_t -> 'a method add_mult_constr: - int -> int -> int -> int option -> big_int option -> bool -> 'a + int -> int -> int -> int option -> big_int option -> bool -> 'a method affine_increment : int -> big_int -> 'a method affine_image: int -> big_int -> (int * big_int) list -> big_int -> interval_t -> 'a @@ -51,7 +50,7 @@ class poly_t : method copy : 'a method copy_other_col_constrs : int -> int -> 'a method equal : 'a -> bool - method get_constraints : JCHLinearConstraint.linear_constraint_t list + method get_constraints : JCHLinearConstraint.linear_constraint_t list method get_eq_matrix : big_int array array method get_ineq_matrix : big_int array array method get_index_map : (int * int) list @@ -87,21 +86,20 @@ class poly_t : method restrict_number_vars : 'a * bool method toPretty : pretty_t method to_string : string - method to_pretty : variable_t list -> pretty_t + method to_pretty : variable_t list -> pretty_t method widening : 'a -> 'a end val bottom_poly : poly_t val top_poly : poly_t val top_poly_large : int list -> poly_t - + val mk_poly_from_constraints : bool -> JCHLinearConstraint.linear_constraint_t list -> poly_t - + val move_simple_ineqs_to_intervals : poly_t -> JCHIntervalArray.interval_array_t -> poly_t * JCHIntervalArray.interval_array_t val dbg : bool ref - diff --git a/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.ml b/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.ml index 607d8451..354eee90 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.ml +++ b/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.ml @@ -1,2262 +1,2277 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -open Big_int_Z - -(* chlib *) -open CHIntervals -open CHLanguage -open CHNonRelationalDomainValues -open CHNumerical -open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil - -(* jchlib *) -open JCHBasicTypes -open JCHBasicTypesAPI -open JCHDictionary - -(* jchpre *) -open JCHApplication -open JCHBytecodeLocation -open JCHPreAPI - -(* jchsys *) -open JCHGlobals -open JCHPrintUtils - -(* jchpoly *) -open JCHPoly -open JCHPolyIntervalArray - -exception JCH_no_return_proc of pretty_t - -let dbg = ref false -let params = JCHAnalysisUtils.numeric_params - -(* A way to get the private variables of poly_doamin_no_arrays_t *) -let st_poly_int_array_opt = ref None -let set_st_poly_int_array poly_int_array = - st_poly_int_array_opt := Some poly_int_array -let get_st_poly_int_array () = Option.get !st_poly_int_array_opt - -let st_bool_opt = ref None -let set_st_bool b = st_bool_opt := Some b -let get_st_bool () = Option.get !st_bool_opt - -let st_local_var_map = ref None -let set_st_local_var_map local_var_map = st_local_var_map := Some local_var_map -let get_st_local_var_map () = Option.get !st_local_var_map - -let st_local_var_invariants = ref None -let set_st_local_var_invariants local_var_invariants = - st_local_var_invariants:= Some local_var_invariants -let get_st_local_var_invariants () = Option.get !st_local_var_invariants - -let st_relational_exprs = ref None -let set_st_relational_exprs exprs = st_relational_exprs:= Some exprs -let get_st_relational_exprs () = Option.get !st_relational_exprs - -let st_poly_vars = ref None -let set_st_poly_vars vars = st_poly_vars:= Some vars -let get_st_poly_vars () = Option.get !st_poly_vars - -let instr_pc = ref (-1) -let set_instr_pc i = instr_pc := i - -let prev_pc_to_wto_pc = ref [] -let set_prev_pc_to_wto_pc ls = prev_pc_to_wto_pc := ls -let get_wto_pc prev_pc = - let rec find_wto_pc p = - try - List.assoc p !prev_pc_to_wto_pc - with _ -> - find_wto_pc (p + 1) in - find_wto_pc prev_pc - -let old_pc_to_join_poly_int_array = ref (new IntCollections.table_t) - -let get_old_join_poly_int_array prev_pc var_to_const poly_vars = - let pc = try List.assoc prev_pc !prev_pc_to_wto_pc with _ -> prev_pc in - match !old_pc_to_join_poly_int_array#get pc with - | Some set -> set - | _ -> top_poly_interval_array var_to_const poly_vars - -let pc_to_join_poly_int_array = ref (new IntCollections.table_t) - -let set_join_poly_int_array prev_pc poly_int_array = - let pc = try List.assoc prev_pc !prev_pc_to_wto_pc with _ -> prev_pc in - !pc_to_join_poly_int_array#set pc poly_int_array - -let old_pc_to_widening_poly_int_array = ref (new IntCollections.table_t) - -let get_old_widening_poly_int_array prev_pc var_to_const poly_vars = - if !dbg then - pr__debug [STR "get_old_widening_poly_int_array "; - INT prev_pc; NL; pp_assoc_list_ints !prev_pc_to_wto_pc; NL] ; - - let pc = get_wto_pc prev_pc in - match !old_pc_to_widening_poly_int_array#get pc with - | Some pia -> pia - | _ -> top_poly_interval_array var_to_const poly_vars - -let pc_to_widening_poly_int_array = ref (new IntCollections.table_t) - -let set_widening_poly_int_array prev_pc poly_int_array = - let pc = get_wto_pc prev_pc in - !pc_to_widening_poly_int_array#set pc poly_int_array - -let set_invs wto_pc_to_poly_int_array = - let add_wto wto_pc poly_int_array = - !old_pc_to_join_poly_int_array#set wto_pc poly_int_array ; - !old_pc_to_widening_poly_int_array#set wto_pc poly_int_array in - wto_pc_to_poly_int_array#iter add_wto - - -let pc_to_join_iteration = ref (new IntCollections.table_t) - -let increment_join_iteration () = - match !pc_to_join_iteration#get !instr_pc with - | Some n -> !pc_to_join_iteration#set !instr_pc (n#add numerical_one) - | _ -> !pc_to_join_iteration#set !instr_pc numerical_one - -let pc_to_widening_iteration = ref (new IntCollections.table_t) -let get_widening_iteration () = - match !pc_to_widening_iteration#get !instr_pc with - | Some n -> n#toInt - | _ -> 0 -let increment_widening_iteration () = - match !pc_to_widening_iteration#get !instr_pc with - | Some n -> !pc_to_widening_iteration#set !instr_pc (n#add numerical_one) - | _ -> !pc_to_widening_iteration#set !instr_pc numerical_one - -(* These are both numeric and symbolic *) -let reachables = ref (new VariableCollections.set_t) -let is_reachable var = !reachables#has var - -(* Symbolic params that might have been changed *) -let changed_sym_params = ref (new VariableCollections.set_t) -let get_changed_sym_params () = !changed_sym_params#toList - -let overflow = ref (new VariableCollections.set_t) -let underflow = ref (new VariableCollections.set_t) -let convert_overflow = ref (new VariableCollections.set_t) (* dst of conversion *) - -(* The result of a division with a possible 0 divisor *) -let div0 = ref (new VariableCollections.set_t) - -let add_overflow var = !overflow#add var -let add_underflow var = !underflow#add var -let add_convert_overflow dst = !convert_overflow#add dst -let add_reachable var = !reachables#add var -let add_div0 var = !div0#add var - -let in_bounds_vars = ref (new VariableCollections.set_t) -let out_of_bounds_vars = ref (new VariableCollections.set_t) -let no_info_bounds_vars = ref (new VariableCollections.set_t) - - -let record_array_access - (poly_int_array: JCHPolyIntervalArray.poly_interval_array_t) - array - index = () - -(* Used to project out variables that are not needed in very long states, - * such as in clinit that set arrays *) -let pc_to_last_read = ref (new IntCollections.table_t) - -(* Used to report truncations in casts of results of operations as over/underflow *) -let arith_casts = ref (new IntCollections.set_t) - -module FieldInfoCollections = CHCollections.Make ( - struct - type t = field_info_int - let compare f1 f2 = compare f1#get_index f2#get_index - let toPretty f = f#toPretty - end) - -(* Array and collection variables that were obtained as OpGetField - * They are needed to check if OpArrayStore or invoked methods do not change them *) -let variable_to_fields = ref (new VariableCollections.table_t) -let add_variable_to_field var iInfo = - let fInfo = iInfo#get_field_target in - match !variable_to_fields#get var with - | Some set -> set#add fInfo - | None -> - !variable_to_fields#set var (FieldInfoCollections.set_of_list [fInfo]) - -let reset_ref_vars - proc_name jproc_info consts reset_old_join_widening = - begin - overflow := new VariableCollections.set_t ; - underflow := new VariableCollections.set_t ; - convert_overflow := new VariableCollections.set_t ; - reachables := VariableCollections.set_of_list consts ; - changed_sym_params := new VariableCollections.set_t ; - div0 := new VariableCollections.set_t ; - variable_to_fields := new VariableCollections.table_t ; - instr_pc := (-1) ; - - old_pc_to_widening_poly_int_array := - if reset_old_join_widening then - new IntCollections.table_t - else - !pc_to_widening_poly_int_array ; - pc_to_widening_poly_int_array := new IntCollections.table_t ; - - pc_to_widening_iteration := new IntCollections.table_t ; - old_pc_to_join_poly_int_array := - if reset_old_join_widening then - new IntCollections.table_t - else - !pc_to_join_poly_int_array ; - pc_to_join_poly_int_array:= new IntCollections.table_t; - - let (table, set, div2div2quot) = - JCHCollectors.collect_lin_eqs_info proc_name jproc_info in - pc_to_last_read := table ; - arith_casts := set ; - div2div2quot - end - -let get_proc_info () = - let res = - (!in_bounds_vars, - !out_of_bounds_vars, - !no_info_bounds_vars, - !overflow, - !underflow, - !convert_overflow, - !reachables, - !div0) in - begin - in_bounds_vars := new VariableCollections.set_t ; - out_of_bounds_vars := new VariableCollections.set_t ; - no_info_bounds_vars := new VariableCollections.set_t ; - res - end - -let lost_info_table = new SymbolCollections.table_t - -let log_lost_info proc_name v local_var_map = - let v_table = - match lost_info_table#get proc_name with - | Some t -> t - | None -> - let t = new VariableCollections.table_t in - begin - lost_info_table#set proc_name t ; - t - end in - try - let (local_v, _) = List.find (fun (_, u) -> u#equal v) local_var_map in - let t = new IntCollections.table_t in - begin - t#set !instr_pc local_v; - v_table#set v t - end - with _ -> - v_table#set v (new IntCollections.table_t) - - -let unlog_lost_info proc_name v = - let v_table = - match lost_info_table#get proc_name with - | Some t -> t - | None -> - let t = new VariableCollections.table_t in - begin - lost_info_table#set proc_name t ; - t - end in - v_table#remove v - -let has_lost_info proc_name vs = - let v_table = - match lost_info_table#get proc_name with - | Some t -> t - | None -> - let t = new VariableCollections.table_t in - begin - lost_info_table#set proc_name t ; - t - end in - List.exists v_table#has vs - -let transfer_lost_info proc_name x y local_var_map = - if has_lost_info proc_name [x] then - begin - if not (JCHSystemUtils.is_constant y) then - log_lost_info proc_name y local_var_map - end - else if has_lost_info proc_name [y] then - if not (JCHSystemUtils.is_constant x) then - log_lost_info proc_name x local_var_map - - -let print_lost_info () = - let table = new SymbolCollections.table_t in - let add_proc ((proc_name, v_table): - symbol_t - * variable_t IntCollections.table_t VariableCollections.table_t) = - if not (v_table#size = 0) then - begin - let new_t = new VariableCollections.table_t in - table#set proc_name new_t ; - let add_var (v, pc_table) = - let add_local_v (pc, local_v) = - match new_t#get local_v with - | Some set -> set#add pc - | _ -> - new_t#set local_v (IntCollections.set_of_list [pc]) in - List.iter add_local_v pc_table#listOfPairs in - List.iter add_var v_table#listOfPairs - end in - List.iter add_proc lost_info_table#listOfPairs ; - - if !dbg then - pr__debug [STR "lost_info: "; NL; lost_info_table#toPretty; NL]; - - pr__debug [STR "lost_info: "; NL; table#toPretty; NL] - -(* A poly domain in which the constants are kept separately - * The variables are added and removed as needed - * The order of the variables is kept otherwise constant *) -class poly_int_domain_no_arrays_t - (jproc_info:JCHProcInfo.jproc_info_t) - (p_int_a:poly_interval_array_t) - ((orig_local_vs, local_v_map): variable_t list * (variable_t * variable_t) list) = -object (self: 'a) - - inherit ['a] CHCommunications.domain_downlink_t - - val proc_name = jproc_info#get_name - val cms = retrieve_cms jproc_info#get_name#getSeqNumber - val mInfo = app#get_method (retrieve_cms jproc_info#get_name#getSeqNumber) - - val poly_int_array = p_int_a - - val orig_local_vars = orig_local_vs - val phi_infos = - List.filter (fun info -> info#is_phi) (jproc_info#get_jvar_infos#listOfValues) - - (* original variable -> version variable at current pc *) - val local_var_map = local_v_map - - method mkBottom = - {< poly_int_array = bottom_poly_interval_array >} - - method isBottom = poly_int_array#is_bottom - - method mkEmpty = - {< poly_int_array = - poly_int_array#mk_empty (self#get_var_to_const) (self#get_poly_vars) >} - - method clone = - {< poly_int_array = poly_int_array#clone >} - - method isRelational = true - - method private reached_time_limit = - match params#check_time_limit with - | 0 -> false - | 1 -> - begin - pr__debug [STR " Reached constraint analysis time limit "; NL] ; - params#reset_analysis_failure_status; - true - end - | _ -> - begin - pr__debug [STR "Analysis failed: reached numeric analysis time limit "; NL] ; - raise (params#analysis_failed 3 "reached numeric analysis time limit ") - end - - method observer = - object - inherit CHDomainObserver.domain_observer_t - method getObservedVariables: variable_t list = poly_int_array#get_poly_vars - method getMatrix = None - method isTop = Some poly_int_array#is_top - method isBottom = Some poly_int_array#is_bottom - end - - method private get_poly_int_array (a: 'a) = - let _ = a#special "set_poly_int_array" [] in - get_st_poly_int_array () - - method private get_local_var_map (a: 'a) = - let _ = a#special "set_local_var_map" [] in - get_st_local_var_map () - - method private change_local_var_map (a: 'a) v w = - try (* For the case when v or w are not local variables *) - let alocal_var_map:(variable_t * variable_t) list = - self#get_local_var_map a in - let get_var_index var = - int_of_string (Str.string_after var#getName#getBaseName 1) in - let v_index = get_var_index v in - let alocal_v_map = - match List.partition - (fun (v1, v2) -> - v2#equal w && get_var_index v1 = v_index) alocal_var_map with - | ((orig_w, _) :: _, rest_local_var_map) -> - (orig_w, v) :: rest_local_var_map - | _ -> alocal_var_map in - {< poly_int_array = self#get_poly_int_array a; - local_var_map = alocal_v_map >} - with _ -> a - - method private get_var_to_const = poly_int_array#get_var_to_const - - method private is_const v = poly_int_array#is_const v - - method private get_const_val v = poly_int_array#get_const_val v - - method private get_const_val_n v = poly_int_array#get_const_val_n v - - method private get_poly_vars = poly_int_array#get_poly_vars - - method leq ?(variables: variable_t list option) (a: 'a) = - let res = - match (self#isBottom, a#isBottom) with - | (true, _) -> true - | (_, true) -> false - | _ -> - if not params#use_types && get_widening_iteration () < 2 then - false - else - begin - let s_poly_int_array = poly_int_array#move_simple_ineqs in - let a_poly_int_array = - (self#get_poly_int_array a)#move_simple_ineqs in - s_poly_int_array#leq a_poly_int_array - end in - res - - method equal (a: 'a) = - poly_int_array#equal (self#get_poly_int_array a) - - method meet ?(variables: variable_t list option) (a: 'a) = - match (self#isBottom, a#isBottom) with - | (false, false) -> {< poly_int_array = poly_int_array#meet false (self#get_poly_int_array a) >} - | _ -> self#mkBottom - - method private join_local_var_map (a: 'a) = - let alocal_var_map = self#get_local_var_map a in - let join_vars var_index v1 v2 = - try - let is_this_phi (phi_info: JCHVarInfo.jvar_info_t) = - let rvars = phi_info#get_read_vars in - if (List.hd phi_info#get_local_indices) = var_index then - (List.exists (fun v -> - v#equal v1) rvars) && (List.exists (fun v -> v#equal v2) rvars) - else false in - Some (List.find is_this_phi phi_infos)#get_variable - with _ -> - begin - let is_v_phi var1 var2 = - let var1_info = jproc_info#get_jvar_info var1 in - let rvars = var1_info#get_read_vars in - var1_info#is_phi && List.exists (fun v -> v#equal var2) rvars in - if is_v_phi v1 v2 then Some v1 - else if is_v_phi v2 v1 then Some v2 - else None - end in - let join_local_var_map = ref [] in - let add_var orig_var = - match (List.filter (fun (ov, _) -> ov#equal orig_var) local_var_map, - List.filter (fun (ov, _) -> ov#equal orig_var) alocal_var_map) with - | ((_, v1) :: _, (_, v2) :: _) -> - if v1#equal v2 then join_local_var_map := (orig_var, v1) :: !join_local_var_map - else - begin - let var_index = - int_of_string (Str.string_after orig_var#getName#getBaseName 1) in - match join_vars var_index v1 v2 with - | Some v -> join_local_var_map := (orig_var, v) :: !join_local_var_map - | _ -> () - end - | ((_, v) :: _, _) - | (_, (_, v) :: _) -> join_local_var_map := (orig_var, v) :: !join_local_var_map - | _ -> () in - List.iter add_var orig_local_vars ; - !join_local_var_map - - - method join ?(variables: variable_t list option) (a: 'a) = - let _ = - if !dbg then - pr__debug [STR "JCHPIDA.join "; INT (!instr_pc); STR " "; - INT (get_widening_iteration ()); NL; - self#toPretty; NL; a#toPretty; NL] in - - let join_res = - match (self#isBottom, a#isBottom) with - | (true, _) -> a#clone - | (_, true) -> {< >} - | _ -> - increment_join_iteration() ; - let s_poly_int_array = - let pia = - if params#use_loop_counters then - self - else - self#project_out_loop_counters self in - let pia = - if params#use_lengths then - pia - else - self#project_out_lengths pia in - (self#get_poly_int_array pia)#move_simple_ineqs in - let a_poly_int_array = - let pia = - if params#use_loop_counters then - a - else - self#project_out_loop_counters a in - let pia = - if params#use_lengths then - pia - else - self#project_out_lengths pia in - (self#get_poly_int_array pia)#move_simple_ineqs in - if self#reached_time_limit then - begin - let s_poly_int_array' = s_poly_int_array#drop_poly in - let a_poly_int_array' = a_poly_int_array#drop_poly in - params#set_use_intervals true ; - {< poly_int_array = s_poly_int_array'#join a_poly_int_array' ; - local_var_map = self#join_local_var_map a >} - end - else - begin - let old_poly_int_array = - get_old_join_poly_int_array - !instr_pc self#get_var_to_const self#get_poly_vars in - let jpoly_int_array = - s_poly_int_array#join_with_old a_poly_int_array old_poly_int_array in - set_join_poly_int_array !instr_pc jpoly_int_array; - let join_var_map = self#join_local_var_map a in - {< poly_int_array = jpoly_int_array ; - local_var_map = join_var_map >} - end ; - - in let _ = - if !dbg then - pr__debug [STR "join res = "; NL; join_res#toPretty; NL] in - join_res - - method widening ?(kind: string option) ?(variables: variable_t list option) (a: 'a) : 'a = - try - self#widening_ self a - with - | JCHAnalysisUtils.JCH_num_analysis_failure _ -> - if params#get_analysis_status = 1 then - begin - params#reset_analysis_failure_status; - self#widening_ - {< poly_int_array = poly_int_array#drop_poly >} - {< poly_int_array = (self#get_poly_int_array a)#drop_poly >} - end - else - raise - (params#analysis_failed - (params#get_analysis_status) (params#get_analysis_failure_reason)) - | _ -> - begin - pr__debug [STR "Analysis failed: unknown programming error in widening"; NL]; - raise (params#analysis_failed 3 "unknown programming error in widening") - end - - method private widening_ (s: 'a) (a: 'a) = - let _ = - if !dbg then - pr__debug [STR "widening_ "; INT (!instr_pc); STR " "; - INT (get_widening_iteration ()); NL; - s#toPretty; NL; a#toPretty; NL] in - let res : 'a = - match (s#isBottom, a#isBottom) with - | (true, _) -> a#clone - | (_, true) -> {< >} - | _ -> - let s_poly_int_array = self#get_poly_int_array s in - let a_poly_int_array = self#get_poly_int_array a in - let old_poly_int_array = - get_old_widening_poly_int_array - !instr_pc self#get_var_to_const self#get_poly_vars in - JCHPolyIntervalArray.set_local_vars (List.map snd local_var_map) ; - - let new_poly_int_array = - if self#reached_time_limit then - begin - if !dbg then pr__debug [STR "reached limit"; NL] ; - - params#set_use_intervals true ; - let old_poly_int_array = old_poly_int_array#drop_poly in - let s_poly_int_array = s_poly_int_array#drop_poly in - let a_poly_int_array = a_poly_int_array#drop_poly in - let w_poly_int_array = s_poly_int_array#widening a_poly_int_array in - w_poly_int_array#meet false old_poly_int_array - end - else - begin - let s_poly_int_array = - poly_int_array#move_simple_ineqs#meet true old_poly_int_array in - let a_poly_int_array = - a_poly_int_array#move_simple_ineqs#meet true old_poly_int_array in - let w_poly_int_array = s_poly_int_array#widening a_poly_int_array in - w_poly_int_array#meet false old_poly_int_array ; - end in - set_widening_poly_int_array !instr_pc new_poly_int_array ; - increment_widening_iteration () ; - {< poly_int_array = new_poly_int_array >} in - let _ = - if !dbg then - pr__debug [STR "widening_ res: " ; NL; res#toPretty; NL] in - res - - method narrowing ?(variables: variable_t list option) (a: 'a) = - if self#isBottom then - self#mkBottom - else {< >} - - method private record_changed_sym_params vars : unit = - let is_sym_param v = - let jvar_info = jproc_info#get_jvar_info v in - jvar_info#is_parameter && not v#isNumerical in - let changed_params = List.filter is_sym_param vars in - !changed_sym_params#addList changed_params - - method private copy_num_info (a: 'a) dst_var src_var = - let apoly_int_array = self#get_poly_int_array a in - {< poly_int_array = apoly_int_array#copy_num_info dst_var src_var >} - - method special (cmd: string) (args: domain_cmd_arg_t list) : 'a = - match cmd with - | "set_poly_int_array" -> - begin - set_st_poly_int_array poly_int_array; - {< >} - end - | "set_local_var_map" -> - begin - set_st_local_var_map local_var_map ; - {< >} - end - | "restrict_to_vars" -> - let add_var vs arg = - match arg with VAR_DOM_ARG v -> v :: vs | _ -> vs in - let restr_vars = List.fold_left add_var [] args in - {< poly_int_array = - poly_int_array#restrict_to_vars jproc_info (List.rev restr_vars) >} - | "get_vars_fields_rel_exprs" -> - let add_var vs arg = - match arg with VAR_DOM_ARG v -> v :: vs | _ -> vs in - let restr_vars = - VariableCollections.set_of_list (List.fold_left add_var [] args) in - let vars_with_fields = poly_int_array#get_vars_with_fields jproc_info in - set_st_poly_int_array poly_int_array ; - restr_vars#addList vars_with_fields ; - let restr_poly_int_array = - poly_int_array#restrict_to_vars jproc_info restr_vars#toList in - - if !dbg then - pr__debug [STR "get_vars_fields_rel_expres "; NL; - restr_poly_int_array#toPretty; NL] ; - - let restr_local_var_map = - List.filter (fun (v1, v2) -> v1#equal v2) local_var_map in - let postconds = - restr_poly_int_array#to_postconditions - true jproc_info restr_local_var_map vars_with_fields in - - if !dbg then - pr__debug [STR "postconds "; - pretty_print_list - postconds - JCHNumericUtils.postcondition_predicate_to_pretty - "{" "; " "}" ; NL]; - - let rel_exprs = - List.map JCHNumericUtils.post_predicate_to_relational_expr postconds in - set_st_relational_exprs rel_exprs ; - {< >} - - | "get_local_var_invariants" -> - let include_loop_counters = List.length args > 0 in - let postconds = - poly_int_array#to_postconditions - include_loop_counters jproc_info local_var_map [] in - let rel_exprs = - List.map JCHNumericUtils.post_predicate_to_relational_expr postconds in - begin - set_st_relational_exprs rel_exprs ; - {< >} - end - | "set_poly_vars" -> - begin - set_st_poly_vars poly_int_array#get_poly_vars; - {< >} - end - | "project_out_loop_counters" -> - let restr_poly_int_array = - self#get_poly_int_array (self#project_out_loop_counters self) in - {< poly_int_array = restr_poly_int_array#remove_duplicates >} - | "remove_duplicates" -> - {< poly_int_array = poly_int_array#remove_duplicates >} - | "drop_poly" -> - {< poly_int_array = poly_int_array#drop_poly >} - | _ -> - begin - pr__debug [ STR "Analysis faied: programming error: " ; - STR "poly domain - unrecognized command"; NL] ; - raise - (params#analysis_failed - 3 "programming error: poly domain - unrecognized command") - end - - method private project_out (vs:variable_t list) = - self#record_changed_sym_params vs ; - {< poly_int_array = poly_int_array#project_out vs >} - - method projectOut (vs:variable_t list) = - if self#isBottom then - {< >} - else - begin - List.iter add_reachable vs ; - - let poly_vars = poly_int_array#get_poly_vars in - let num_vs = List.filter (fun v -> List.mem v poly_vars) vs in - if num_vs = [] then - begin - self#record_changed_sym_params vs ; - {< >} - end - else - self#project_out num_vs - end - - method private remove (vs: variable_t list) = - if self#isBottom then - {< >} - else - begin - let poly_vars = poly_int_array#get_poly_vars in - let num_vs = List.filter (fun v -> List.mem v poly_vars) vs in - if num_vs = [] then - {< >} - else - begin - let new_poly_int_array = poly_int_array#project_out num_vs in - {< poly_int_array = new_poly_int_array#remove num_vs >} - end - end - - method private is_float v = - let info = jproc_info#get_jvar_info v in - JCHTypeUtils.can_be_float info#get_types - - (* We do not record division by 0 for Float or Double because it does not - * result in an arithmetic exception. - * It produces and infinite number or NaN *) - method private record_div0 div0_opt = - if params#use_types then - match div0_opt with - | Some v -> if not (self#is_float v) then add_div0 v - | _ -> - if !dbg then - pr__debug [proc_name#toPretty; STR " record_div0 not possible "; NL] ; - - method private record_overflow overflow_opt = - if params#use_types then - match overflow_opt with - | Some v -> - if not (JCHSystemUtils.is_loop_counter v) then - add_overflow v - else - pr__debug [STR "loop_counter has overflow"] - | _ -> () - - method private record_underflow underflow_opt = - if params#use_types then - match underflow_opt with - | Some v -> add_underflow v - | _ -> () - - method private record_down_cast_overflow pc_opt overflow_opt = - if params#use_types then - match (pc_opt, overflow_opt) with - | (Some pc, Some v) -> add_overflow v ; - | (None, Some v) -> add_convert_overflow v ; - | _ -> () - - method private record_down_cast_underflow pc_opt underflow_opt = - if params#use_types then - match (pc_opt, underflow_opt) with - | (Some pc, Some v) -> add_underflow v ; - | (None, Some v) -> add_convert_overflow v ; - | _ -> () - - method private affine_image report equality vpair pairs const = - let v = fst vpair in - add_reachable v; - - let (new_poly_int_array, overflow_opt, underflow_opt) = - poly_int_array#affine_image equality vpair pairs const in - if report then - begin - self#record_overflow overflow_opt ; - self#record_underflow underflow_opt - end ; - (if has_lost_info proc_name (List.map fst pairs) then - log_lost_info proc_name v local_var_map) ; - {< poly_int_array = new_poly_int_array >} - - (* v and w are different *) - method private affine_subst report v w_opt coeff const = - add_reachable v; - - let (new_poly_int_array, overflow_opt, underflow_opt) = - poly_int_array#affine_subst v w_opt coeff const in - if report then - begin - self#record_overflow overflow_opt ; - self#record_underflow underflow_opt - end ; - (match w_opt with - | Some w -> - if has_lost_info proc_name [w] then - log_lost_info proc_name v local_var_map - | _ -> ()) ; - {< poly_int_array = new_poly_int_array >} - - (* v = v + const *) - method private affine_increment report v const = - add_reachable v; - - let (new_poly_int_array, overflow_opt, underflow_opt) = - poly_int_array#affine_increment v const in - (if report then - begin - self#record_overflow overflow_opt ; - self#record_underflow underflow_opt - end) ; - {< poly_int_array = new_poly_int_array >} - - method private affine_image_down_cast - pc_opt equality vpair pairs const src dst dst_interval_opt = - let v = fst vpair in - add_reachable v ; - - let (new_poly_int_array, overflow_opt, underflow_opt) = - poly_int_array#affine_image equality vpair pairs const in - (if has_lost_info proc_name (List.map fst pairs) then - log_lost_info proc_name v local_var_map) ; - if Option.is_some overflow_opt || Option.is_some underflow_opt then - begin - self#record_down_cast_overflow pc_opt overflow_opt ; - self#record_down_cast_underflow pc_opt underflow_opt ; - {< poly_int_array = new_poly_int_array >} - end - else - begin - match dst_interval_opt with - | Some dst_interval -> - begin - let var = fst vpair in - let interval = new_poly_int_array#get_interval var in - if not (interval#leq dst_interval) then - begin - let new_poly_int_array = - new_poly_int_array#project_out [var] in - (if interval#getMax#gt dst_interval#getMax then - self#record_down_cast_overflow pc_opt (Some var)) ; - (if interval#getMin#lt dst_interval#getMin then - self#record_down_cast_underflow pc_opt (Some var)) ; - {< poly_int_array = new_poly_int_array >} - end - else - {< poly_int_array = new_poly_int_array >} - end - | _ -> {< poly_int_array = new_poly_int_array >} - end - - method private down_cast_float src dst = - add_reachable dst ; - - let (new_poly_int_array, is_overflow) = - poly_int_array#down_cast_float src dst in - (if is_overflow then add_convert_overflow dst) ; - {< poly_int_array = new_poly_int_array >} - - method private affine_preimage vpair pairs const = - {< poly_int_array = poly_int_array#affine_preimage vpair pairs const >} - - method getNonRelationalValue v = - let interval = poly_int_array#get_interval v in - mkIntervalValue interval - - method importNumericalConstraints - (csts: CHNumericalConstraints.numerical_constraint_t list) = - {< >} - - method importNonRelationalValues - ?(refine = true) - (pairs:(variable_t * non_relational_domain_value_t) list) = - {< >} - - val neg_unit_big_int = minus_big_int unit_big_int - - method private mult v x y = - add_reachable v ; - - let (new_poly_int_array, overflow_opt, underflow_opt, lost_info) = - poly_int_array#mult v x y in - self#record_overflow overflow_opt ; - self#record_underflow underflow_opt ; - (if lost_info then - log_lost_info proc_name v local_var_map - else - unlog_lost_info proc_name v) ; - {< poly_int_array = new_poly_int_array >} - - method private div v x y = - add_reachable v ; - - let is_float = self#is_float v in - let (new_poly_int_array, div0_opt, overflow_opt, underflow_opt) = - poly_int_array#div is_float v x y in - (if not is_float then - begin - self#record_div0 div0_opt ; - self#record_overflow overflow_opt ; - self#record_underflow underflow_opt ; - end) ; - {< poly_int_array = new_poly_int_array >} - - method private rem v x y = - add_reachable v ; - - let is_float = self#is_float v in - let (new_poly_int_array, div0_opt) = poly_int_array#rem is_float v x y in - (if not is_float then self#record_div0 div0_opt) ; - {< poly_int_array = new_poly_int_array >} - - method private update_fields new_poly_int_array var = - (match !variable_to_fields#get var with - | Some fields -> - begin - let int = new_poly_int_array#get_interval var in - match jproc_info#get_length var with - | Some length_var -> - let length_interval = new_poly_int_array#get_interval length_var in - fields#iter - (fun fi -> - JCHFields.int_field_manager#put_field - proc_name fi int [length_interval] true var) - | _ -> - fields#iter - (fun fi -> - JCHFields.int_field_manager#put_field proc_name fi int [] false var) - end - | None -> () ) - - method private project_out_fields var = - match !variable_to_fields#get var with - | Some fields -> fields#iter JCHFields.int_field_manager#project_out - | None -> () - - method private project_out_loop_counters (a: 'a) : 'a = - let apoly_int_array = self#get_poly_int_array a in - let loop_counters = - List.filter JCHSystemUtils.is_loop_counter apoly_int_array#get_poly_vars in - a#projectOut loop_counters - - method private project_out_lengths (a: 'a) : 'a = - let apoly_int_array = self#get_poly_int_array a in - let lengths = - List.filter JCHSystemUtils.is_length apoly_int_array#get_poly_vars in - a#projectOut lengths - - method analyzeBwd (cmd: (code_int, cfg_int) command_t) : 'a = - if self#isBottom then - match cmd with - | ASSERT e -> - self#mkEmpty#analyzeFwd (ASSERT (negate_bool_exp e)) - | _ -> - self#mkBottom - else - match cmd with - | ABSTRACT_VARS l -> - self#projectOut l - | ASSIGN_NUM (v, NUM n) -> - if self#is_const v then - self#clone - else - self#projectOut [v] - - | ASSIGN_NUM (v, NUM_VAR w) -> - if self#is_const v then - self#clone - else if v#equal w then - self#clone - else if self#is_const w then - self#projectOut [v] - else - self#affine_preimage - (v, unit_big_int) [(w, unit_big_int)] zero_big_int - - | ASSIGN_NUM (v, PLUS (x, y)) -> - if self#is_const x then - if self#is_const y then - self#projectOut [v] - else - self#affine_preimage - (v,unit_big_int) [(y,unit_big_int)] (self#get_const_val x) - else - if self#is_const y then - self#affine_preimage - (v,unit_big_int) [(x,unit_big_int)] (self#get_const_val y) - else - self#affine_preimage - (v,unit_big_int) [(x,unit_big_int); (y,unit_big_int)] zero_big_int - - | ASSIGN_NUM (v, MINUS (x, y)) -> - if self#is_const x then - if self#is_const y then - self#projectOut [v] - else - self#affine_preimage - (v,unit_big_int) [(y, neg_unit_big_int)] (self#get_const_val x) - else - if self#is_const y then - self#affine_preimage - (v, unit_big_int) [(x,unit_big_int)] (minus_big_int (self#get_const_val y)) - else - self#affine_preimage - (v,unit_big_int) [(x,unit_big_int); (y, neg_unit_big_int)] zero_big_int - - | ASSIGN_NUM (v, MULT (x,y)) -> - if self#is_const x then - if self#is_const y then - self#projectOut [v] - else - self#affine_preimage - (v,unit_big_int) [(y,self#get_const_val x)] zero_big_int - else - if self#is_const y then - self#affine_preimage - (v,unit_big_int) [(x,self#get_const_val y)] zero_big_int - else - self#projectOut [v] - - | ASSIGN_NUM (v, DIV (x, y)) -> self#projectOut [v] - | INCREMENT (v, n) -> self#analyzeFwd (INCREMENT (v, n#neg)) - | ASSERT TRUE -> self#clone - | ASSERT FALSE -> self#mkBottom - | ASSERT _ -> self#analyzeFwd cmd - | _ -> self#clone - - method analyzeFwd (cmd: (code_int, cfg_int) command_t) : 'a = - - let _ = - if !dbg then - pr__debug [STR "PolyDom.analyzeFwd "; - command_to_pretty 0 cmd; NL; self#to_pretty; NL] in - try - self#analyzeFwd_ cmd - with - | JCHAnalysisUtils.JCH_num_analysis_failure _ -> - if params#get_analysis_status = 1 then - begin - params#reset_analysis_failure_status; - ({< poly_int_array = poly_int_array#drop_poly >})#analyzeFwd cmd - end - else - raise - (params#analysis_failed - (params#get_analysis_status) (params#get_analysis_failure_reason)) - | _ -> - begin - pr__debug [STR "Analysis failed:unknown programming error in analyzeFwd"; NL] ; - raise (params#analysis_failed 3 "unknown programming error in analyzeFwd") - end - - method private analyzeFwd_ (cmd: (code_int, cfg_int) command_t) : 'a = - - let _ = - if !dbg then - pr__debug [STR "PolyDom.analyzeFwd_ "; command_to_pretty 0 cmd; NL; - self#to_pretty; NL] in - - let res = - let default () = {< >} in - let default_v v = - add_reachable v ; - {< >} in - if self#reached_time_limit then - begin - params#set_use_intervals true ; - let a = {< poly_int_array = poly_int_array#drop_poly >} in - a#analyzeFwd cmd - end - else if self#isBottom then - self#mkBottom - else - match cmd with - | ABSTRACT_VARS l -> - List.iter add_reachable l ; - let poly_vars = self#get_poly_vars in - let red_l = List.filter (fun v -> List.mem v poly_vars) l in - self#projectOut red_l - - | ASSIGN_NUM (v, NUM n) -> - if self#is_const v then - default_v v - else - self#affine_subst false v None zero_big_int n#getNum - - | ASSIGN_NUM (v, NUM_VAR w) -> - begin - let a = - if self#is_const v then - default_v v - else if self#is_const w then - self#affine_subst - false v None zero_big_int (self#get_const_val w) - else - self#affine_subst false v (Some w) unit_big_int zero_big_int in - let b = - if JCHSystemUtils.is_length w then - let pia = self#get_poly_int_array a in - {< poly_int_array = pia#transfer_fields true w v >} - else - a in - self#change_local_var_map b v w - end - - | ASSIGN_NUM (v, PLUS (x, y)) -> - if self#is_const x then - if self#is_const y then - let n = add_big_int (self#get_const_val x) (self#get_const_val y) in - self#affine_subst true v None zero_big_int n - else if v#equal y then - self#affine_increment true v (self#get_const_val x) - else - self#affine_subst - true v (Some y) unit_big_int (self#get_const_val x) - else if self#is_const y then - if v#equal x then - self#affine_increment true v (self#get_const_val y) - else - self#affine_subst - true - v - (Some x) - unit_big_int - (self#get_const_val y) - else - self#affine_image - true - None - (v, unit_big_int) - [(x, unit_big_int); (y, unit_big_int)] - zero_big_int - - | ASSIGN_NUM (v, MINUS (x, y)) -> - if self#is_const x then - if self#is_const y then - let n = - add_big_int - (self#get_const_val x) (minus_big_int (self#get_const_val y)) in - self#affine_subst true v None zero_big_int n - else if v#equal y then - self#affine_image - true - None - (v, unit_big_int) - [(y, neg_unit_big_int)] - (self#get_const_val x) - else - self#affine_subst - true v (Some y) neg_unit_big_int (self#get_const_val x) - else if self#is_const y then - let n = minus_big_int (self#get_const_val y) in - if v#equal x then - self#affine_increment true v n - else - self#affine_subst true v (Some x) unit_big_int n - else - self#affine_image - true - None - (v, unit_big_int) - [(x, unit_big_int); (y, neg_unit_big_int)] - zero_big_int - - | ASSIGN_NUM (v, MULT (x, y)) -> - if self#is_const x then - if self#is_const y then - let n = mult_big_int (self#get_const_val x) (self#get_const_val y) in - self#affine_subst true v None zero_big_int n - else if v#equal y then - self#affine_image - true - None - (v, unit_big_int) - [(y, self#get_const_val x)] - zero_big_int - else - self#affine_subst - true v (Some y) (self#get_const_val x) zero_big_int - else if self#is_const y then - if v#equal x then - self#affine_image - true - None - (v, unit_big_int) - [(x, self#get_const_val y)] - zero_big_int - else - self#affine_subst true v (Some x) (self#get_const_val y) zero_big_int - else self#mult v x y - - | ASSIGN_NUM (v, DIV (x, y)) -> self#div v x y - | INCREMENT (v, n) -> self#affine_increment true v n#getNum - | ASSERT TRUE -> default () - | ASSERT FALSE -> self#mkBottom - - | ASSERT (EQ (x, y)) -> - if JCHAnalysisUtils.is_numeric - jproc_info x && JCHAnalysisUtils.is_numeric jproc_info y then - begin - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_eq x y >} - end - else default () - - | ASSERT (GEQ (x, y)) -> - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_geq x y >} - | ASSERT (GT (x, y)) -> - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_gt x y >} - | ASSERT (LEQ (x, y)) -> - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_geq y x >} - | ASSERT (LT (x, y)) -> - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_gt y x >} - | ASSERT (NEQ (x, y)) -> - transfer_lost_info proc_name x y local_var_map; - {< poly_int_array = poly_int_array#assert_neq x y >} - | DOMAIN_OPERATION (doms, op) -> - if List.mem poly_dom_name doms then - begin - let pid = - self#analyzeOperation - ~domain_name:poly_dom_name - ~fwd_direction:true - ~operation:op in - pid - end - else - default () - - | ASSIGN_SYM (v, SYM_VAR w) -> - let a = - if JCHAnalysisUtils.is_numeric jproc_info v then - if JCHAnalysisUtils.is_numeric jproc_info w then - self#affine_subst false v (Some w) unit_big_int zero_big_int - else self#projectOut [v] - else default_v v in - self#change_local_var_map a v w - - | ASSIGN_SYM (v, _) - | ASSIGN_STRUCT (v, _) -> - default_v v - | _ -> - default () in - let _ = - if !dbg then - pr__debug [STR "after PolyDom.analyzeFwd_ res"; NL; res#toPretty; NL] in - res - - method private to_pretty = - LBLOCK [ STR "poly_int_domain: "; - (if params#use_intervals then STR "use intervals " else STR ""); NL; - INDENT (5, poly_int_array#to_pretty); NL ] - - method toPretty = self#to_pretty - - method analyzeFwdInTransaction = self#analyzeFwd - - method analyzeBwdInTransaction = self#analyzeBwd - - method private invoke_with_target - (is_static:bool) - (iInfo:instruction_info_int) - args - num_wvars - num_rvars - coll_rvars - all_wvars:'a = - - if !dbg then - pr__debug [STR "invoke_with_target "; NL; iInfo#toPretty; NL] ; - - let other_lengths = - let all_wvars_lengths = - let ls = ref [] in - let add_length v = - match jproc_info#get_length v with - | Some l -> ls := l :: !ls - | _ -> () in - List.iter add_length all_wvars ; - List.rev !ls in - List.filter (fun v -> not (List.mem v all_wvars)) all_wvars_lengths in - - (if !dbg then - pr__debug [STR "other_lengths = "; pp_list other_lengths; NL]) ; - - let invoke_unknown () = - List.iter self#project_out_fields coll_rvars ; - self#project_out (all_wvars @ other_lengths) in - - let mtarget = iInfo#get_method_target () in - if mtarget#is_top then - invoke_unknown () - else if mtarget#is_top then - begin - List.iter self#project_out_fields coll_rvars ; - self#project_out (all_wvars @ other_lengths) - end - else - begin - let procs = - List.filter (fun p -> - not (JCHSystem.jsystem#not_analyzed p#getSeqNumber)) mtarget#get_procs in - let stubs = mtarget#get_stubs in - - let _ = if !dbg then pr__debug [STR "procs = "; pp_list procs; NL] in - let _ = if !dbg then pr__debug [STR "stubs = "; pp_list stubs; NL] in - - (* record the call so that we know the context in which we have to analyze - * the callee *) - if procs <> [] then - begin - let record_call invoked_proc_name = - let (sig_vars, sig_lengths, length_to_var) = - JCHIntStubs.int_stub_manager#get_all_call_vars invoked_proc_name in - - (if !dbg then pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]) ; - (if !dbg then pr__debug [STR "sig_lengths = "; pp_list sig_lengths; NL]) ; - (if !dbg then - pr__debug [STR "sig_vars_with_lengths = "; - pp_list (length_to_var#listOfValues); NL]) ; - - let (invoked_args, sig_lengths_not_included, missing_length_inds) = - JCHAnalysisUtils.include_all_length_vars - jproc_info (JCHSystemUtils.get_read_vars args) sig_vars length_to_var in - - (if !dbg then - pr__debug [STR "invoked_args = "; pp_list invoked_args; NL]) ; - - let call_poly_int_array = - poly_int_array#get_call jproc_info invoked_args in - - (if !dbg then - pr__debug [STR "record_call call_poly_int_array = "; NL; - call_poly_int_array#toPretty; NL]) ; - - JCHIntStubs.int_stub_manager#record_poly_int_array_call - jproc_info#get_name invoked_proc_name call_poly_int_array in - List.iter record_call procs ; - - if !dbg then pr__debug [STR "after record_call"; NL] - end ; - - if procs = [] && stubs = [] then - begin - List.iter self#project_out_fields coll_rvars ; - self#project_out (all_wvars @ other_lengths) - end - else if all_wvars = [] then {< >} - else - begin - let arg_vars = List.map (fun (_,v,_) -> v) args in - let _ = if !dbg then pr__debug [STR "arg_vars = "; pp_list arg_vars ; NL] in - let (empty_collections, non_empty_collections) = - let is_empty_collection v = - poly_int_array#get_extra_infos#is_empty_collection v in - let (empty, non_empty) = List.partition is_empty_collection coll_rvars in - (VariableCollections.set_of_list empty, non_empty) in - - let (invoked_poly_int_array, invoked_conds, sig_vars_opt) = - - let (invoked_proc_poly_int_array, proc_sig_vars, proc_sig_arrays, - invoked_stub_poly_int_array, stub_sig_vars, stub_sig_arrays, conds) = - JCHIntStubs.int_stub_manager#invoke_poly_int_array jproc_info procs stubs in - - (if !dbg then pr__debug [STR "after invoke_poly_int_array"; NL]) ; - - let stub_sig_vars_opt = - match invoked_stub_poly_int_array with - | None -> None - | _ -> Some stub_sig_vars in - let add_invoked - res_poly_int_array invoked_poly_int_array_opt sig_vars sig_arrays = - match invoked_poly_int_array_opt with - | Some invoked_poly_int_array -> - - (if !dbg then - pr__debug [STR "invoked_poly_int_array = "; NL; - invoked_poly_int_array#toPretty; NL]) ; - - (if invoked_poly_int_array#is_bottom then - raise (JCH_no_return_proc (mtarget#toPretty))) ; - - let inds_to_eliminate = ref [] in - let invoked_vars = ref [] in - let check_arg ind (_, arg, _) = - (if JCHAnalysisUtils.is_numeric jproc_info arg then - invoked_vars := arg :: !invoked_vars - else - inds_to_eliminate := ind :: !inds_to_eliminate) ; - ind + 1 in - let ind = List.fold_left check_arg 0 args in - let assoc_arg_sig = List.combine args sig_vars in - - (if !dbg then - pr__debug [STR "sig_arrays = "; pp_list sig_arrays; NL]) ; - - let check_arrays ind array = - - (if !dbg then - pr__debug [STR "check_arrays "; INT ind; STR " "; - array#toPretty; NL]) ; - (if !dbg then - pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]) ; - (if !dbg then - pr__debug [STR "args = "; - pp_list (List.map (fun (_,v,_) -> v) args); NL]) ; - - let ((_,arg,_), _) = - List.find (fun (v, v') -> - v'#getName#equal array#getName) assoc_arg_sig in - - (if !dbg then pr__debug [STR "arg = "; arg#toPretty; NL]) ; - - let arg_info = jproc_info#get_jvar_info arg in - if not arg_info#has_length then - begin - (if !dbg then - pr__debug [STR "add ind to eliminate for arg_info = "; - arg_info#toPretty; STR " "; INT ind; NL]) ; - - inds_to_eliminate := ind :: !inds_to_eliminate - end ; - ind + 1 in - let _ = List.fold_left check_arrays ind sig_arrays in - let invoked_vars = List.rev !invoked_vars in - - let (invoked_lengths, invoked_target_lengths) = - let lens = ref [] in - let target_lens = ref [] in - let add_var var target_var = - - (if !dbg then - pr__debug [STR "add_var "; var#toPretty; STR " "; - target_var#toPretty; NL]) ; - - match jproc_info#get_length var with - | Some len -> - lens := len :: !lens ; - if (List.exists (fun v -> - v#equal target_var) sig_arrays) then - (* The invoked target might have argument that are - * objects rather than arrays *) - target_lens := len :: !target_lens - | _ -> () in - List.iter2 add_var arg_vars sig_vars ; - (List.rev !lens, List.rev !target_lens) in - let all_invoked_vars = invoked_vars @ invoked_target_lengths in - - let _ = - (if !dbg then - pr__debug [STR "all_invoked_vars = "; - pp_list all_invoked_vars; NL]) in - - let arg_length = List.length arg_vars + List.length sig_arrays in - let meet_poly_int_array = - res_poly_int_array#meet_invoked - invoked_poly_int_array - !inds_to_eliminate arg_length - invoked_vars - invoked_lengths - invoked_target_lengths - num_wvars - coll_rvars in - let changed = - List.filter - invoked_poly_int_array#get_extra_infos#is_changed_sym_param - all_invoked_vars in - - (if !dbg then - pr__debug [STR "variables changed in invoke = "; - pp_list changed; NL]) ; - - self#record_changed_sym_params changed; - - (if !dbg then - pr__debug [STR "meet_poly_int_array = "; NL; - meet_poly_int_array#toPretty; NL]) ; - - meet_poly_int_array - | _ -> poly_int_array#project_out all_wvars in - (add_invoked - (add_invoked - poly_int_array - invoked_proc_poly_int_array - proc_sig_vars - proc_sig_arrays) - invoked_stub_poly_int_array - stub_sig_vars - stub_sig_arrays, conds, stub_sig_vars_opt) in - - (if !dbg then - pr__debug [STR "invoked_poly_int_array "; NL; - invoked_poly_int_array#toPretty; NL]) ; - - (if !dbg then - pr__debug [STR "empty_collections = "; - empty_collections#toPretty; NL]) ; - - let changed_vars = ref [] in - let add_cond p_int_array cond = - - (if !dbg then - pr__debug [STR "add_cond "; NL; p_int_array#toPretty; NL; - JCHIntStubs.stub_condition_to_pretty cond; NL]) ; - match cond with - | JCHIntStubs.CheckReturnType -> - let ret = JCHSystemUtils.get_arg_var "return" args in - p_int_array#check_type ret - | JCHIntStubs.JoinInfo (src1, src2, dst) -> - begin - match sig_vars_opt with - | Some sig_vars -> - (if !dbg then - pr__debug [STR "arg_vars = "; pp_list arg_vars; NL]) ; - - (if !dbg then - pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]) ; - - let sig_var_arg_var = - List.combine - (List.map (fun v -> v#getIndex) sig_vars) arg_vars in - let dst_var = List.assoc dst#getIndex sig_var_arg_var in - let src1_var = List.assoc src1#getIndex sig_var_arg_var in - let src2_var = List.assoc src2#getIndex sig_var_arg_var in - changed_vars := dst_var :: !changed_vars ; - if JCHAnalysisUtils.is_numeric jproc_info dst_var then - if JCHAnalysisUtils.is_numeric jproc_info src1_var - && JCHAnalysisUtils.is_numeric jproc_info src2_var then - begin - empty_collections#remove dst_var ; - p_int_array#set_join dst_var src1_var src2_var - end - else - p_int_array#project_out [dst_var] - else - p_int_array - | None -> p_int_array - end - | JCHIntStubs.CopyInfo (var1, var2) -> - begin - - (if !dbg then - pr__debug [STR "CopyInfo "; var1#toPretty; STR " "; - INT var1#getIndex; STR " "; var2#toPretty; - STR " "; INT var2#getIndex; NL]) ; - - match sig_vars_opt with - | Some sig_vars -> - (if !dbg then - pr__debug [STR "arg_vars = "; pp_list arg_vars; NL]) ; - - (if !dbg then - pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]) ; - - let sig_var_arg_var = - List.combine - (List.map (fun v -> v#getIndex) sig_vars) arg_vars in - let arg1 = List.assoc var1#getIndex sig_var_arg_var in - let arg2 = List.assoc var2#getIndex sig_var_arg_var in - - (if !dbg then - pr__debug [STR "arg1 = "; arg1#toPretty; - STR ", arg2 = "; arg2#toPretty; NL]) ; - - changed_vars := arg2 :: !changed_vars ; - if JCHAnalysisUtils.is_numeric jproc_info arg2 then - if JCHAnalysisUtils.is_numeric jproc_info arg1 then - let interval = poly_int_array#get_interval arg1 in - let excluded_vals = - poly_int_array#get_extra_infos#get_excluded_vals arg1 in - p_int_array#copy_info arg2 interval excluded_vals - else - p_int_array#project_out [arg2] - else - p_int_array - | None -> p_int_array - end - | JCHIntStubs.PostInterval (var, interval) -> - begin - match sig_vars_opt with - | Some sig_vars -> - let sig_var_arg_var = - List.combine (List.map (fun v -> v#getIndex) sig_vars) arg_vars in - let arg = List.assoc var#getIndex sig_var_arg_var in - changed_vars := arg :: !changed_vars ; - if JCHAnalysisUtils.is_numeric jproc_info arg then - p_int_array#set_interval var interval - else - p_int_array - | None -> p_int_array - end - | JCHIntStubs.Abstract var -> - begin - match sig_vars_opt with - | Some sig_vars -> - let sig_var_arg_var = - List.combine (List.map (fun v -> v#getIndex) sig_vars) arg_vars in - let arg = List.assoc var#getIndex sig_var_arg_var in - changed_vars := arg :: !changed_vars ; - if JCHAnalysisUtils.is_numeric jproc_info arg then - p_int_array#project_out [arg] - else - p_int_array - | _ -> p_int_array - end in - - self#record_changed_sym_params !changed_vars; - let cond_poly_int = - let pia_cond = - List.fold_left add_cond invoked_poly_int_array invoked_conds in - let add_empty pia v = pia#add_empty_collection v in - List.fold_left add_empty pia_cond empty_collections#toList in - - let length_poly_int = - let unassigned_lengths = - List.filter (fun l -> - (cond_poly_int#get_interval l)#isBottom) other_lengths in - cond_poly_int#project_out unassigned_lengths in - let red_poly_int = length_poly_int#move_simple_ineqs in - let best_poly_int = red_poly_int#set_best_intervals in - let is_restricted v = - JCHAnalysisUtils.is_numeric jproc_info v && not (self#is_const v) in - - let restrict_poly_int = - best_poly_int#restrict_to_type (List.filter is_restricted arg_vars) in - - List.iter (self#update_fields restrict_poly_int) coll_rvars ; - if params#use_intervals then - {< poly_int_array = restrict_poly_int#drop_poly >} - else - {< poly_int_array = restrict_poly_int >} - end - end - - method private invoke - (is_static:bool) - cn_msig_opt - (iInfo:instruction_info_int) - args = - - let _ = - if !dbg then - pr__debug [STR "analyze_invoke "; proc_name_pp proc_name; NL; - iInfo#toPretty; NL] in - - let res = - let wvars = JCHSystemUtils.get_write_vars args in - List.iter add_reachable wvars ; - let num_wvars = List.filter (JCHAnalysisUtils.is_numeric jproc_info) wvars in - let rvars = JCHSystemUtils.get_read_vars args in - let num_rvars = - List.filter (JCHAnalysisUtils.is_numeric jproc_info) rvars in - let coll_rvars = - List.filter (JCHAnalysisUtils.is_collection_or_array jproc_info) num_rvars in - let all_wvars = num_wvars @ coll_rvars in - - (* remove some targets *) - if iInfo#has_method_target then - begin - try - self#invoke_with_target - is_static iInfo args num_wvars num_rvars coll_rvars all_wvars - with - | JCH_no_return_proc pp -> self#mkBottom - end - else - begin - List.iter self#project_out_fields coll_rvars ; - self#project_out all_wvars ; - end in - - let _ = - begin - (if !dbg then pr__debug [STR "after invoke, res = "; res#toPretty; NL]) ; - if iInfo#has_method_target && !dbg then - pr__debug [STR "mtarget = "; NL; - (iInfo#get_method_target ())#toPretty; NL] - end in - - res - - method analyzeOperation - ~(domain_name: string) - ~(fwd_direction: bool) - ~(operation: operation_t): 'a = - - let _ = - if !dbg then - pr__debug [STR "PolyDom.analyzeOperation "; - operation_to_pretty operation; NL; - self#toPretty; NL] in - - let res = - match operation.op_name#getBaseName with - |"init_params" -> - List.iter - add_reachable (JCHSystemUtils.get_write_vars operation.op_args) ; - if self#isBottom || poly_int_array#is_top then - {< >} - else - let simple_poly_int_array = poly_int_array#move_simple_ineqs in - {< poly_int_array = simple_poly_int_array >} - | "init_assumptions" -> - List.iter add_reachable (JCHSystemUtils.get_write_vars operation.op_args) ; - if self#isBottom then - {< >} - else - let p = poly_int_array#init_assumptions jproc_info in - {< poly_int_array = p >} - | "add_vars" -> {< >} - | "remove_vars" -> - let vars = List.map (fun (_,v,_) -> v) operation.op_args in - self#remove vars - | "i" - | "ii" -> - let pc = operation.op_name#getSeqNumber in - let bcloc = get_bytecode_location cms#index pc in - let iInfo = app#get_instruction bcloc in - begin - match mInfo#get_opcode pc with - | OpInvokeStatic (cn, msig) -> - self#invoke true (Some (cn, msig)) iInfo operation.op_args - | OpInvokeVirtual _ -> - self#invoke false None iInfo operation.op_args - | OpInvokeInterface (cn, msig) - | OpInvokeSpecial (cn, msig) -> - self#invoke false (Some (cn, msig)) iInfo operation.op_args - | OpNew cn -> - let var = JCHSystemUtils.get_arg_var "ref" operation.op_args in - add_reachable var ; - - if JCHAnalysisUtils.is_numeric jproc_info var then - let new_poly_int_array = poly_int_array#project_out [var] in - if JCHAnalysisUtils.is_collection jproc_info var then - {< poly_int_array = new_poly_int_array#add_empty_collection var >} - else - {< poly_int_array = new_poly_int_array >} - else - {< >} - | OpGetStatic _ - | OpGetField _ -> - let var = JCHSystemUtils.get_arg_var "val" operation.op_args in - add_reachable var ; - - JCHFields.int_field_manager#record_field iInfo ; - if JCHAnalysisUtils.is_numeric jproc_info var then - begin - if JCHAnalysisUtils.is_collection_or_array jproc_info var then - add_variable_to_field var iInfo ; - let intervals = - JCHFields.int_field_manager#get_field_intervals - iInfo#get_field_target in - let fInfo = iInfo#get_field_target in - {< poly_int_array = - poly_int_array#get_field jproc_info fInfo intervals var >} - end - else - {< >} - | OpPutStatic _ - | OpPutField _ -> - let var = JCHSystemUtils.get_arg_var "val" operation.op_args in - if JCHAnalysisUtils.is_numeric jproc_info var then - begin - let fInfo = iInfo#get_field_target in - {< poly_int_array = poly_int_array#add_field var fInfo >} - end - else {< >} - - | OpNewArray _ -> - let array = JCHSystemUtils.get_arg_var "ref" operation.op_args in - let length = JCHSystemUtils.get_arg_var "length" operation.op_args in - add_reachable array ; - - if JCHAnalysisUtils.is_numeric jproc_info array then - {< poly_int_array = poly_int_array#new_array array [length] >} - else - {< >} - - | OpAMultiNewArray _ -> - let array = JCHSystemUtils.get_arg_var "ref" operation.op_args in - let dims = JCHSystemUtils.get_read_vars operation.op_args in - add_reachable array ; - - if JCHAnalysisUtils.is_numeric jproc_info array then - {< poly_int_array = poly_int_array#new_array array dims >} - else - {< >} - - | OpArrayStore _ -> - let array = JCHSystemUtils.get_arg_var "array" operation.op_args in - let element = JCHSystemUtils.get_arg_var "val" operation.op_args in - let index = JCHSystemUtils.get_arg_var "index" operation.op_args in - record_array_access poly_int_array array index ; - self#record_changed_sym_params [array]; - - if JCHAnalysisUtils.is_numeric jproc_info array then - if JCHAnalysisUtils.is_numeric jproc_info element then - let new_poly_int_array = - poly_int_array#set_join array element array in - begin - self#update_fields new_poly_int_array array ; - {< poly_int_array = new_poly_int_array >} - end - else - begin - self#project_out_fields array ; - {< poly_int_array = poly_int_array#project_out_array array >} - end - else - {< >} - - | OpArrayLoad _ -> - let array = JCHSystemUtils.get_arg_var "array" operation.op_args in - let element = JCHSystemUtils.get_arg_var "val" operation.op_args in - let index = JCHSystemUtils.get_arg_var "index" operation.op_args in - record_array_access poly_int_array array index ; - let new_poly_int_array = poly_int_array in (* CHANGE : bring back info about the dims *) - add_reachable element ; - - if JCHAnalysisUtils.is_numeric jproc_info element then - if JCHAnalysisUtils.is_numeric jproc_info array then - {< poly_int_array = new_poly_int_array#array_load array element >} - else - self#projectOut [element] - else - begin - self#record_changed_sym_params [array] ; - {< >} - end - - | OpArrayLength -> - let var = JCHSystemUtils.get_arg_var "ref" operation.op_args in - let length = JCHSystemUtils.get_arg_var "val" operation.op_args in - add_reachable length ; - {< poly_int_array = poly_int_array#transfer_fields false length var >} - - | OpCheckCast _ -> - let ref = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let ref_new_type = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - add_reachable ref_new_type ; - - if JCHAnalysisUtils.is_numeric jproc_info ref_new_type then - if JCHAnalysisUtils.is_numeric jproc_info ref then - begin - (* We are not using affine_image here because there - * cannot be over/underflow *) - let (new_poly_int_array, _, _) = - if self#is_const ref then - poly_int_array#affine_subst - ref_new_type None zero_big_int (self#get_const_val ref) - else - poly_int_array#affine_subst - ref_new_type (Some ref) unit_big_int zero_big_int in - {< poly_int_array = new_poly_int_array >} - end - else - self#copy_num_info (self#projectOut [ref_new_type]) ref_new_type ref - else - self#copy_num_info self ref_new_type ref - - | OpI2F -> (* [-2^23,2^23] is a safe conversion range ? *) - let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - if self#is_const src1 then - begin - let const = self#get_const_val src1 in - if le_big_int const (big_int_of_int 8388608) - && ge_big_int const (big_int_of_int (-8388608)) then - self#affine_subst false dst1 None zero_big_int const - else - self#project_out [dst1] (* CHANGE *) - end - else - begin - let src1_int = poly_int_array#get_interval src1 in - let max_conversion_int = - mkInterval (mkNumerical (-8388608)) (mkNumerical 8388608) in - if src1_int#leq max_conversion_int then - self#affine_subst false dst1 (Some src1) unit_big_int zero_big_int - else self#project_out [dst1] (* CHANGE *) - end - - | OpI2L - | OpI2D - | OpL2F - | OpL2D - | OpF2D -> - let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - if self#is_const src1 then - self#affine_subst - false dst1 None zero_big_int (self#get_const_val src1) - else - self#affine_subst - false dst1 (Some src1) unit_big_int zero_big_int - - | OpD2L - | OpD2I - | OpF2I - | OpF2L -> - let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - self#down_cast_float src1 dst1 - - | OpL2I -> - let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let tp_interval_opt = None in - if self#is_const src1 then - self#affine_image_down_cast - None - None - (dst1, unit_big_int) - [] - (self#get_const_val src1) - src1 - dst1 - tp_interval_opt - else - self#affine_image_down_cast - None - (Some src1) - (dst1, unit_big_int) - [(src1, unit_big_int)] - zero_big_int - src1 - dst1 - tp_interval_opt - | OpI2B - | OpI2C - | OpI2S -> - let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let pc = iInfo#get_location#get_pc in - let tp_interval_opt = - (* type of the variable could be int although although the - * truncation is to byte, char or short *) - match iInfo#get_opcode with - | OpI2B -> Some (JCHTypeUtils.byte_interval) - | OpI2C -> Some (JCHTypeUtils.char_interval) - | OpI2S -> Some (JCHTypeUtils.short_interval) - | _ -> None in - let pc_opt = if !arith_casts#has pc then Some pc else None in - if self#is_const src1 then - self#affine_image_down_cast - pc_opt - None - (dst1, unit_big_int) - [] - (self#get_const_val src1) - src1 - dst1 - tp_interval_opt - else - self#affine_image_down_cast - pc_opt - (Some src1) - (dst1, unit_big_int) - [(src1, unit_big_int)] - zero_big_int - src1 - dst1 - tp_interval_opt - - | OpD2F -> - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - self#projectOut [dst1] - - | OpFloatConst f - | OpDoubleConst f -> - let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - begin - add_reachable dst1 ; - {< poly_int_array = poly_int_array#float_const dst1 f >} - end - - | OpAdd Float - | OpAdd Double -> - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - self#affine_image - false - None - (v, unit_big_int) - [(x, unit_big_int); (y, unit_big_int)] - zero_big_int - - | OpSub Float - | OpSub Double -> - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - self#affine_image - false - None - (v, unit_big_int) - [(x, unit_big_int); (y, neg_unit_big_int)] - zero_big_int - - | OpMult Float - | OpMult Double -> - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - self#mult v x y - - | OpDiv Float - | OpDiv Double -> - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - self#div v x y - - | OpRem _ -> - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - self#rem v x y - - | OpIAnd - | OpLAnd -> - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - begin - add_reachable v ; - {< poly_int_array = poly_int_array#log_and v x y >} - end - - | OpIOr - | OpLOr -> - let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in - let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in - let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - begin - add_reachable v ; - {< poly_int_array = poly_int_array#log_and v x y >} - end - - | OpStore (t, n) -> - let is_r_n v = - let name = v#getName in - let base_name = name#getBaseName in - if base_name.[0] = 'r' - && base_name.[1] <> 'e' - && (int_of_string (Str.string_after base_name 1)) = n then - match t with - | Object -> (List.hd name#getAttributes) = "sym" - | _ -> (List.hd name#getAttributes) = "num" - else - false in - let (_, rest_local_var_map) = - List.partition (fun (orig_v, v) -> is_r_n orig_v) local_var_map in - let new_var = JCHSystemUtils.get_arg_var "dst1" operation.op_args in - let orig_var = - try - List.find is_r_n orig_local_vars - with - | Not_found -> - raise - (JCH_failure - (LBLOCK [ STR "original variable not found in " ; - STR "JCHPolyIntDomainNoArrays.analyzeOperation" ])) in - let new_local_var_map = (orig_var, new_var) :: rest_local_var_map in - {< local_var_map = new_local_var_map >} - - | _ -> - begin - pr__debug [STR "Analysis failed: Poly does not implement the operation"; NL; - operation_to_pretty operation] ; - raise (params#analysis_failed 3 "Poly does not implement the operation") - end - end - | _ -> - begin - pr__debug [STR "Analysis failed: Poly does not implement the operation"; NL; - operation_to_pretty operation] ; - raise (params#analysis_failed 3 "Poly does not implement the operation") - end in - - let _ = - if !dbg then - pr__debug [STR "after analyzeOperation res "; NL; res#toPretty; NL] in - res - - end - -let get_poly_int_array (poly_dom: CHDomain.domain_int) = - - (if !dbg then - pr__debug [STR "get_poly_int_array "; NL; poly_dom#toPretty; NL]) ; - - let _ = poly_dom#special "set_poly_int_array" [] in - get_st_poly_int_array () - -let get_relational_exprs include_loop_counters poly_int_dom = - if poly_int_dom#isBottom then - [] - else - let args = - if include_loop_counters then - [NUM_DOM_ARG numerical_zero] else [] in - let _ = poly_int_dom#special "get_local_var_invariants" args in - get_st_relational_exprs () - -let get_local_var_map poly_int_dom = - if poly_int_dom#isBottom then - [] - else - let _ = poly_int_dom#special "set_local_var_map" [] in - get_st_local_var_map () - -let get_poly_vars poly_int_dom = - if poly_int_dom#isBottom then - [] - else - let _ = poly_int_dom#special "set_poly_vars" [] in - get_st_poly_vars () - - -let mk_param_map - (jproc_info: JCHProcInfo.jproc_info_t): - (variable_t list * (variable_t * variable_t) list) = - let name = jproc_info#get_name in - let orig_proc = (JCHSystem.jsystem#get_original_chif#getProcedure name) in - let orig_locals = - List.filter (fun v -> - JCHSystemUtils.is_register v - || JCHSystemUtils.is_return v) orig_proc#getScope#getVariables in - let jvar_infos = jproc_info#get_jvar_infos#listOfValues in - let params = List.filter (fun info -> info#is_parameter) jvar_infos in - let map = - List.map (fun info -> let v = info#get_variable in (v, v)) params in - (orig_locals, map) - -let get_poly_dom - jproc_info - init_poly_int_array - reset_old_join_widening - reset_use_intervals = - let proc_name = jproc_info#get_name in - - (if !dbg then - pr__debug [jproc_info#get_opcodes#toPretty; NL; jproc_info#toPretty; NL]) ; - - (if !dbg then - pr__debug [STR "init_poly_int_array "; init_poly_int_array#toPretty; NL]) ; - - let consts = - let is_const var = - List.exists (fun (i, _) -> - var#getIndex = i) init_poly_int_array#get_var_to_const in - List.filter is_const jproc_info#get_variables in - let div2div2quot = - reset_ref_vars - proc_name - jproc_info - consts - reset_old_join_widening in - params#reset reset_use_intervals; - - let new_init_poly_int_array = - let new_extra_infos = - init_poly_int_array#get_extra_infos#add_div_info div2div2quot in - let pia = init_poly_int_array#set_extra_infos new_extra_infos in - if params#use_intervals then - pia#move_simple_ineqs#drop_poly - else pia in - new poly_int_domain_no_arrays_t - jproc_info new_init_poly_int_array (mk_param_map jproc_info) - -let get_interval poly_int_dom var = - let poly_interval_array = get_poly_int_array poly_int_dom in - poly_interval_array#get_interval var - -let bottom_poly_int_dom jproc_info = - new poly_int_domain_no_arrays_t - jproc_info bottom_poly_interval_array (mk_param_map jproc_info) - -let top_poly_int_dom jproc_info vs = - let top = top_poly_interval_array [] vs in - new poly_int_domain_no_arrays_t jproc_info top (mk_param_map jproc_info) - -let project_out_loop_counters poly = - poly#special "project_out_loop_counters" [] - -let remove_duplicates poly = - poly#special "remove_duplicates" [] - -let restrict_to_vars poly vars = - poly#special "restrict_to_vars" (List.map (fun v -> VAR_DOM_ARG v) vars) - -let get_relational_exprs_vars_fields (poly: poly_int_domain_no_arrays_t) vars = - let _ = poly#special - "get_vars_fields_rel_exprs" (List.map (fun v -> VAR_DOM_ARG v) vars) in - get_st_relational_exprs () +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +open Big_int_Z + +(* chlib *) +open CHIntervals +open CHLanguage +open CHNonRelationalDomainValues +open CHNumerical +open CHPretty +open CHUtils + +(* chutil *) +open CHPrettyUtil + +(* jchlib *) +open JCHBasicTypes +open JCHBasicTypesAPI +open JCHDictionary + +(* jchpre *) +open JCHApplication +open JCHBytecodeLocation +open JCHPreAPI + +(* jchsys *) +open JCHGlobals +open JCHPrintUtils + +(* jchpoly *) +open JCHPolyIntervalArray + +(* Suppress warnings on unused variables *) +[@@@warning "-27"] + + +exception JCH_no_return_proc of pretty_t + +let dbg = ref false +let params = JCHAnalysisUtils.numeric_params + +(* A way to get the private variables of poly_doamin_no_arrays_t *) +let st_poly_int_array_opt = ref None +let set_st_poly_int_array poly_int_array = + st_poly_int_array_opt := Some poly_int_array +let get_st_poly_int_array () = Option.get !st_poly_int_array_opt + +let st_bool_opt = ref None +let _set_st_bool b = st_bool_opt := Some b +let _get_st_bool () = Option.get !st_bool_opt + +let st_local_var_map = ref None +let set_st_local_var_map local_var_map = st_local_var_map := Some local_var_map +let get_st_local_var_map () = Option.get !st_local_var_map + +let st_local_var_invariants = ref None +let _set_st_local_var_invariants local_var_invariants = + st_local_var_invariants:= Some local_var_invariants +let _get_st_local_var_invariants () = Option.get !st_local_var_invariants + +let st_relational_exprs = ref None +let set_st_relational_exprs exprs = st_relational_exprs:= Some exprs +let get_st_relational_exprs () = Option.get !st_relational_exprs + +let st_poly_vars = ref None +let set_st_poly_vars vars = st_poly_vars:= Some vars +let get_st_poly_vars () = Option.get !st_poly_vars + +let instr_pc = ref (-1) +let set_instr_pc i = instr_pc := i + +let prev_pc_to_wto_pc = ref [] +let set_prev_pc_to_wto_pc ls = prev_pc_to_wto_pc := ls +let get_wto_pc prev_pc = + let rec find_wto_pc p = + try + List.assoc p !prev_pc_to_wto_pc + with _ -> + find_wto_pc (p + 1) in + find_wto_pc prev_pc + +let old_pc_to_join_poly_int_array = ref (new IntCollections.table_t) + +let get_old_join_poly_int_array prev_pc var_to_const poly_vars = + let pc = try List.assoc prev_pc !prev_pc_to_wto_pc with _ -> prev_pc in + match !old_pc_to_join_poly_int_array#get pc with + | Some set -> set + | _ -> top_poly_interval_array var_to_const poly_vars + +let pc_to_join_poly_int_array = ref (new IntCollections.table_t) + +let set_join_poly_int_array prev_pc poly_int_array = + let pc = try List.assoc prev_pc !prev_pc_to_wto_pc with _ -> prev_pc in + !pc_to_join_poly_int_array#set pc poly_int_array + +let old_pc_to_widening_poly_int_array = ref (new IntCollections.table_t) + +let get_old_widening_poly_int_array prev_pc var_to_const poly_vars = + if !dbg then + pr__debug [STR "get_old_widening_poly_int_array "; + INT prev_pc; NL; pp_assoc_list_ints !prev_pc_to_wto_pc; NL]; + + let pc = get_wto_pc prev_pc in + match !old_pc_to_widening_poly_int_array#get pc with + | Some pia -> pia + | _ -> top_poly_interval_array var_to_const poly_vars + +let pc_to_widening_poly_int_array = ref (new IntCollections.table_t) + +let set_widening_poly_int_array prev_pc poly_int_array = + let pc = get_wto_pc prev_pc in + !pc_to_widening_poly_int_array#set pc poly_int_array + +let set_invs wto_pc_to_poly_int_array = + let add_wto wto_pc poly_int_array = + !old_pc_to_join_poly_int_array#set wto_pc poly_int_array; + !old_pc_to_widening_poly_int_array#set wto_pc poly_int_array in + wto_pc_to_poly_int_array#iter add_wto + + +let pc_to_join_iteration = ref (new IntCollections.table_t) + +let increment_join_iteration () = + match !pc_to_join_iteration#get !instr_pc with + | Some n -> !pc_to_join_iteration#set !instr_pc (n#add numerical_one) + | _ -> !pc_to_join_iteration#set !instr_pc numerical_one + +let pc_to_widening_iteration = ref (new IntCollections.table_t) +let get_widening_iteration () = + match !pc_to_widening_iteration#get !instr_pc with + | Some n -> n#toInt + | _ -> 0 +let increment_widening_iteration () = + match !pc_to_widening_iteration#get !instr_pc with + | Some n -> !pc_to_widening_iteration#set !instr_pc (n#add numerical_one) + | _ -> !pc_to_widening_iteration#set !instr_pc numerical_one + +(* These are both numeric and symbolic *) +let reachables = ref (new VariableCollections.set_t) +let is_reachable var = !reachables#has var + +(* Symbolic params that might have been changed *) +let changed_sym_params = ref (new VariableCollections.set_t) +let get_changed_sym_params () = !changed_sym_params#toList + +let overflow = ref (new VariableCollections.set_t) +let underflow = ref (new VariableCollections.set_t) +let convert_overflow = ref (new VariableCollections.set_t) (* dst of conversion *) + +(* The result of a division with a possible 0 divisor *) +let div0 = ref (new VariableCollections.set_t) + +let add_overflow var = !overflow#add var +let add_underflow var = !underflow#add var +let add_convert_overflow dst = !convert_overflow#add dst +let add_reachable var = !reachables#add var +let add_div0 var = !div0#add var + +let in_bounds_vars = ref (new VariableCollections.set_t) +let out_of_bounds_vars = ref (new VariableCollections.set_t) +let no_info_bounds_vars = ref (new VariableCollections.set_t) + + +let record_array_access + (_poly_int_array: JCHPolyIntervalArray.poly_interval_array_t) + _array + _index = () + +(* Used to project out variables that are not needed in very long states, + * such as in clinit that set arrays *) +let pc_to_last_read = ref (new IntCollections.table_t) + +(* Used to report truncations in casts of results of operations as over/underflow *) +let arith_casts = ref (new IntCollections.set_t) + +module FieldInfoCollections = CHCollections.Make ( + struct + type t = field_info_int + let compare f1 f2 = compare f1#get_index f2#get_index + let toPretty f = f#toPretty + end) + +(* Array and collection variables that were obtained as OpGetField + * They are needed to check if OpArrayStore or invoked methods do not change them *) +let variable_to_fields = ref (new VariableCollections.table_t) +let add_variable_to_field var iInfo = + let fInfo = iInfo#get_field_target in + match !variable_to_fields#get var with + | Some set -> set#add fInfo + | None -> + !variable_to_fields#set var (FieldInfoCollections.set_of_list [fInfo]) + +let reset_ref_vars + proc_name jproc_info consts reset_old_join_widening = + begin + overflow := new VariableCollections.set_t; + underflow := new VariableCollections.set_t; + convert_overflow := new VariableCollections.set_t; + reachables := VariableCollections.set_of_list consts; + changed_sym_params := new VariableCollections.set_t; + div0 := new VariableCollections.set_t; + variable_to_fields := new VariableCollections.table_t; + instr_pc := (-1); + + old_pc_to_widening_poly_int_array := + if reset_old_join_widening then + new IntCollections.table_t + else + !pc_to_widening_poly_int_array; + pc_to_widening_poly_int_array := new IntCollections.table_t; + + pc_to_widening_iteration := new IntCollections.table_t; + old_pc_to_join_poly_int_array := + if reset_old_join_widening then + new IntCollections.table_t + else + !pc_to_join_poly_int_array; + pc_to_join_poly_int_array:= new IntCollections.table_t; + + let (table, set, div2div2quot) = + JCHCollectors.collect_lin_eqs_info proc_name jproc_info in + pc_to_last_read := table; + arith_casts := set; + div2div2quot + end + +let get_proc_info () = + let res = + (!in_bounds_vars, + !out_of_bounds_vars, + !no_info_bounds_vars, + !overflow, + !underflow, + !convert_overflow, + !reachables, + !div0) in + begin + in_bounds_vars := new VariableCollections.set_t; + out_of_bounds_vars := new VariableCollections.set_t; + no_info_bounds_vars := new VariableCollections.set_t; + res + end + +let lost_info_table = new SymbolCollections.table_t + +let log_lost_info proc_name v local_var_map = + let v_table = + match lost_info_table#get proc_name with + | Some t -> t + | None -> + let t = new VariableCollections.table_t in + begin + lost_info_table#set proc_name t; + t + end in + try + let (local_v, _) = List.find (fun (_, u) -> u#equal v) local_var_map in + let t = new IntCollections.table_t in + begin + t#set !instr_pc local_v; + v_table#set v t + end + with _ -> + v_table#set v (new IntCollections.table_t) + + +let unlog_lost_info proc_name v = + let v_table = + match lost_info_table#get proc_name with + | Some t -> t + | None -> + let t = new VariableCollections.table_t in + begin + lost_info_table#set proc_name t; + t + end in + v_table#remove v + +let has_lost_info proc_name vs = + let v_table = + match lost_info_table#get proc_name with + | Some t -> t + | None -> + let t = new VariableCollections.table_t in + begin + lost_info_table#set proc_name t; + t + end in + List.exists v_table#has vs + +let transfer_lost_info proc_name x y local_var_map = + if has_lost_info proc_name [x] then + begin + if not (JCHSystemUtils.is_constant y) then + log_lost_info proc_name y local_var_map + end + else if has_lost_info proc_name [y] then + if not (JCHSystemUtils.is_constant x) then + log_lost_info proc_name x local_var_map + + +let print_lost_info () = + let table = new SymbolCollections.table_t in + let add_proc ((proc_name, v_table): + symbol_t + * variable_t IntCollections.table_t VariableCollections.table_t) = + if not (v_table#size = 0) then + begin + let new_t = new VariableCollections.table_t in + table#set proc_name new_t; + let add_var (_v, pc_table) = + let add_local_v (pc, local_v) = + match new_t#get local_v with + | Some set -> set#add pc + | _ -> + new_t#set local_v (IntCollections.set_of_list [pc]) in + List.iter add_local_v pc_table#listOfPairs in + List.iter add_var v_table#listOfPairs + end in + List.iter add_proc lost_info_table#listOfPairs; + + if !dbg then + pr__debug [STR "lost_info: "; NL; lost_info_table#toPretty; NL]; + + pr__debug [STR "lost_info: "; NL; table#toPretty; NL] + +(* A poly domain in which the constants are kept separately + * The variables are added and removed as needed + * The order of the variables is kept otherwise constant *) +class poly_int_domain_no_arrays_t + (jproc_info:JCHProcInfo.jproc_info_t) + (p_int_a:poly_interval_array_t) + ((orig_local_vs, local_v_map): variable_t list * (variable_t * variable_t) list) = +object (self: 'a) + + inherit ['a] CHCommunications.domain_downlink_t + + val proc_name = jproc_info#get_name + val cms = retrieve_cms jproc_info#get_name#getSeqNumber + val mInfo = app#get_method (retrieve_cms jproc_info#get_name#getSeqNumber) + + val poly_int_array = p_int_a + + val orig_local_vars = orig_local_vs + val phi_infos = + List.filter (fun info -> info#is_phi) (jproc_info#get_jvar_infos#listOfValues) + + (* original variable -> version variable at current pc *) + val local_var_map = local_v_map + + method mkBottom = + {< poly_int_array = bottom_poly_interval_array >} + + method isBottom = poly_int_array#is_bottom + + method mkEmpty = + {< poly_int_array = + poly_int_array#mk_empty (self#get_var_to_const) (self#get_poly_vars) >} + + method clone = + {< poly_int_array = poly_int_array#clone >} + + method isRelational = true + + method private reached_time_limit = + match params#check_time_limit with + | 0 -> false + | 1 -> + begin + pr__debug [STR " Reached constraint analysis time limit "; NL]; + params#reset_analysis_failure_status; + true + end + | _ -> + begin + pr__debug [STR "Analysis failed: reached numeric analysis time limit "; NL]; + raise (params#analysis_failed 3 "reached numeric analysis time limit ") + end + + method observer = + object + inherit CHDomainObserver.domain_observer_t + method !getObservedVariables: variable_t list = poly_int_array#get_poly_vars + method !getMatrix = None + method !isTop = Some poly_int_array#is_top + method !isBottom = Some poly_int_array#is_bottom + end + + method private get_poly_int_array (a: 'a) = + let _ = a#special "set_poly_int_array" [] in + get_st_poly_int_array () + + method private get_local_var_map (a: 'a) = + let _ = a#special "set_local_var_map" [] in + get_st_local_var_map () + + method private change_local_var_map (a: 'a) v w = + try (* For the case when v or w are not local variables *) + let alocal_var_map:(variable_t * variable_t) list = + self#get_local_var_map a in + let get_var_index var = + int_of_string (Str.string_after var#getName#getBaseName 1) in + let v_index = get_var_index v in + let alocal_v_map = + match List.partition + (fun (v1, v2) -> + v2#equal w && get_var_index v1 = v_index) alocal_var_map with + | ((orig_w, _) :: _, rest_local_var_map) -> + (orig_w, v) :: rest_local_var_map + | _ -> alocal_var_map in + {< poly_int_array = self#get_poly_int_array a; + local_var_map = alocal_v_map >} + with _ -> a + + method private get_var_to_const = poly_int_array#get_var_to_const + + method private is_const v = poly_int_array#is_const v + + method private get_const_val v = poly_int_array#get_const_val v + + method private get_const_val_n v = poly_int_array#get_const_val_n v + + method private get_poly_vars = poly_int_array#get_poly_vars + + method leq ?(variables: variable_t list option) (a: 'a) = + let res = + match (self#isBottom, a#isBottom) with + | (true, _) -> true + | (_, true) -> false + | _ -> + if not params#use_types && get_widening_iteration () < 2 then + false + else + begin + let s_poly_int_array = poly_int_array#move_simple_ineqs in + let a_poly_int_array = + (self#get_poly_int_array a)#move_simple_ineqs in + s_poly_int_array#leq a_poly_int_array + end in + res + + method equal (a: 'a) = + poly_int_array#equal (self#get_poly_int_array a) + + method meet ?(variables: variable_t list option) (a: 'a) = + match (self#isBottom, a#isBottom) with + | (false, false) -> + {< poly_int_array = + poly_int_array#meet false (self#get_poly_int_array a) >} + | _ -> self#mkBottom + + method private join_local_var_map (a: 'a) = + let alocal_var_map = self#get_local_var_map a in + let join_vars var_index v1 v2 = + try + let is_this_phi (phi_info: JCHVarInfo.jvar_info_t) = + let rvars = phi_info#get_read_vars in + if (List.hd phi_info#get_local_indices) = var_index then + (List.exists (fun v -> + v#equal v1) rvars) && (List.exists (fun v -> v#equal v2) rvars) + else false in + Some (List.find is_this_phi phi_infos)#get_variable + with _ -> + begin + let is_v_phi var1 var2 = + let var1_info = jproc_info#get_jvar_info var1 in + let rvars = var1_info#get_read_vars in + var1_info#is_phi && List.exists (fun v -> v#equal var2) rvars in + if is_v_phi v1 v2 then Some v1 + else if is_v_phi v2 v1 then Some v2 + else None + end in + let join_local_var_map = ref [] in + let add_var orig_var = + match (List.filter (fun (ov, _) -> ov#equal orig_var) local_var_map, + List.filter (fun (ov, _) -> ov#equal orig_var) alocal_var_map) with + | ((_, v1) :: _, (_, v2) :: _) -> + if v1#equal v2 then join_local_var_map := (orig_var, v1) :: !join_local_var_map + else + begin + let var_index = + int_of_string (Str.string_after orig_var#getName#getBaseName 1) in + match join_vars var_index v1 v2 with + | Some v -> join_local_var_map := (orig_var, v) :: !join_local_var_map + | _ -> () + end + | ((_, v) :: _, _) + | (_, (_, v) :: _) -> join_local_var_map := (orig_var, v) :: !join_local_var_map + | _ -> () in + List.iter add_var orig_local_vars; + !join_local_var_map + + + method join ?(variables: variable_t list option) (a: 'a) = + let _ = + if !dbg then + pr__debug [STR "JCHPIDA.join "; INT (!instr_pc); STR " "; + INT (get_widening_iteration ()); NL; + self#toPretty; NL; a#toPretty; NL] in + + let join_res = + match (self#isBottom, a#isBottom) with + | (true, _) -> a#clone + | (_, true) -> {< >} + | _ -> + increment_join_iteration(); + let s_poly_int_array = + let pia = + if params#use_loop_counters then + self + else + self#project_out_loop_counters self in + let pia = + if params#use_lengths then + pia + else + self#project_out_lengths pia in + (self#get_poly_int_array pia)#move_simple_ineqs in + let a_poly_int_array = + let pia = + if params#use_loop_counters then + a + else + self#project_out_loop_counters a in + let pia = + if params#use_lengths then + pia + else + self#project_out_lengths pia in + (self#get_poly_int_array pia)#move_simple_ineqs in + if self#reached_time_limit then + begin + let s_poly_int_array' = s_poly_int_array#drop_poly in + let a_poly_int_array' = a_poly_int_array#drop_poly in + params#set_use_intervals true; + {< poly_int_array = s_poly_int_array'#join a_poly_int_array'; + local_var_map = self#join_local_var_map a >} + end + else + begin + let old_poly_int_array = + get_old_join_poly_int_array + !instr_pc self#get_var_to_const self#get_poly_vars in + let jpoly_int_array = + s_poly_int_array#join_with_old a_poly_int_array old_poly_int_array in + set_join_poly_int_array !instr_pc jpoly_int_array; + let join_var_map = self#join_local_var_map a in + {< poly_int_array = jpoly_int_array; + local_var_map = join_var_map >} + end; + + in let _ = + if !dbg then + pr__debug [STR "join res = "; NL; join_res#toPretty; NL] in + join_res + + method widening ?(kind: string option) ?(variables: variable_t list option) (a: 'a) : 'a = + try + self#widening_ self a + with + | JCHAnalysisUtils.JCH_num_analysis_failure _ -> + if params#get_analysis_status = 1 then + begin + params#reset_analysis_failure_status; + self#widening_ + {< poly_int_array = poly_int_array#drop_poly >} + {< poly_int_array = (self#get_poly_int_array a)#drop_poly >} + end + else + raise + (params#analysis_failed + (params#get_analysis_status) (params#get_analysis_failure_reason)) + | _ -> + begin + pr__debug [STR "Analysis failed: unknown programming error in widening"; NL]; + raise (params#analysis_failed 3 "unknown programming error in widening") + end + + method private widening_ (s: 'a) (a: 'a) = + let _ = + if !dbg then + pr__debug [STR "widening_ "; INT (!instr_pc); STR " "; + INT (get_widening_iteration ()); NL; + s#toPretty; NL; a#toPretty; NL] in + let res : 'a = + match (s#isBottom, a#isBottom) with + | (true, _) -> a#clone + | (_, true) -> {< >} + | _ -> + let s_poly_int_array = self#get_poly_int_array s in + let a_poly_int_array = self#get_poly_int_array a in + let old_poly_int_array = + get_old_widening_poly_int_array + !instr_pc self#get_var_to_const self#get_poly_vars in + JCHPolyIntervalArray.set_local_vars (List.map snd local_var_map); + + let new_poly_int_array = + if self#reached_time_limit then + begin + if !dbg then pr__debug [STR "reached limit"; NL]; + + params#set_use_intervals true; + let old_poly_int_array = old_poly_int_array#drop_poly in + let s_poly_int_array = s_poly_int_array#drop_poly in + let a_poly_int_array = a_poly_int_array#drop_poly in + let w_poly_int_array = s_poly_int_array#widening a_poly_int_array in + w_poly_int_array#meet false old_poly_int_array + end + else + begin + let s_poly_int_array = + poly_int_array#move_simple_ineqs#meet true old_poly_int_array in + let a_poly_int_array = + a_poly_int_array#move_simple_ineqs#meet true old_poly_int_array in + let w_poly_int_array = s_poly_int_array#widening a_poly_int_array in + w_poly_int_array#meet false old_poly_int_array; + end in + set_widening_poly_int_array !instr_pc new_poly_int_array; + increment_widening_iteration (); + {< poly_int_array = new_poly_int_array >} in + let _ = + if !dbg then + pr__debug [STR "widening_ res: "; NL; res#toPretty; NL] in + res + + method narrowing ?(variables: variable_t list option) (a: 'a) = + if self#isBottom then + self#mkBottom + else {< >} + + method private record_changed_sym_params vars : unit = + let is_sym_param v = + let jvar_info = jproc_info#get_jvar_info v in + jvar_info#is_parameter && not v#isNumerical in + let changed_params = List.filter is_sym_param vars in + !changed_sym_params#addList changed_params + + method private copy_num_info (a: 'a) dst_var src_var = + let apoly_int_array = self#get_poly_int_array a in + {< poly_int_array = apoly_int_array#copy_num_info dst_var src_var >} + + method special (cmd: string) (args: domain_cmd_arg_t list) : 'a = + match cmd with + | "set_poly_int_array" -> + begin + set_st_poly_int_array poly_int_array; + {< >} + end + | "set_local_var_map" -> + begin + set_st_local_var_map local_var_map; + {< >} + end + | "restrict_to_vars" -> + let add_var vs arg = + match arg with VAR_DOM_ARG v -> v :: vs | _ -> vs in + let restr_vars = List.fold_left add_var [] args in + {< poly_int_array = + poly_int_array#restrict_to_vars jproc_info (List.rev restr_vars) >} + | "get_vars_fields_rel_exprs" -> + let add_var vs arg = + match arg with VAR_DOM_ARG v -> v :: vs | _ -> vs in + let restr_vars = + VariableCollections.set_of_list (List.fold_left add_var [] args) in + let vars_with_fields = poly_int_array#get_vars_with_fields jproc_info in + set_st_poly_int_array poly_int_array; + restr_vars#addList vars_with_fields; + let restr_poly_int_array = + poly_int_array#restrict_to_vars jproc_info restr_vars#toList in + + if !dbg then + pr__debug [STR "get_vars_fields_rel_expres "; NL; + restr_poly_int_array#toPretty; NL]; + + let restr_local_var_map = + List.filter (fun (v1, v2) -> v1#equal v2) local_var_map in + let postconds = + restr_poly_int_array#to_postconditions + true jproc_info restr_local_var_map vars_with_fields in + + if !dbg then + pr__debug [STR "postconds "; + pretty_print_list + postconds + JCHNumericUtils.postcondition_predicate_to_pretty + "{" "; " "}"; NL]; + + let rel_exprs = + List.map JCHNumericUtils.post_predicate_to_relational_expr postconds in + set_st_relational_exprs rel_exprs; + {< >} + + | "get_local_var_invariants" -> + let include_loop_counters = List.length args > 0 in + let postconds = + poly_int_array#to_postconditions + include_loop_counters jproc_info local_var_map [] in + let rel_exprs = + List.map JCHNumericUtils.post_predicate_to_relational_expr postconds in + begin + set_st_relational_exprs rel_exprs; + {< >} + end + | "set_poly_vars" -> + begin + set_st_poly_vars poly_int_array#get_poly_vars; + {< >} + end + | "project_out_loop_counters" -> + let restr_poly_int_array = + self#get_poly_int_array (self#project_out_loop_counters self) in + {< poly_int_array = restr_poly_int_array#remove_duplicates >} + | "remove_duplicates" -> + {< poly_int_array = poly_int_array#remove_duplicates >} + | "drop_poly" -> + {< poly_int_array = poly_int_array#drop_poly >} + | _ -> + begin + pr__debug [ STR "Analysis faied: programming error: "; + STR "poly domain - unrecognized command"; NL]; + raise + (params#analysis_failed + 3 "programming error: poly domain - unrecognized command") + end + + method private project_out (vs:variable_t list) = + self#record_changed_sym_params vs; + {< poly_int_array = poly_int_array#project_out vs >} + + method projectOut (vs:variable_t list) = + if self#isBottom then + {< >} + else + begin + List.iter add_reachable vs; + + let poly_vars = poly_int_array#get_poly_vars in + let num_vs = List.filter (fun v -> List.mem v poly_vars) vs in + if num_vs = [] then + begin + self#record_changed_sym_params vs; + {< >} + end + else + self#project_out num_vs + end + + method private remove (vs: variable_t list) = + if self#isBottom then + {< >} + else + begin + let poly_vars = poly_int_array#get_poly_vars in + let num_vs = List.filter (fun v -> List.mem v poly_vars) vs in + if num_vs = [] then + {< >} + else + begin + let new_poly_int_array = poly_int_array#project_out num_vs in + {< poly_int_array = new_poly_int_array#remove num_vs >} + end + end + + method private is_float v = + let info = jproc_info#get_jvar_info v in + JCHTypeUtils.can_be_float info#get_types + + (* We do not record division by 0 for Float or Double because it does not + * result in an arithmetic exception. + * It produces and infinite number or NaN *) + method private record_div0 div0_opt = + if params#use_types then + match div0_opt with + | Some v -> if not (self#is_float v) then add_div0 v + | _ -> + if !dbg then + pr__debug [proc_name#toPretty; STR " record_div0 not possible "; NL]; + + method private record_overflow overflow_opt = + if params#use_types then + match overflow_opt with + | Some v -> + if not (JCHSystemUtils.is_loop_counter v) then + add_overflow v + else + pr__debug [STR "loop_counter has overflow"] + | _ -> () + + method private record_underflow underflow_opt = + if params#use_types then + match underflow_opt with + | Some v -> add_underflow v + | _ -> () + + method private record_down_cast_overflow pc_opt overflow_opt = + if params#use_types then + match (pc_opt, overflow_opt) with + | (Some _pc, Some v) -> add_overflow v; + | (None, Some v) -> add_convert_overflow v; + | _ -> () + + method private record_down_cast_underflow pc_opt underflow_opt = + if params#use_types then + match (pc_opt, underflow_opt) with + | (Some _pc, Some v) -> add_underflow v; + | (None, Some v) -> add_convert_overflow v; + | _ -> () + + method private affine_image report equality vpair pairs const = + let v = fst vpair in + add_reachable v; + + let (new_poly_int_array, overflow_opt, underflow_opt) = + poly_int_array#affine_image equality vpair pairs const in + if report then + begin + self#record_overflow overflow_opt; + self#record_underflow underflow_opt + end; + (if has_lost_info proc_name (List.map fst pairs) then + log_lost_info proc_name v local_var_map); + {< poly_int_array = new_poly_int_array >} + + (* v and w are different *) + method private affine_subst report v w_opt coeff const = + add_reachable v; + + let (new_poly_int_array, overflow_opt, underflow_opt) = + poly_int_array#affine_subst v w_opt coeff const in + if report then + begin + self#record_overflow overflow_opt; + self#record_underflow underflow_opt + end; + (match w_opt with + | Some w -> + if has_lost_info proc_name [w] then + log_lost_info proc_name v local_var_map + | _ -> ()); + {< poly_int_array = new_poly_int_array >} + + (* v = v + const *) + method private affine_increment report v const = + add_reachable v; + + let (new_poly_int_array, overflow_opt, underflow_opt) = + poly_int_array#affine_increment v const in + (if report then + begin + self#record_overflow overflow_opt; + self#record_underflow underflow_opt + end); + {< poly_int_array = new_poly_int_array >} + + method private affine_image_down_cast + pc_opt equality vpair pairs const _src _dst dst_interval_opt = + let v = fst vpair in + add_reachable v; + + let (new_poly_int_array, overflow_opt, underflow_opt) = + poly_int_array#affine_image equality vpair pairs const in + (if has_lost_info proc_name (List.map fst pairs) then + log_lost_info proc_name v local_var_map); + if Option.is_some overflow_opt || Option.is_some underflow_opt then + begin + self#record_down_cast_overflow pc_opt overflow_opt; + self#record_down_cast_underflow pc_opt underflow_opt; + {< poly_int_array = new_poly_int_array >} + end + else + begin + match dst_interval_opt with + | Some dst_interval -> + begin + let var = fst vpair in + let interval = new_poly_int_array#get_interval var in + if not (interval#leq dst_interval) then + begin + let new_poly_int_array = + new_poly_int_array#project_out [var] in + (if interval#getMax#gt dst_interval#getMax then + self#record_down_cast_overflow pc_opt (Some var)); + (if interval#getMin#lt dst_interval#getMin then + self#record_down_cast_underflow pc_opt (Some var)); + {< poly_int_array = new_poly_int_array >} + end + else + {< poly_int_array = new_poly_int_array >} + end + | _ -> {< poly_int_array = new_poly_int_array >} + end + + method private down_cast_float src dst = + add_reachable dst; + + let (new_poly_int_array, is_overflow) = + poly_int_array#down_cast_float src dst in + (if is_overflow then add_convert_overflow dst); + {< poly_int_array = new_poly_int_array >} + + method private affine_preimage vpair pairs const = + {< poly_int_array = poly_int_array#affine_preimage vpair pairs const >} + + method getNonRelationalValue v = + let interval = poly_int_array#get_interval v in + mkIntervalValue interval + + method importNumericalConstraints + (_csts: CHNumericalConstraints.numerical_constraint_t list) = + {< >} + + method importNonRelationalValues + ?(refine = true) + (pairs:(variable_t * non_relational_domain_value_t) list) = + {< >} + + val neg_unit_big_int = minus_big_int unit_big_int + + method private mult v x y = + add_reachable v; + + let (new_poly_int_array, overflow_opt, underflow_opt, lost_info) = + poly_int_array#mult v x y in + self#record_overflow overflow_opt; + self#record_underflow underflow_opt; + (if lost_info then + log_lost_info proc_name v local_var_map + else + unlog_lost_info proc_name v); + {< poly_int_array = new_poly_int_array >} + + method private div v x y = + add_reachable v; + + let is_float = self#is_float v in + let (new_poly_int_array, div0_opt, overflow_opt, underflow_opt) = + poly_int_array#div is_float v x y in + (if not is_float then + begin + self#record_div0 div0_opt; + self#record_overflow overflow_opt; + self#record_underflow underflow_opt; + end); + {< poly_int_array = new_poly_int_array >} + + method private rem v x y = + add_reachable v; + + let is_float = self#is_float v in + let (new_poly_int_array, div0_opt) = poly_int_array#rem is_float v x y in + (if not is_float then self#record_div0 div0_opt); + {< poly_int_array = new_poly_int_array >} + + method private update_fields new_poly_int_array var = + (match !variable_to_fields#get var with + | Some fields -> + begin + let int = new_poly_int_array#get_interval var in + match jproc_info#get_length var with + | Some length_var -> + let length_interval = new_poly_int_array#get_interval length_var in + fields#iter + (fun fi -> + JCHFields.int_field_manager#put_field + proc_name fi int [length_interval] true var) + | _ -> + fields#iter + (fun fi -> + JCHFields.int_field_manager#put_field proc_name fi int [] false var) + end + | None -> () ) + + method private project_out_fields var = + match !variable_to_fields#get var with + | Some fields -> fields#iter JCHFields.int_field_manager#project_out + | None -> () + + method private project_out_loop_counters (a: 'a) : 'a = + let apoly_int_array = self#get_poly_int_array a in + let loop_counters = + List.filter JCHSystemUtils.is_loop_counter apoly_int_array#get_poly_vars in + a#projectOut loop_counters + + method private project_out_lengths (a: 'a) : 'a = + let apoly_int_array = self#get_poly_int_array a in + let lengths = + List.filter JCHSystemUtils.is_length apoly_int_array#get_poly_vars in + a#projectOut lengths + + method analyzeBwd (cmd: (code_int, cfg_int) command_t) : 'a = + if self#isBottom then + match cmd with + | ASSERT e -> + self#mkEmpty#analyzeFwd (ASSERT (negate_bool_exp e)) + | _ -> + self#mkBottom + else + match cmd with + | ABSTRACT_VARS l -> + self#projectOut l + | ASSIGN_NUM (v, NUM _n) -> + if self#is_const v then + self#clone + else + self#projectOut [v] + + | ASSIGN_NUM (v, NUM_VAR w) -> + if self#is_const v then + self#clone + else if v#equal w then + self#clone + else if self#is_const w then + self#projectOut [v] + else + self#affine_preimage + (v, unit_big_int) [(w, unit_big_int)] zero_big_int + + | ASSIGN_NUM (v, PLUS (x, y)) -> + if self#is_const x then + if self#is_const y then + self#projectOut [v] + else + self#affine_preimage + (v,unit_big_int) [(y,unit_big_int)] (self#get_const_val x) + else + if self#is_const y then + self#affine_preimage + (v,unit_big_int) [(x,unit_big_int)] (self#get_const_val y) + else + self#affine_preimage + (v,unit_big_int) [(x,unit_big_int); (y,unit_big_int)] zero_big_int + + | ASSIGN_NUM (v, MINUS (x, y)) -> + if self#is_const x then + if self#is_const y then + self#projectOut [v] + else + self#affine_preimage + (v,unit_big_int) [(y, neg_unit_big_int)] (self#get_const_val x) + else + if self#is_const y then + self#affine_preimage + (v, unit_big_int) [(x,unit_big_int)] (minus_big_int (self#get_const_val y)) + else + self#affine_preimage + (v,unit_big_int) [(x,unit_big_int); (y, neg_unit_big_int)] zero_big_int + + | ASSIGN_NUM (v, MULT (x,y)) -> + if self#is_const x then + if self#is_const y then + self#projectOut [v] + else + self#affine_preimage + (v,unit_big_int) [(y,self#get_const_val x)] zero_big_int + else + if self#is_const y then + self#affine_preimage + (v,unit_big_int) [(x,self#get_const_val y)] zero_big_int + else + self#projectOut [v] + + | ASSIGN_NUM (v, DIV (_x, _y)) -> self#projectOut [v] + | INCREMENT (v, n) -> self#analyzeFwd (INCREMENT (v, n#neg)) + | ASSERT TRUE -> self#clone + | ASSERT FALSE -> self#mkBottom + | ASSERT _ -> self#analyzeFwd cmd + | _ -> self#clone + + method analyzeFwd (cmd: (code_int, cfg_int) command_t) : 'a = + + let _ = + if !dbg then + pr__debug [STR "PolyDom.analyzeFwd "; + command_to_pretty 0 cmd; NL; self#to_pretty; NL] in + try + self#analyzeFwd_ cmd + with + | JCHAnalysisUtils.JCH_num_analysis_failure _ -> + if params#get_analysis_status = 1 then + begin + params#reset_analysis_failure_status; + ({< poly_int_array = poly_int_array#drop_poly >})#analyzeFwd cmd + end + else + raise + (params#analysis_failed + (params#get_analysis_status) (params#get_analysis_failure_reason)) + | _ -> + begin + pr__debug [STR "Analysis failed:unknown programming error in analyzeFwd"; NL]; + raise (params#analysis_failed 3 "unknown programming error in analyzeFwd") + end + + method private analyzeFwd_ (cmd: (code_int, cfg_int) command_t) : 'a = + + let _ = + if !dbg then + pr__debug [STR "PolyDom.analyzeFwd_ "; command_to_pretty 0 cmd; NL; + self#to_pretty; NL] in + + let res = + let default () = {< >} in + let default_v v = + add_reachable v; + {< >} in + if self#reached_time_limit then + begin + params#set_use_intervals true; + let a = {< poly_int_array = poly_int_array#drop_poly >} in + a#analyzeFwd cmd + end + else if self#isBottom then + self#mkBottom + else + match cmd with + | ABSTRACT_VARS l -> + List.iter add_reachable l; + let poly_vars = self#get_poly_vars in + let red_l = List.filter (fun v -> List.mem v poly_vars) l in + self#projectOut red_l + + | ASSIGN_NUM (v, NUM n) -> + if self#is_const v then + default_v v + else + self#affine_subst false v None zero_big_int n#getNum + + | ASSIGN_NUM (v, NUM_VAR w) -> + begin + let a = + if self#is_const v then + default_v v + else if self#is_const w then + self#affine_subst + false v None zero_big_int (self#get_const_val w) + else + self#affine_subst false v (Some w) unit_big_int zero_big_int in + let b = + if JCHSystemUtils.is_length w then + let pia = self#get_poly_int_array a in + {< poly_int_array = pia#transfer_fields true w v >} + else + a in + self#change_local_var_map b v w + end + + | ASSIGN_NUM (v, PLUS (x, y)) -> + if self#is_const x then + if self#is_const y then + let n = add_big_int (self#get_const_val x) (self#get_const_val y) in + self#affine_subst true v None zero_big_int n + else if v#equal y then + self#affine_increment true v (self#get_const_val x) + else + self#affine_subst + true v (Some y) unit_big_int (self#get_const_val x) + else if self#is_const y then + if v#equal x then + self#affine_increment true v (self#get_const_val y) + else + self#affine_subst + true + v + (Some x) + unit_big_int + (self#get_const_val y) + else + self#affine_image + true + None + (v, unit_big_int) + [(x, unit_big_int); (y, unit_big_int)] + zero_big_int + + | ASSIGN_NUM (v, MINUS (x, y)) -> + if self#is_const x then + if self#is_const y then + let n = + add_big_int + (self#get_const_val x) (minus_big_int (self#get_const_val y)) in + self#affine_subst true v None zero_big_int n + else if v#equal y then + self#affine_image + true + None + (v, unit_big_int) + [(y, neg_unit_big_int)] + (self#get_const_val x) + else + self#affine_subst + true v (Some y) neg_unit_big_int (self#get_const_val x) + else if self#is_const y then + let n = minus_big_int (self#get_const_val y) in + if v#equal x then + self#affine_increment true v n + else + self#affine_subst true v (Some x) unit_big_int n + else + self#affine_image + true + None + (v, unit_big_int) + [(x, unit_big_int); (y, neg_unit_big_int)] + zero_big_int + + | ASSIGN_NUM (v, MULT (x, y)) -> + if self#is_const x then + if self#is_const y then + let n = mult_big_int (self#get_const_val x) (self#get_const_val y) in + self#affine_subst true v None zero_big_int n + else if v#equal y then + self#affine_image + true + None + (v, unit_big_int) + [(y, self#get_const_val x)] + zero_big_int + else + self#affine_subst + true v (Some y) (self#get_const_val x) zero_big_int + else if self#is_const y then + if v#equal x then + self#affine_image + true + None + (v, unit_big_int) + [(x, self#get_const_val y)] + zero_big_int + else + self#affine_subst true v (Some x) (self#get_const_val y) zero_big_int + else self#mult v x y + + | ASSIGN_NUM (v, DIV (x, y)) -> self#div v x y + | INCREMENT (v, n) -> self#affine_increment true v n#getNum + | ASSERT TRUE -> default () + | ASSERT FALSE -> self#mkBottom + + | ASSERT (EQ (x, y)) -> + if JCHAnalysisUtils.is_numeric + jproc_info x && JCHAnalysisUtils.is_numeric jproc_info y then + begin + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_eq x y >} + end + else default () + + | ASSERT (GEQ (x, y)) -> + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_geq x y >} + | ASSERT (GT (x, y)) -> + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_gt x y >} + | ASSERT (LEQ (x, y)) -> + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_geq y x >} + | ASSERT (LT (x, y)) -> + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_gt y x >} + | ASSERT (NEQ (x, y)) -> + transfer_lost_info proc_name x y local_var_map; + {< poly_int_array = poly_int_array#assert_neq x y >} + | DOMAIN_OPERATION (doms, op) -> + if List.mem poly_dom_name doms then + begin + let pid = + self#analyzeOperation + ~domain_name:poly_dom_name + ~fwd_direction:true + ~operation:op in + pid + end + else + default () + + | ASSIGN_SYM (v, SYM_VAR w) -> + let a = + if JCHAnalysisUtils.is_numeric jproc_info v then + if JCHAnalysisUtils.is_numeric jproc_info w then + self#affine_subst false v (Some w) unit_big_int zero_big_int + else self#projectOut [v] + else default_v v in + self#change_local_var_map a v w + + | ASSIGN_SYM (v, _) + | ASSIGN_STRUCT (v, _) -> + default_v v + | _ -> + default () in + let _ = + if !dbg then + pr__debug [STR "after PolyDom.analyzeFwd_ res"; NL; res#toPretty; NL] in + res + + method private to_pretty = + LBLOCK [ STR "poly_int_domain: "; + (if params#use_intervals then STR "use intervals " else STR ""); NL; + INDENT (5, poly_int_array#to_pretty); NL ] + + method toPretty = self#to_pretty + + method analyzeFwdInTransaction = self#analyzeFwd + + method analyzeBwdInTransaction = self#analyzeBwd + + method private invoke_with_target + (_is_static:bool) + (iInfo:instruction_info_int) + args + num_wvars + _num_rvars + coll_rvars + all_wvars:'a = + + if !dbg then + pr__debug [STR "invoke_with_target "; NL; iInfo#toPretty; NL]; + + let other_lengths = + let all_wvars_lengths = + let ls = ref [] in + let add_length v = + match jproc_info#get_length v with + | Some l -> ls := l :: !ls + | _ -> () in + List.iter add_length all_wvars; + List.rev !ls in + List.filter (fun v -> not (List.mem v all_wvars)) all_wvars_lengths in + + (if !dbg then + pr__debug [STR "other_lengths = "; pp_list other_lengths; NL]); + + let invoke_unknown () = + List.iter self#project_out_fields coll_rvars; + self#project_out (all_wvars @ other_lengths) in + + let mtarget = iInfo#get_method_target () in + if mtarget#is_top then + invoke_unknown () + else if mtarget#is_top then + begin + List.iter self#project_out_fields coll_rvars; + self#project_out (all_wvars @ other_lengths) + end + else + begin + let procs = + List.filter (fun p -> + not (JCHSystem.jsystem#not_analyzed p#getSeqNumber)) mtarget#get_procs in + let stubs = mtarget#get_stubs in + + let _ = if !dbg then pr__debug [STR "procs = "; pp_list procs; NL] in + let _ = if !dbg then pr__debug [STR "stubs = "; pp_list stubs; NL] in + + (* record the call so that we know the context in which we have to analyze + * the callee *) + if procs <> [] then + begin + let record_call invoked_proc_name = + let (sig_vars, sig_lengths, length_to_var) = + JCHIntStubs.int_stub_manager#get_all_call_vars invoked_proc_name in + + (if !dbg then pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]); + (if !dbg then pr__debug [STR "sig_lengths = "; pp_list sig_lengths; NL]); + (if !dbg then + pr__debug [STR "sig_vars_with_lengths = "; + pp_list (length_to_var#listOfValues); NL]); + + let (invoked_args, + _sig_lengths_not_included, + _missing_length_inds) = + JCHAnalysisUtils.include_all_length_vars + jproc_info (JCHSystemUtils.get_read_vars args) + sig_vars length_to_var in + + (if !dbg then + pr__debug [STR "invoked_args = "; pp_list invoked_args; NL]); + + let call_poly_int_array = + poly_int_array#get_call jproc_info invoked_args in + + (if !dbg then + pr__debug [STR "record_call call_poly_int_array = "; NL; + call_poly_int_array#toPretty; NL]); + + JCHIntStubs.int_stub_manager#record_poly_int_array_call + jproc_info#get_name invoked_proc_name call_poly_int_array in + List.iter record_call procs; + + if !dbg then pr__debug [STR "after record_call"; NL] + end; + + if procs = [] && stubs = [] then + begin + List.iter self#project_out_fields coll_rvars; + self#project_out (all_wvars @ other_lengths) + end + else if all_wvars = [] then {< >} + else + begin + let arg_vars = List.map (fun (_,v,_) -> v) args in + let _ = if !dbg then pr__debug [STR "arg_vars = "; pp_list arg_vars; NL] in + let (empty_collections, _non_empty_collections) = + let is_empty_collection v = + poly_int_array#get_extra_infos#is_empty_collection v in + let (empty, non_empty) = List.partition is_empty_collection coll_rvars in + (VariableCollections.set_of_list empty, non_empty) in + + let (invoked_poly_int_array, invoked_conds, sig_vars_opt) = + + let (invoked_proc_poly_int_array, proc_sig_vars, proc_sig_arrays, + invoked_stub_poly_int_array, stub_sig_vars, stub_sig_arrays, conds) = + JCHIntStubs.int_stub_manager#invoke_poly_int_array jproc_info procs stubs in + + (if !dbg then pr__debug [STR "after invoke_poly_int_array"; NL]); + + let stub_sig_vars_opt = + match invoked_stub_poly_int_array with + | None -> None + | _ -> Some stub_sig_vars in + let add_invoked + res_poly_int_array invoked_poly_int_array_opt sig_vars sig_arrays = + match invoked_poly_int_array_opt with + | Some invoked_poly_int_array -> + + (if !dbg then + pr__debug [STR "invoked_poly_int_array = "; NL; + invoked_poly_int_array#toPretty; NL]); + + (if invoked_poly_int_array#is_bottom then + raise (JCH_no_return_proc (mtarget#toPretty))); + + let inds_to_eliminate = ref [] in + let invoked_vars = ref [] in + let check_arg ind (_, arg, _) = + (if JCHAnalysisUtils.is_numeric jproc_info arg then + invoked_vars := arg :: !invoked_vars + else + inds_to_eliminate := ind :: !inds_to_eliminate); + ind + 1 in + let ind = List.fold_left check_arg 0 args in + let assoc_arg_sig = List.combine args sig_vars in + + (if !dbg then + pr__debug [STR "sig_arrays = "; pp_list sig_arrays; NL]); + + let check_arrays ind array = + + (if !dbg then + pr__debug [STR "check_arrays "; INT ind; STR " "; + array#toPretty; NL]); + (if !dbg then + pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]); + (if !dbg then + pr__debug [STR "args = "; + pp_list (List.map (fun (_,v,_) -> v) args); NL]); + + let ((_,arg,_), _) = + List.find (fun (_v, v') -> + v'#getName#equal array#getName) assoc_arg_sig in + + (if !dbg then pr__debug [STR "arg = "; arg#toPretty; NL]); + + let arg_info = jproc_info#get_jvar_info arg in + if not arg_info#has_length then + begin + (if !dbg then + pr__debug [STR "add ind to eliminate for arg_info = "; + arg_info#toPretty; STR " "; INT ind; NL]); + + inds_to_eliminate := ind :: !inds_to_eliminate + end; + ind + 1 in + let _ = List.fold_left check_arrays ind sig_arrays in + let invoked_vars = List.rev !invoked_vars in + + let (invoked_lengths, invoked_target_lengths) = + let lens = ref [] in + let target_lens = ref [] in + let add_var var target_var = + + (if !dbg then + pr__debug [STR "add_var "; var#toPretty; STR " "; + target_var#toPretty; NL]); + + match jproc_info#get_length var with + | Some len -> + lens := len :: !lens; + if (List.exists (fun v -> + v#equal target_var) sig_arrays) then + (* The invoked target might have argument that are + * objects rather than arrays *) + target_lens := len :: !target_lens + | _ -> () in + List.iter2 add_var arg_vars sig_vars; + (List.rev !lens, List.rev !target_lens) in + let all_invoked_vars = invoked_vars @ invoked_target_lengths in + + let _ = + (if !dbg then + pr__debug [STR "all_invoked_vars = "; + pp_list all_invoked_vars; NL]) in + + let arg_length = List.length arg_vars + List.length sig_arrays in + let meet_poly_int_array = + res_poly_int_array#meet_invoked + invoked_poly_int_array + !inds_to_eliminate arg_length + invoked_vars + invoked_lengths + invoked_target_lengths + num_wvars + coll_rvars in + let changed = + List.filter + invoked_poly_int_array#get_extra_infos#is_changed_sym_param + all_invoked_vars in + + (if !dbg then + pr__debug [STR "variables changed in invoke = "; + pp_list changed; NL]); + + self#record_changed_sym_params changed; + + (if !dbg then + pr__debug [STR "meet_poly_int_array = "; NL; + meet_poly_int_array#toPretty; NL]); + + meet_poly_int_array + | _ -> poly_int_array#project_out all_wvars in + (add_invoked + (add_invoked + poly_int_array + invoked_proc_poly_int_array + proc_sig_vars + proc_sig_arrays) + invoked_stub_poly_int_array + stub_sig_vars + stub_sig_arrays, conds, stub_sig_vars_opt) in + + (if !dbg then + pr__debug [STR "invoked_poly_int_array "; NL; + invoked_poly_int_array#toPretty; NL]); + + (if !dbg then + pr__debug [STR "empty_collections = "; + empty_collections#toPretty; NL]); + + let changed_vars = ref [] in + let add_cond p_int_array cond = + + (if !dbg then + pr__debug [STR "add_cond "; NL; p_int_array#toPretty; NL; + JCHIntStubs.stub_condition_to_pretty cond; NL]); + match cond with + | JCHIntStubs.CheckReturnType -> + let ret = JCHSystemUtils.get_arg_var "return" args in + p_int_array#check_type ret + | JCHIntStubs.JoinInfo (src1, src2, dst) -> + begin + match sig_vars_opt with + | Some sig_vars -> + (if !dbg then + pr__debug [STR "arg_vars = "; pp_list arg_vars; NL]); + + (if !dbg then + pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]); + + let sig_var_arg_var = + List.combine + (List.map (fun v -> v#getIndex) sig_vars) arg_vars in + let dst_var = List.assoc dst#getIndex sig_var_arg_var in + let src1_var = List.assoc src1#getIndex sig_var_arg_var in + let src2_var = List.assoc src2#getIndex sig_var_arg_var in + changed_vars := dst_var :: !changed_vars; + if JCHAnalysisUtils.is_numeric jproc_info dst_var then + if JCHAnalysisUtils.is_numeric jproc_info src1_var + && JCHAnalysisUtils.is_numeric jproc_info src2_var then + begin + empty_collections#remove dst_var; + p_int_array#set_join dst_var src1_var src2_var + end + else + p_int_array#project_out [dst_var] + else + p_int_array + | None -> p_int_array + end + | JCHIntStubs.CopyInfo (var1, var2) -> + begin + + (if !dbg then + pr__debug [STR "CopyInfo "; var1#toPretty; STR " "; + INT var1#getIndex; STR " "; var2#toPretty; + STR " "; INT var2#getIndex; NL]); + + match sig_vars_opt with + | Some sig_vars -> + (if !dbg then + pr__debug [STR "arg_vars = "; pp_list arg_vars; NL]); + + (if !dbg then + pr__debug [STR "sig_vars = "; pp_list sig_vars; NL]); + + let sig_var_arg_var = + List.combine + (List.map (fun v -> v#getIndex) sig_vars) arg_vars in + let arg1 = List.assoc var1#getIndex sig_var_arg_var in + let arg2 = List.assoc var2#getIndex sig_var_arg_var in + + (if !dbg then + pr__debug [STR "arg1 = "; arg1#toPretty; + STR ", arg2 = "; arg2#toPretty; NL]); + + changed_vars := arg2 :: !changed_vars; + if JCHAnalysisUtils.is_numeric jproc_info arg2 then + if JCHAnalysisUtils.is_numeric jproc_info arg1 then + let interval = poly_int_array#get_interval arg1 in + let excluded_vals = + poly_int_array#get_extra_infos#get_excluded_vals arg1 in + p_int_array#copy_info arg2 interval excluded_vals + else + p_int_array#project_out [arg2] + else + p_int_array + | None -> p_int_array + end + | JCHIntStubs.PostInterval (var, interval) -> + begin + match sig_vars_opt with + | Some sig_vars -> + let sig_var_arg_var = + List.combine (List.map (fun v -> v#getIndex) sig_vars) arg_vars in + let arg = List.assoc var#getIndex sig_var_arg_var in + changed_vars := arg :: !changed_vars; + if JCHAnalysisUtils.is_numeric jproc_info arg then + p_int_array#set_interval var interval + else + p_int_array + | None -> p_int_array + end + | JCHIntStubs.Abstract var -> + begin + match sig_vars_opt with + | Some sig_vars -> + let sig_var_arg_var = + List.combine (List.map (fun v -> v#getIndex) sig_vars) arg_vars in + let arg = List.assoc var#getIndex sig_var_arg_var in + changed_vars := arg :: !changed_vars; + if JCHAnalysisUtils.is_numeric jproc_info arg then + p_int_array#project_out [arg] + else + p_int_array + | _ -> p_int_array + end in + + self#record_changed_sym_params !changed_vars; + let cond_poly_int = + let pia_cond = + List.fold_left add_cond invoked_poly_int_array invoked_conds in + let add_empty pia v = pia#add_empty_collection v in + List.fold_left add_empty pia_cond empty_collections#toList in + + let length_poly_int = + let unassigned_lengths = + List.filter (fun l -> + (cond_poly_int#get_interval l)#isBottom) other_lengths in + cond_poly_int#project_out unassigned_lengths in + let red_poly_int = length_poly_int#move_simple_ineqs in + let best_poly_int = red_poly_int#set_best_intervals in + let is_restricted v = + JCHAnalysisUtils.is_numeric jproc_info v && not (self#is_const v) in + + let restrict_poly_int = + best_poly_int#restrict_to_type (List.filter is_restricted arg_vars) in + + List.iter (self#update_fields restrict_poly_int) coll_rvars; + if params#use_intervals then + {< poly_int_array = restrict_poly_int#drop_poly >} + else + {< poly_int_array = restrict_poly_int >} + end + end + + method private invoke + (is_static:bool) + _cn_msig_opt + (iInfo:instruction_info_int) + args = + + let _ = + if !dbg then + pr__debug [STR "analyze_invoke "; proc_name_pp proc_name; NL; + iInfo#toPretty; NL] in + + let res = + let wvars = JCHSystemUtils.get_write_vars args in + List.iter add_reachable wvars; + let num_wvars = List.filter (JCHAnalysisUtils.is_numeric jproc_info) wvars in + let rvars = JCHSystemUtils.get_read_vars args in + let num_rvars = + List.filter (JCHAnalysisUtils.is_numeric jproc_info) rvars in + let coll_rvars = + List.filter (JCHAnalysisUtils.is_collection_or_array jproc_info) num_rvars in + let all_wvars = num_wvars @ coll_rvars in + + (* remove some targets *) + if iInfo#has_method_target then + begin + try + self#invoke_with_target + is_static iInfo args num_wvars num_rvars coll_rvars all_wvars + with + | JCH_no_return_proc _pp -> self#mkBottom + end + else + begin + List.iter self#project_out_fields coll_rvars; + self#project_out all_wvars; + end in + + let _ = + begin + (if !dbg then pr__debug [STR "after invoke, res = "; res#toPretty; NL]); + if iInfo#has_method_target && !dbg then + pr__debug [STR "mtarget = "; NL; + (iInfo#get_method_target ())#toPretty; NL] + end in + + res + + method analyzeOperation + ~(domain_name: string) + ~(fwd_direction: bool) + ~(operation: operation_t): 'a = + + let _ = + if !dbg then + pr__debug [STR "PolyDom.analyzeOperation "; + operation_to_pretty operation; NL; + self#toPretty; NL] in + + let res = + match operation.op_name#getBaseName with + |"init_params" -> + List.iter + add_reachable (JCHSystemUtils.get_write_vars operation.op_args); + if self#isBottom || poly_int_array#is_top then + {< >} + else + let simple_poly_int_array = poly_int_array#move_simple_ineqs in + {< poly_int_array = simple_poly_int_array >} + | "init_assumptions" -> + List.iter add_reachable (JCHSystemUtils.get_write_vars operation.op_args); + if self#isBottom then + {< >} + else + let p = poly_int_array#init_assumptions jproc_info in + {< poly_int_array = p >} + | "add_vars" -> {< >} + | "remove_vars" -> + let vars = List.map (fun (_,v,_) -> v) operation.op_args in + self#remove vars + | "i" + | "ii" -> + let pc = operation.op_name#getSeqNumber in + let bcloc = get_bytecode_location cms#index pc in + let iInfo = app#get_instruction bcloc in + begin + match mInfo#get_opcode pc with + | OpInvokeStatic (cn, msig) -> + self#invoke true (Some (cn, msig)) iInfo operation.op_args + | OpInvokeVirtual _ -> + self#invoke false None iInfo operation.op_args + | OpInvokeInterface (cn, msig) + | OpInvokeSpecial (cn, msig) -> + self#invoke false (Some (cn, msig)) iInfo operation.op_args + | OpNew _cn -> + let var = JCHSystemUtils.get_arg_var "ref" operation.op_args in + add_reachable var; + + if JCHAnalysisUtils.is_numeric jproc_info var then + let new_poly_int_array = poly_int_array#project_out [var] in + if JCHAnalysisUtils.is_collection jproc_info var then + {< poly_int_array = new_poly_int_array#add_empty_collection var >} + else + {< poly_int_array = new_poly_int_array >} + else + {< >} + | OpGetStatic _ + | OpGetField _ -> + let var = JCHSystemUtils.get_arg_var "val" operation.op_args in + add_reachable var; + + JCHFields.int_field_manager#record_field iInfo; + if JCHAnalysisUtils.is_numeric jproc_info var then + begin + if JCHAnalysisUtils.is_collection_or_array jproc_info var then + add_variable_to_field var iInfo; + let intervals = + JCHFields.int_field_manager#get_field_intervals + iInfo#get_field_target in + let fInfo = iInfo#get_field_target in + {< poly_int_array = + poly_int_array#get_field jproc_info fInfo intervals var >} + end + else + {< >} + | OpPutStatic _ + | OpPutField _ -> + let var = JCHSystemUtils.get_arg_var "val" operation.op_args in + if JCHAnalysisUtils.is_numeric jproc_info var then + begin + let fInfo = iInfo#get_field_target in + {< poly_int_array = poly_int_array#add_field var fInfo >} + end + else {< >} + + | OpNewArray _ -> + let array = JCHSystemUtils.get_arg_var "ref" operation.op_args in + let length = JCHSystemUtils.get_arg_var "length" operation.op_args in + add_reachable array; + + if JCHAnalysisUtils.is_numeric jproc_info array then + {< poly_int_array = poly_int_array#new_array array [length] >} + else + {< >} + + | OpAMultiNewArray _ -> + let array = JCHSystemUtils.get_arg_var "ref" operation.op_args in + let dims = JCHSystemUtils.get_read_vars operation.op_args in + add_reachable array; + + if JCHAnalysisUtils.is_numeric jproc_info array then + {< poly_int_array = poly_int_array#new_array array dims >} + else + {< >} + + | OpArrayStore _ -> + let array = JCHSystemUtils.get_arg_var "array" operation.op_args in + let element = JCHSystemUtils.get_arg_var "val" operation.op_args in + let index = JCHSystemUtils.get_arg_var "index" operation.op_args in + record_array_access poly_int_array array index; + self#record_changed_sym_params [array]; + + if JCHAnalysisUtils.is_numeric jproc_info array then + if JCHAnalysisUtils.is_numeric jproc_info element then + let new_poly_int_array = + poly_int_array#set_join array element array in + begin + self#update_fields new_poly_int_array array; + {< poly_int_array = new_poly_int_array >} + end + else + begin + self#project_out_fields array; + {< poly_int_array = poly_int_array#project_out_array array >} + end + else + {< >} + + | OpArrayLoad _ -> + let array = JCHSystemUtils.get_arg_var "array" operation.op_args in + let element = JCHSystemUtils.get_arg_var "val" operation.op_args in + let index = JCHSystemUtils.get_arg_var "index" operation.op_args in + record_array_access poly_int_array array index; + let new_poly_int_array = poly_int_array in (* CHANGE : bring back info about the dims *) + add_reachable element; + + if JCHAnalysisUtils.is_numeric jproc_info element then + if JCHAnalysisUtils.is_numeric jproc_info array then + {< poly_int_array = new_poly_int_array#array_load array element >} + else + self#projectOut [element] + else + begin + self#record_changed_sym_params [array]; + {< >} + end + + | OpArrayLength -> + let var = JCHSystemUtils.get_arg_var "ref" operation.op_args in + let length = JCHSystemUtils.get_arg_var "val" operation.op_args in + add_reachable length; + {< poly_int_array = poly_int_array#transfer_fields false length var >} + + | OpCheckCast _ -> + let ref = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let ref_new_type = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + add_reachable ref_new_type; + + if JCHAnalysisUtils.is_numeric jproc_info ref_new_type then + if JCHAnalysisUtils.is_numeric jproc_info ref then + begin + (* We are not using affine_image here because there + * cannot be over/underflow *) + let (new_poly_int_array, _, _) = + if self#is_const ref then + poly_int_array#affine_subst + ref_new_type None zero_big_int (self#get_const_val ref) + else + poly_int_array#affine_subst + ref_new_type (Some ref) unit_big_int zero_big_int in + {< poly_int_array = new_poly_int_array >} + end + else + self#copy_num_info (self#projectOut [ref_new_type]) ref_new_type ref + else + self#copy_num_info self ref_new_type ref + + | OpI2F -> (* [-2^23,2^23] is a safe conversion range ? *) + let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + if self#is_const src1 then + begin + let const = self#get_const_val src1 in + if le_big_int const (big_int_of_int 8388608) + && ge_big_int const (big_int_of_int (-8388608)) then + self#affine_subst false dst1 None zero_big_int const + else + self#project_out [dst1] (* CHANGE *) + end + else + begin + let src1_int = poly_int_array#get_interval src1 in + let max_conversion_int = + mkInterval (mkNumerical (-8388608)) (mkNumerical 8388608) in + if src1_int#leq max_conversion_int then + self#affine_subst false dst1 (Some src1) unit_big_int zero_big_int + else self#project_out [dst1] (* CHANGE *) + end + + | OpI2L + | OpI2D + | OpL2F + | OpL2D + | OpF2D -> + let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + if self#is_const src1 then + self#affine_subst + false dst1 None zero_big_int (self#get_const_val src1) + else + self#affine_subst + false dst1 (Some src1) unit_big_int zero_big_int + + | OpD2L + | OpD2I + | OpF2I + | OpF2L -> + let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + self#down_cast_float src1 dst1 + + | OpL2I -> + let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let tp_interval_opt = None in + if self#is_const src1 then + self#affine_image_down_cast + None + None + (dst1, unit_big_int) + [] + (self#get_const_val src1) + src1 + dst1 + tp_interval_opt + else + self#affine_image_down_cast + None + (Some src1) + (dst1, unit_big_int) + [(src1, unit_big_int)] + zero_big_int + src1 + dst1 + tp_interval_opt + | OpI2B + | OpI2C + | OpI2S -> + let src1 = JCHSystemUtils.get_arg_var "src1" operation.op_args in + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let pc = iInfo#get_location#get_pc in + let tp_interval_opt = + (* type of the variable could be int although although the + * truncation is to byte, char or short *) + match iInfo#get_opcode with + | OpI2B -> Some (JCHTypeUtils.byte_interval) + | OpI2C -> Some (JCHTypeUtils.char_interval) + | OpI2S -> Some (JCHTypeUtils.short_interval) + | _ -> None in + let pc_opt = if !arith_casts#has pc then Some pc else None in + if self#is_const src1 then + self#affine_image_down_cast + pc_opt + None + (dst1, unit_big_int) + [] + (self#get_const_val src1) + src1 + dst1 + tp_interval_opt + else + self#affine_image_down_cast + pc_opt + (Some src1) + (dst1, unit_big_int) + [(src1, unit_big_int)] + zero_big_int + src1 + dst1 + tp_interval_opt + + | OpD2F -> + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + self#projectOut [dst1] + + | OpFloatConst f + | OpDoubleConst f -> + let dst1 = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + begin + add_reachable dst1; + {< poly_int_array = poly_int_array#float_const dst1 f >} + end + + | OpAdd Float + | OpAdd Double -> + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + self#affine_image + false + None + (v, unit_big_int) + [(x, unit_big_int); (y, unit_big_int)] + zero_big_int + + | OpSub Float + | OpSub Double -> + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + self#affine_image + false + None + (v, unit_big_int) + [(x, unit_big_int); (y, neg_unit_big_int)] + zero_big_int + + | OpMult Float + | OpMult Double -> + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + self#mult v x y + + | OpDiv Float + | OpDiv Double -> + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + self#div v x y + + | OpRem _ -> + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + self#rem v x y + + | OpIAnd + | OpLAnd -> + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + begin + add_reachable v; + {< poly_int_array = poly_int_array#log_and v x y >} + end + + | OpIOr + | OpLOr -> + let x = JCHSystemUtils.get_arg_var "src1_1" operation.op_args in + let y = JCHSystemUtils.get_arg_var "src1_2" operation.op_args in + let v = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + begin + add_reachable v; + {< poly_int_array = poly_int_array#log_and v x y >} + end + + | OpStore (t, n) -> + let is_r_n v = + let name = v#getName in + let base_name = name#getBaseName in + if base_name.[0] = 'r' + && base_name.[1] <> 'e' + && (int_of_string (Str.string_after base_name 1)) = n then + match t with + | Object -> (List.hd name#getAttributes) = "sym" + | _ -> (List.hd name#getAttributes) = "num" + else + false in + let (_, rest_local_var_map) = + List.partition (fun (orig_v, _v) -> is_r_n orig_v) local_var_map in + let new_var = JCHSystemUtils.get_arg_var "dst1" operation.op_args in + let orig_var = + try + List.find is_r_n orig_local_vars + with + | Not_found -> + raise + (JCH_failure + (LBLOCK [ + STR "original variable not found in "; + STR "JCHPolyIntDomainNoArrays.analyzeOperation" ])) in + let new_local_var_map = (orig_var, new_var) :: rest_local_var_map in + {< local_var_map = new_local_var_map >} + + | _ -> + begin + pr__debug [ + STR "Analysis failed: Poly does not implement the operation"; NL; + operation_to_pretty operation]; + raise + (params#analysis_failed 3 "Poly does not implement the operation") + end + end + | _ -> + begin + pr__debug [ + STR "Analysis failed: Poly does not implement the operation"; NL; + operation_to_pretty operation]; + raise + (params#analysis_failed 3 "Poly does not implement the operation") + end in + + let _ = + if !dbg then + pr__debug [STR "after analyzeOperation res "; NL; res#toPretty; NL] in + res + + end + + +let get_poly_int_array (poly_dom: CHDomain.domain_int) = + + (if !dbg then + pr__debug [STR "get_poly_int_array "; NL; poly_dom#toPretty; NL]); + + let _ = poly_dom#special "set_poly_int_array" [] in + get_st_poly_int_array () + +let get_relational_exprs include_loop_counters poly_int_dom = + if poly_int_dom#isBottom then + [] + else + let args = + if include_loop_counters then + [NUM_DOM_ARG numerical_zero] else [] in + let _ = poly_int_dom#special "get_local_var_invariants" args in + get_st_relational_exprs () + +let get_local_var_map poly_int_dom = + if poly_int_dom#isBottom then + [] + else + let _ = poly_int_dom#special "set_local_var_map" [] in + get_st_local_var_map () + +let get_poly_vars poly_int_dom = + if poly_int_dom#isBottom then + [] + else + let _ = poly_int_dom#special "set_poly_vars" [] in + get_st_poly_vars () + + +let mk_param_map + (jproc_info: JCHProcInfo.jproc_info_t): + (variable_t list * (variable_t * variable_t) list) = + let name = jproc_info#get_name in + let orig_proc = (JCHSystem.jsystem#get_original_chif#getProcedure name) in + let orig_locals = + List.filter (fun v -> + JCHSystemUtils.is_register v + || JCHSystemUtils.is_return v) orig_proc#getScope#getVariables in + let jvar_infos = jproc_info#get_jvar_infos#listOfValues in + let params = List.filter (fun info -> info#is_parameter) jvar_infos in + let map = + List.map (fun info -> let v = info#get_variable in (v, v)) params in + (orig_locals, map) + +let get_poly_dom + jproc_info + init_poly_int_array + reset_old_join_widening + reset_use_intervals = + let proc_name = jproc_info#get_name in + + (if !dbg then + pr__debug [jproc_info#get_opcodes#toPretty; NL; jproc_info#toPretty; NL]); + + (if !dbg then + pr__debug [STR "init_poly_int_array "; init_poly_int_array#toPretty; NL]); + + let consts = + let is_const var = + List.exists (fun (i, _) -> + var#getIndex = i) init_poly_int_array#get_var_to_const in + List.filter is_const jproc_info#get_variables in + let div2div2quot = + reset_ref_vars + proc_name + jproc_info + consts + reset_old_join_widening in + params#reset reset_use_intervals; + + let new_init_poly_int_array = + let new_extra_infos = + init_poly_int_array#get_extra_infos#add_div_info div2div2quot in + let pia = init_poly_int_array#set_extra_infos new_extra_infos in + if params#use_intervals then + pia#move_simple_ineqs#drop_poly + else pia in + new poly_int_domain_no_arrays_t + jproc_info new_init_poly_int_array (mk_param_map jproc_info) + +let get_interval poly_int_dom var = + let poly_interval_array = get_poly_int_array poly_int_dom in + poly_interval_array#get_interval var + +let bottom_poly_int_dom jproc_info = + new poly_int_domain_no_arrays_t + jproc_info bottom_poly_interval_array (mk_param_map jproc_info) + +let top_poly_int_dom jproc_info vs = + let top = top_poly_interval_array [] vs in + new poly_int_domain_no_arrays_t jproc_info top (mk_param_map jproc_info) + +let project_out_loop_counters poly = + poly#special "project_out_loop_counters" [] + +let remove_duplicates poly = + poly#special "remove_duplicates" [] + +let restrict_to_vars poly vars = + poly#special "restrict_to_vars" (List.map (fun v -> VAR_DOM_ARG v) vars) + +let get_relational_exprs_vars_fields (poly: poly_int_domain_no_arrays_t) vars = + let _ = poly#special + "get_vars_fields_rel_exprs" (List.map (fun v -> VAR_DOM_ARG v) vars) in + get_st_relational_exprs () diff --git a/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.mli b/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.mli index c78f480e..5fd6289c 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.mli +++ b/CodeHawk/CHJ/jchpoly/jCHPolyIntDomainNoArrays.mli @@ -1,109 +1,108 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -(* chlib *) -open CHDomain -open CHIntervals -open CHLanguage -open CHUtils - -(* jchlib *) -open JCHBasicTypesAPI - -(* jchpre *) -open JCHPreAPI - -val set_instr_pc : int -> unit -val set_prev_pc_to_wto_pc : (int * int) list -> unit - -val set_invs : - JCHPolyIntervalArray.poly_interval_array_t IntCollections.table_t -> unit - -val add_reachable : variable_t -> unit -val is_reachable : variable_t -> bool -val get_changed_sym_params : unit -> variable_t list -val add_variable_to_field : variable_t -> instruction_info_int -> unit - -val get_proc_info : - unit - -> VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - * VariableCollections.set_t - -val print_lost_info : unit -> unit - -class poly_int_domain_no_arrays_t : - JCHProcInfo.jproc_info_t - -> JCHPolyIntervalArray.poly_interval_array_t - -> variable_t list * (variable_t * variable_t) list - -> domain_int - -val get_poly_int_array : domain_int -> JCHPolyIntervalArray.poly_interval_array_t - -val get_poly_dom : - JCHProcInfo.jproc_info_t - -> JCHPolyIntervalArray.poly_interval_array_t - -> bool - -> bool - -> poly_int_domain_no_arrays_t - -val get_interval: domain_int -> variable_t -> interval_t - -val get_relational_exprs : - bool -> poly_int_domain_no_arrays_t -> relational_expr_t list - -val get_local_var_map : - poly_int_domain_no_arrays_t -> (variable_t * variable_t) list - -val get_poly_vars : poly_int_domain_no_arrays_t -> variable_t list - -val bottom_poly_int_dom : - JCHProcInfo.jproc_info_t -> poly_int_domain_no_arrays_t - -val top_poly_int_dom : - JCHProcInfo.jproc_info_t -> variable_t list -> poly_int_domain_no_arrays_t - -val project_out_loop_counters : - poly_int_domain_no_arrays_t -> poly_int_domain_no_arrays_t - -val remove_duplicates : - poly_int_domain_no_arrays_t -> poly_int_domain_no_arrays_t - -val restrict_to_vars : - poly_int_domain_no_arrays_t -> variable_t list -> poly_int_domain_no_arrays_t - -val get_relational_exprs_vars_fields : - poly_int_domain_no_arrays_t -> variable_t list -> relational_expr_t list - -val dbg : bool ref - - +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +(* chlib *) +open CHDomain +open CHIntervals +open CHLanguage +open CHUtils + +(* jchlib *) +open JCHBasicTypesAPI + +(* jchpre *) +open JCHPreAPI + +val set_instr_pc : int -> unit +val set_prev_pc_to_wto_pc : (int * int) list -> unit + +val set_invs : + JCHPolyIntervalArray.poly_interval_array_t IntCollections.table_t -> unit + +val add_reachable : variable_t -> unit +val is_reachable : variable_t -> bool +val get_changed_sym_params : unit -> variable_t list +val add_variable_to_field : variable_t -> instruction_info_int -> unit + +val get_proc_info : + unit + -> VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + * VariableCollections.set_t + +val print_lost_info : unit -> unit + +class poly_int_domain_no_arrays_t : + JCHProcInfo.jproc_info_t + -> JCHPolyIntervalArray.poly_interval_array_t + -> variable_t list * (variable_t * variable_t) list + -> domain_int + +val get_poly_int_array : domain_int -> JCHPolyIntervalArray.poly_interval_array_t + +val get_poly_dom : + JCHProcInfo.jproc_info_t + -> JCHPolyIntervalArray.poly_interval_array_t + -> bool + -> bool + -> poly_int_domain_no_arrays_t + +val get_interval: domain_int -> variable_t -> interval_t + +val get_relational_exprs : + bool -> poly_int_domain_no_arrays_t -> relational_expr_t list + +val get_local_var_map : + poly_int_domain_no_arrays_t -> (variable_t * variable_t) list + +val get_poly_vars : poly_int_domain_no_arrays_t -> variable_t list + +val bottom_poly_int_dom : + JCHProcInfo.jproc_info_t -> poly_int_domain_no_arrays_t + +val top_poly_int_dom : + JCHProcInfo.jproc_info_t -> variable_t list -> poly_int_domain_no_arrays_t + +val project_out_loop_counters : + poly_int_domain_no_arrays_t -> poly_int_domain_no_arrays_t + +val remove_duplicates : + poly_int_domain_no_arrays_t -> poly_int_domain_no_arrays_t + +val restrict_to_vars : + poly_int_domain_no_arrays_t -> variable_t list -> poly_int_domain_no_arrays_t + +val get_relational_exprs_vars_fields : + poly_int_domain_no_arrays_t -> variable_t list -> relational_expr_t list + +val dbg : bool ref diff --git a/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.ml b/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.ml index 4e22fcf6..ba5de9e1 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.ml +++ b/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -45,21 +46,19 @@ open JCHBasicTypes open JCHPreAPI (* jchsys *) -open JCHGlobals -open JCHSystemUtils open JCHPrintUtils (* jchpoly *) open JCHLinearConstraint open JCHPoly -open JCHIntervalArray +open JCHIntervalArray open JCHNumericUtils open JCHNumericInfo -let dbg = ref false +let dbg = ref false -let params = JCHAnalysisUtils.numeric_params -let zero_bound = CHBounds.bound_of_num numerical_zero +let params = JCHAnalysisUtils.numeric_params +let zero_bound = CHBounds.bound_of_num numerical_zero let one_bound = CHBounds.bound_of_num numerical_one module ConstraintCollections = CHCollections.Make ( @@ -69,127 +68,127 @@ module ConstraintCollections = CHCollections.Make ( let toPretty c = c#toPretty end) -let local_vars = ref [] +let local_vars = ref [] let set_local_vars vs = local_vars := vs -class poly_interval_array_t v2const poly_vs = - object (self: 'a) - - val var_to_const : (int * numerical_t) list = v2const +class poly_interval_array_t v2const poly_vs = + object (self: 'a) + + val var_to_const : (int * numerical_t) list = v2const val poly_vars : variable_t list = poly_vs - (* variable to the index used in interval_array *) - val var_to_index : (int * int) list = mk_var_to_index poly_vs + (* variable to the index used in interval_array *) + val var_to_index : (int * int) list = mk_var_to_index poly_vs val poly : poly_t = top_poly val interval_array : interval_array_t = make_top_intervals 0 val extra_infos : numeric_info_t = new numeric_info_t method get_var_to_const = var_to_const method get_poly_vars = poly_vars - method get_var_to_index = var_to_index + method get_var_to_index = var_to_index method get_poly = poly method get_interval_array = interval_array method get_extra_infos = extra_infos - method get_excluded_vals var = + method get_excluded_vals var = extra_infos#get_excluded_vals var - method has_var (var: variable_t) = + method has_var (var: variable_t) = (List.exists (fun (i,_) -> var#getIndex = i) var_to_const) || (List.exists (fun v -> v#getIndex = var#getIndex) poly_vars) - - method set_poly poly = + + method set_poly poly = {< poly = poly >} - method set_interval_array new_interval_array = + method set_interval_array new_interval_array = {< interval_array = new_interval_array >} - method set_interval var interval = + method set_interval var interval = let new_interval_array = interval_array#copy_set (self#get_index var) interval in - {< interval_array = new_interval_array >} + {< interval_array = new_interval_array >} - method set_extra_infos extra_infos = + method set_extra_infos extra_infos = {< extra_infos = extra_infos >} method private get_dim = List.length poly_vars - method private mk_bottom = - {< var_to_const = [] ; - poly_vars = [] ; - var_to_index = [] ; - poly = bottom_poly ; - interval_array = interval_array#make_bottom_intervals 0 ; + method private mk_bottom = + {< var_to_const = []; + poly_vars = []; + var_to_index = []; + poly = bottom_poly; + interval_array = interval_array#make_bottom_intervals 0; extra_infos = new numeric_info_t >} - method mk_empty v2const poly_vs = + method mk_empty v2const poly_vs = let v2ind = mk_var_to_index poly_vs in - {< var_to_const = v2const ; - poly_vars = poly_vs ; - var_to_index = v2ind ; - poly = top_poly ; - interval_array = interval_array#make_bottom_intervals (List.length poly_vs) ; - extra_infos = new numeric_info_t >} - - method private mk_top v2const poly_vs = + {< var_to_const = v2const; + poly_vars = poly_vs; + var_to_index = v2ind; + poly = top_poly; + interval_array = interval_array#make_bottom_intervals (List.length poly_vs); + extra_infos = new numeric_info_t >} + + method private mk_top v2const poly_vs = let v2ind = mk_var_to_index poly_vs in - {< var_to_const = v2const ; - poly_vars = poly_vs ; - var_to_index = v2ind ; - poly = top_poly ; - interval_array = interval_array#make_top_intervals (List.length poly_vs) ; - extra_infos = new numeric_info_t >} - - method drop_poly = - if poly#is_bottom then {< >} + {< var_to_const = v2const; + poly_vars = poly_vs; + var_to_index = v2ind; + poly = top_poly; + interval_array = interval_array#make_top_intervals (List.length poly_vs); + extra_infos = new numeric_info_t >} + + method drop_poly = + if poly#is_bottom then {< >} else {< poly = top_poly >} - method drop_all = + method drop_all = if poly#is_bottom then {< >} - else {< poly = top_poly ; + else {< poly = top_poly; interval_array = interval_array#make_from_types (List.length poly_vars) >} method is_bottom = poly#is_bottom method is_top = (* what about the excluded values ? *) - let check_array i = + let check_array i = let int = interval_array#get i in - if int#isTop || int#isBottom then () + if int#isTop || int#isBottom then () else raise Exit in - try (* Just as a way not to look at all the intervals if one is not top or bottom *) - if poly#is_top then + try (* Just as a way not to look at all the intervals if one is not top or bottom *) + if poly#is_top then begin for i = 0 to pred self#get_dim do check_array i - done ; - true + done; + true end - else false - with Exit -> false + else false + with Exit -> false - method clone = - {< poly = poly#clone ; - interval_array = interval_array#clone ; + method clone = + {< poly = poly#clone; + interval_array = interval_array#clone; extra_infos = extra_infos#clone >} - (* Change the vars but the info stays the same. - * Eliminate the lengths that do not correspont to an array length - * in new_poly_length_vars + (* Change the vars but the info stays the same. + * Eliminate the lengths that do not correspont to an array length + * in new_poly_length_vars * Add lengths that are in the new_poly_length_vars but not in poly_vars *) method change_vars proc_name new_proc_name (new_poly_vars:variable_t list) (new_length_poly_vars:variable_t list) : 'a = - + if !dbg then pr__debug [STR "change vars to "; new_proc_name#toPretty; NL; - pp_list poly_vars; NL; + pp_list poly_vars; NL; pp_list new_poly_vars; STR " "; - pp_list new_length_poly_vars; NL] ; + pp_list new_length_poly_vars; NL]; let (length_poly_vars, non_length_poly_vars) = List.partition JCHSystemUtils.is_length poly_vars in let (all_new_poly_vars, new_poly, new_interval_array, all_map): - variable_t list * poly_t * interval_array_t * (int * variable_t) list = + variable_t list * poly_t * interval_array_t * (int * variable_t) list = let new_jproc_info = JCHSystem.jsystem#get_jproc_info new_proc_name in let map_v = List.combine non_length_poly_vars new_poly_vars in let length_map = ref [] in @@ -197,92 +196,92 @@ class poly_interval_array_t v2const poly_vs = let lengths_to_add = ref [] in let all_length_poly_vars = ref [] in let index = ref 0 in - let map = + let map = let mp = ref [] in - let add_var v = - mp := (!index, !index) :: !mp ; + let add_var _v = + mp := (!index, !index) :: !mp; incr index in - List.iter add_var non_length_poly_vars ; + List.iter add_var non_length_poly_vars; mp in let index_skip = ref !index in - let add_new_length new_length = + let add_new_length new_length = let new_var = Option.get (new_jproc_info#get_variable_from_length new_length) in let (var, _) = - List.find (fun (v, new_v) -> new_v#equal new_var) map_v in + List.find (fun (_v, new_v) -> new_v#equal new_var) map_v in let l = JCHSystemUtils.make_length var in try let length = List.find (fun v -> v#getName = l#getName) length_poly_vars in - lengths_to_stay := length :: !lengths_to_stay ; - length_map := (length#getIndex, new_length) :: !length_map ; - all_length_poly_vars := length :: !all_length_poly_vars ; - map := (!index_skip, !index) :: !map ; + lengths_to_stay := length :: !lengths_to_stay; + length_map := (length#getIndex, new_length) :: !length_map; + all_length_poly_vars := length :: !all_length_poly_vars; + map := (!index_skip, !index) :: !map; incr index; - incr index_skip - with Not_found -> - lengths_to_add := (l, !index) :: !lengths_to_add ; - length_map := (l#getIndex, l) :: !length_map ; - all_length_poly_vars := l :: !all_length_poly_vars ; + incr index_skip + with Not_found -> + lengths_to_add := (l, !index) :: !lengths_to_add; + length_map := (l#getIndex, l) :: !length_map; + all_length_poly_vars := l :: !all_length_poly_vars; incr index in - List.iter add_new_length new_length_poly_vars ; + List.iter add_new_length new_length_poly_vars; let lengths_to_add = List.rev !lengths_to_add in - let add_to_map (var, ind) = - map := (!index_skip, ind) :: !map ; + let add_to_map (_var, ind) = + map := (!index_skip, ind) :: !map; incr index_skip in - List.iter add_to_map lengths_to_add ; + List.iter add_to_map lengths_to_add; let lengths_to_remove = List.filter (fun v -> not (List.mem v !lengths_to_stay)) length_poly_vars in let restr_poly_vars = non_length_poly_vars in - let new_poly_interval_array = self#project_out lengths_to_remove in - let (all_poly, all_interval_array) = + let new_poly_interval_array = self#project_out lengths_to_remove in + let (all_poly, all_interval_array) = if lengths_to_add = [] then (new_poly_interval_array#get_poly, - new_poly_interval_array#get_interval_array) - else + new_poly_interval_array#get_interval_array) + else let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let new_lengths : variable_t list = List.map fst lengths_to_add in let pia = new_poly_interval_array#add_vars jproc_info new_lengths in (pia#get_poly#remap_indices !map, pia#get_interval_array#remap (List.length !map) !map) in let m = List.combine - (List.map (fun v -> v#getIndex) restr_poly_vars) new_poly_vars in + (List.map (fun v -> v#getIndex) restr_poly_vars) new_poly_vars in (new_poly_vars @ !all_length_poly_vars, all_poly, all_interval_array, m @ (List.rev !length_map)) in - let change_var_const (ind, const) = - let new_var = + let change_var_const (ind, const) = + let new_var = try - List.assoc ind all_map + List.assoc ind all_map with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "Change var constant not found for " ; INT ind ; + (JCH_failure + (LBLOCK [ STR "Change var constant not found for "; INT ind; STR " in JCHPolyIntervalArray.change_var_const" ])) in (new_var#getIndex, const) in - - {< var_to_const = List.map change_var_const var_to_const ; + + {< var_to_const = List.map change_var_const var_to_const; poly_vars = all_new_poly_vars; - var_to_index = mk_var_to_index all_new_poly_vars ; - poly = new_poly ; + var_to_index = mk_var_to_index all_new_poly_vars; + poly = new_poly; interval_array = new_interval_array; extra_infos = extra_infos#change_vars all_new_poly_vars >} - method is_const v = + method is_const v = List.mem_assoc v#getIndex var_to_const - method get_const_val (v: variable_t) = + method get_const_val (v: variable_t) = try (List.assoc v#getIndex var_to_const)#getNum with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "Constant value not found for " ; v#toPretty ; + (LBLOCK [ STR "Constant value not found for "; v#toPretty; STR " in JCHPolyIntervalArray.get_const_val" ])) method get_const_val_n v = @@ -292,87 +291,87 @@ class poly_interval_array_t v2const poly_vs = | Not_found -> raise (JCH_failure - (LBLOCK [ STR "Constant value not found for " ; v#toPretty ; + (LBLOCK [ STR "Constant value not found for "; v#toPretty; STR " in JCHPolyIntervalArray.get_const_val_n" ])) - - method get_index var = + + method get_index var = try List.assoc var#getIndex var_to_index with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "Variable index not found for " ; - var#toPretty ; STR " in JCHPolyIntervalArray.get_index" ])) - - method private put_index (var, vl) = + (JCH_failure + (LBLOCK [ STR "Variable index not found for "; + var#toPretty; STR " in JCHPolyIntervalArray.get_index" ])) + + method private put_index (var, vl) = (self#get_index var, vl) - method private is_discrete var = - self#is_const var || interval_array#is_discrete (self#get_index var) + method private is_discrete var = + self#is_const var || interval_array#is_discrete (self#get_index var) method private get_related_constrs_inds - (constrs:linear_constraint_t list) inds = + (constrs:linear_constraint_t list) inds = let ind_to_constrs = new IntCollections.table_t in - let add_constr constr = + let add_constr constr = let inds = constr#get_used_indices in - let add ind = - match ind_to_constrs#get ind with + let add ind = + match ind_to_constrs#get ind with | Some set -> set#add constr | _ -> ind_to_constrs#set ind (ConstraintCollections.set_of_list [constr]) in List.iter add inds in - List.iter add_constr constrs ; - let related_constrs = ref [] in - let related_inds = new IntCollections.set_t in - let rec work inds = - match inds with - | ind :: rest_inds -> + List.iter add_constr constrs; + let related_constrs = ref [] in + let related_inds = new IntCollections.set_t in + let rec work inds = + match inds with + | ind :: rest_inds -> if related_inds#has ind then work rest_inds - else + else begin - related_inds#add ind ; - let ind_constrs = - match ind_to_constrs#get ind with + related_inds#add ind; + let ind_constrs = + match ind_to_constrs#get ind with | Some set -> set | _ -> new ConstraintCollections.set_t in let new_inds = new IntCollections.set_t in - let add constr = - if List.memq constr !related_constrs then () - else + let add constr = + if List.memq constr !related_constrs then () + else begin - related_constrs := constr :: !related_constrs ; + related_constrs := constr :: !related_constrs; let inds = constr#get_used_indices in - new_inds#addList inds + new_inds#addList inds end in - ind_constrs#iter add ; - new_inds#addList rest_inds ; + ind_constrs#iter add; + new_inds#addList rest_inds; work new_inds#toList end | [] -> () in - work inds ; + work inds; (!related_constrs, related_inds) method private get_constrs_for_inds - (constrs: linear_constraint_t list) inds = + (constrs: linear_constraint_t list) inds = let ind_to_constrs = new IntCollections.table_t in - let add_constr constr = + let add_constr constr = let inds = constr#get_used_indices in - let add ind = - match ind_to_constrs#get ind with + let add ind = + match ind_to_constrs#get ind with | Some set -> set#add constr | _ -> ind_to_constrs#set ind (ConstraintCollections.set_of_list [constr]) in List.iter add inds in - List.iter add_constr constrs ; + List.iter add_constr constrs; let constrs_for_inds = new ConstraintCollections.set_t in let inds_in_constrs = new IntCollections.set_t in - let add_ind ind = - match ind_to_constrs#get ind with - | Some set -> - let add_constr constr = - constrs_for_inds#add constr ; + let add_ind ind = + match ind_to_constrs#get ind with + | Some set -> + let add_constr constr = + constrs_for_inds#add constr; inds_in_constrs#addList constr#get_used_indices in set#iter add_constr | _ -> () in @@ -383,14 +382,14 @@ class poly_interval_array_t v2const poly_vs = let int = interval_array'#get index in if poly'#is_top || int#isBottom || (Option.is_some int#singleton) then int - else + else begin let constrs = poly'#get_constraints in - let (related_constrs, related_inds) = + let (related_constrs, related_inds) = self#get_related_constrs_inds constrs [index] in if related_constrs = [] then - int - else + int + else try let related_poly = if related_constrs = [] then @@ -398,30 +397,30 @@ class poly_interval_array_t v2const poly_vs = else mk_poly_from_constraints false related_constrs in let constrs = ref [] in - let add_interval_constr index interval = - if related_inds#has index then + let add_interval_constr index interval = + if related_inds#has index then if interval#isTop || interval#isBottom then - () + () else constrs := - (mk_constraints_from_interval false index interval) @ !constrs + (mk_constraints_from_interval false index interval) @ !constrs else - () in - interval_array'#iteri add_interval_constr ; - + () in + interval_array'#iteri add_interval_constr; + if !dbg then pr__debug [STR "_get_best_interval' big_poly has "; INT (List.length !constrs); STR " constraints"; NL]; - + if List.length !constrs > 12 then int else begin - let big_poly = related_poly#add_constraints !constrs in + let big_poly = related_poly#add_constraints !constrs in let big_poly_int = big_poly#get_interval index in big_poly_int end with (JCHAnalysisUtils.JCH_num_analysis_failure _) -> - int + int end method private _get_best_interval poly' interval_array' index = @@ -430,27 +429,27 @@ class poly_interval_array_t v2const poly_vs = | 0 -> int | 1 -> begin - pr__debug [STR " Reached constraint analysis time limit "; NL] ; + pr__debug [STR " Reached constraint analysis time limit "; NL]; params#reset_analysis_failure_status; int end | _ -> begin - pr__debug [STR "Analysis failed: reached numeric analysis time limit "; NL] ; - raise (params#analysis_failed 3 "reached numeric analysis time limit ") + pr__debug [STR "Analysis failed: reached numeric analysis time limit "; NL]; + raise (params#analysis_failed 3 "reached numeric analysis time limit ") end - + method get_best_interval v_index = - self#_get_best_interval poly interval_array v_index + self#_get_best_interval poly interval_array v_index - method get_interval v = - let interval = + method get_interval v = + let interval = if self#is_const v then mkSingletonInterval (self#get_const_val_n v) - else + else begin let index = self#get_index v in - if List.exists (fun v' -> v#getIndex = v'#getIndex) poly_vars then + if List.exists (fun v' -> v#getIndex = v'#getIndex) poly_vars then self#get_best_interval index else interval_array#get_type_interval index (* topInterval *) @@ -461,161 +460,161 @@ class poly_interval_array_t v2const poly_vs = let dim = self#get_dim in let best_array = interval_array#make_bottom_intervals dim in begin - for i = 0 to pred dim do + for i = 0 to pred dim do let interval = self#_get_best_interval apoly ainterval_array i in - best_array#set i interval - done ; + best_array#set i interval + done; best_array end - method set_best_intervals = + method set_best_intervals = {< interval_array = self#get_best_interval_array poly interval_array >} method move_simple_ineqs = - + if !dbg then pr__debug [STR "move_simple_ineqs "; NL; self#toPretty; NL]; - + let (restr_poly, restr_interval_array) = move_simple_ineqs_to_intervals poly interval_array in - {< poly = restr_poly; interval_array = restr_interval_array >} + {< poly = restr_poly; interval_array = restr_interval_array >} (* checks whether apoly + ainterval_array <= constr *) method private included_in_constr - apoly ainterval_array (constr: linear_constraint_t) = + apoly ainterval_array (constr: linear_constraint_t) = let constr_poly = mk_poly_from_constraints false [constr] in - + if !dbg then pr__debug [STR "included_in_constr "; NL; - apoly#toPretty; NL; constr_poly#toPretty; NL] ; - + apoly#toPretty; NL; constr_poly#toPretty; NL]; + if apoly#leq constr_poly then true - else + else begin let inds = constr#get_used_indices in let aconstrs = apoly#get_constraints in let (related_constrs, related_inds) = self#get_related_constrs_inds aconstrs inds in let interval_constrs = ref [] in - let add_interval_constr ind = + let add_interval_constr ind = let interval = ainterval_array#get ind in if interval#isTop then - () + () else interval_constrs := (mk_constraints_from_interval false ind interval) @ !interval_constrs in - related_inds#iter add_interval_constr ; + related_inds#iter add_interval_constr; let new_poly = mk_poly_from_constraints false (related_constrs @ !interval_constrs) in new_poly#leq constr_poly end - method private are_excluded interval excluded_vals vals = - let is_excluded interval excluded_vals vl = + method private are_excluded interval excluded_vals vals = + let is_excluded interval excluded_vals vl = if interval#contains vl then List.exists (fun vl' -> vl'#equal vl) excluded_vals else true in List.for_all (is_excluded interval excluded_vals) vals - (* This does not take into consideration the extra infos - + (* This does not take into consideration the extra infos - * other than excluded vals. Does it need to? *) method leq (a: 'a) = - + if !dbg then pr__debug [STR "JCHPolyIntervalArray.leq "; NL; - self#toPretty; NL; a#toPretty; NL] ; + self#toPretty; NL; a#toPretty; NL]; - let res = + let res = let best_interval_array = self#get_best_interval_array poly interval_array in (* Is this necessary ? *) let abest_interval_array = self#get_best_interval_array a#get_poly a#get_interval_array in (* Is this necessary ? *) - + if !dbg then - pr__debug [STR "JCHPolyIntervalArray.leq after abest_interval_array"; NL] ; - + pr__debug [STR "JCHPolyIntervalArray.leq after abest_interval_array"; NL]; + let rec check_constrs (constrs: linear_constraint_t list) = - match constrs with - | constr :: rest_constrs -> - if self#included_in_constr poly best_interval_array constr then - check_constrs rest_constrs + match constrs with + | constr :: rest_constrs -> + if self#included_in_constr poly best_interval_array constr then + check_constrs rest_constrs else false | [] -> true in - let rec check_intervals vars = - match vars with + let rec check_intervals vars = + match vars with | var :: rest_vars -> let index = self#get_index var in let int = best_interval_array#get index in let aint = abest_interval_array#get index in - if int#leq aint then + if int#leq aint then let excluded_vals = extra_infos#get_excluded_vals var in - let aexcluded_vals = a#get_extra_infos#get_excluded_vals var in + let aexcluded_vals = a#get_extra_infos#get_excluded_vals var in if self#are_excluded int excluded_vals aexcluded_vals then check_intervals rest_vars - else - false - else + else + false + else false - | [] -> + | [] -> let constrs = a#get_poly#get_constraints in check_constrs constrs in check_intervals poly_vars in - + let _ = if !dbg then pr__debug [STR "JCHPolyIntervalArray.leq result = "; pp_bool res; NL] in res - method equal (a: 'a) = + method equal (a: 'a) = (self#leq a) && (a#leq self) (* vars are collection vars that are read arguments in a call - * For these, we want the intervals to be the intervals in a, + * For these, we want the intervals to be the intervals in a, * which are the exit intervals of the called method - * However for the library functions there might not be any + * However for the library functions there might not be any * intervals in the case when the collections were not changed - * and the excluded values also need to be the ones from a *) + * and the excluded values also need to be the ones from a *) method meet' (a: 'a) vars = - + if !dbg then - pr__debug [STR "meet' "; pp_list vars; NL; self#toPretty; NL; a#toPretty; NL] ; - + pr__debug [STR "meet' "; pp_list vars; NL; self#toPretty; NL; a#toPretty; NL]; + let new_poly = poly#meet a#get_poly in let new_interval_array = interval_array#meet a#get_interval_array true in let ainterval_array = a#get_interval_array in let aextra_infos = a#get_extra_infos in - let set_interval ex_infos v = + let set_interval ex_infos v = try (* ?? *) let index = self#get_index v in - if aextra_infos#is_changed_sym_param v then - new_interval_array#set index (ainterval_array#get index) + if aextra_infos#is_changed_sym_param v then + new_interval_array#set index (ainterval_array#get index) else - interval_array#set index (interval_array#get index) ; - match a#get_extra_infos#get_num_info_ind index with - | Some num_info -> ex_infos#set_num_info v num_info + interval_array#set index (interval_array#get index); + match a#get_extra_infos#get_num_info_ind index with + | Some num_info -> ex_infos#set_num_info v num_info | None -> ex_infos with _ -> ex_infos in let new_extra_infos = List.fold_left set_interval extra_infos vars in - let add_excluded ex_infos var = + let add_excluded ex_infos var = if List.exists (fun v -> var#getIndex = v#getIndex) vars then ex_infos#set_excluded_vals var (aextra_infos#get_excluded_vals var) - else + else begin let new_excluded = new NumericalCollections.set_t in let index = self#get_index var in let meet_interval = new_interval_array#get index in - let add_excl_vals vl = - if meet_interval#contains vl then - new_excluded#add vl in - List.iter add_excl_vals (extra_infos#get_excluded_vals var) ; - List.iter add_excl_vals (aextra_infos#get_excluded_vals var) ; + let add_excl_vals vl = + if meet_interval#contains vl then + new_excluded#add vl in + List.iter add_excl_vals (extra_infos#get_excluded_vals var); + List.iter add_excl_vals (aextra_infos#get_excluded_vals var); if new_excluded#isEmpty then ex_infos else - ex_infos#set_excluded_vals var new_excluded#toList + ex_infos#set_excluded_vals var new_excluded#toList end in let new_extra_infos = List.fold_left add_excluded new_extra_infos poly_vars in @@ -631,61 +630,61 @@ class poly_interval_array_t v2const poly_vs = | (Some num_info, Some anum_info) -> ex_infos#set_num_info var (num_info#meet anum_info) in let new_extra_infos = List.fold_left add_infos new_extra_infos poly_vars in - {< poly = new_poly ; - interval_array = new_interval_array ; - extra_infos = new_extra_infos >} + {< poly = new_poly; + interval_array = new_interval_array; + extra_infos = new_extra_infos >} method meet (simple: bool) (a: 'a) = - + if !dbg then - pr__debug [STR "JCHPolyIntervalArray.meet "; NL; self#toPretty; NL; a#toPretty; NL] ; - + pr__debug [STR "JCHPolyIntervalArray.meet "; NL; self#toPretty; NL; a#toPretty; NL]; + let new_poly = if simple then poly#meet_simple a#get_poly else poly#meet a#get_poly in let new_interval_array = interval_array#meet a#get_interval_array false in let new_extra_infos = extra_infos#meet a#get_extra_infos in - let add_excluded ex_info var = + let add_excluded ex_info var = let aextra_infos = a#get_extra_infos in let new_excluded = new NumericalCollections.set_t in let index = self#get_index var in let meet_interval = new_interval_array#get index in - let add_excl_vals vl = - if meet_interval#contains vl then - new_excluded#add vl in - List.iter add_excl_vals (extra_infos#get_excluded_vals var) ; - List.iter add_excl_vals (aextra_infos#get_excluded_vals var) ; + let add_excl_vals vl = + if meet_interval#contains vl then + new_excluded#add vl in + List.iter add_excl_vals (extra_infos#get_excluded_vals var); + List.iter add_excl_vals (aextra_infos#get_excluded_vals var); if new_excluded#isEmpty then ex_info else ex_info#set_excluded_vals var new_excluded#toList in let new_extra_infos = List.fold_left add_excluded new_extra_infos poly_vars in - {< poly = new_poly ; - interval_array = new_interval_array ; + {< poly = new_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} (* What about divisions and empty collections ? *) method private add_extra_join_ineqs join_poly join_interval_array spoly apoly ainterval_array = - + let _ = if !dbg then pr__debug [NL; STR "add_extra_join_ineqs "; join_poly#toPretty; NL; spoly#toPretty; NL; apoly#toPretty; NL] in - + let constrs = spoly#get_constraints in let ineqs = List.filter (fun c -> not c#is_equality) constrs in let ineqs_to_include = ref [] in - let add_ineq ineq = + let add_ineq ineq = if not (self#included_in_constr join_poly join_interval_array ineq) && self#included_in_constr apoly ainterval_array ineq - && not ineq#is_0_geq_0 then + && not ineq#is_0_geq_0 then ineqs_to_include := ineq :: !ineqs_to_include in - List.iter add_ineq ineqs ; + List.iter add_ineq ineqs; try - join_poly#add_constraints !ineqs_to_include - with (JCHAnalysisUtils.JCH_num_analysis_failure _) -> - params#set_use_intervals true ; + join_poly#add_constraints !ineqs_to_include + with (JCHAnalysisUtils.JCH_num_analysis_failure _) -> + params#set_use_intervals true; top_poly method private join_extra_infos @@ -693,41 +692,41 @@ class poly_interval_array_t v2const poly_vs = ainterval_array (sextra_infos: numeric_info_t) (aextra_infos : numeric_info_t) = - + if !dbg then pr__debug [STR "join_extra_infos "; NL; sextra_infos#toPretty; NL; - aextra_infos#toPretty; NL] ; - + aextra_infos#toPretty; NL]; + let jextra_infos = sextra_infos#join aextra_infos in - let add_excluded (ex_infos: numeric_info_t) var = + let add_excluded (ex_infos: numeric_info_t) var = let sexcluded_vals = sextra_infos#get_excluded_vals var in let aexcluded_vals = aextra_infos#get_excluded_vals var in - let common_excluded_vals = + let common_excluded_vals = List.filter (fun vl -> List.exists vl#equal aexcluded_vals) sexcluded_vals in let new_excluded_vals = NumericalCollections.set_of_list common_excluded_vals in - let add_var int_array1 ex_infos1 ex_infos2 = + let add_var int_array1 _ex_infos1 ex_infos2 = let interval = int_array1#get (self#get_index var) in let add vl = if not (interval#contains vl) then new_excluded_vals#add vl in List.iter add (ex_infos2#get_excluded_vals var) in - add_var sinterval_array sextra_infos aextra_infos ; - add_var ainterval_array aextra_infos sextra_infos ; + add_var sinterval_array sextra_infos aextra_infos; + add_var ainterval_array aextra_infos sextra_infos; ex_infos#set_excluded_vals var new_excluded_vals#toList in - List.fold_left add_excluded jextra_infos poly_vars + List.fold_left add_excluded jextra_infos poly_vars (* Used for stubs *) method simple_join (a: 'a) = - + if !dbg then - pr__debug [STR "simple_join "; NL; self#toPretty; NL; a#toPretty; NL] ; + pr__debug [STR "simple_join "; NL; self#toPretty; NL; a#toPretty; NL]; let apoly = a#get_poly in let ainterval_array = a#get_interval_array in - let new_extra_infos = - self#join_extra_infos interval_array ainterval_array + let new_extra_infos = + self#join_extra_infos interval_array ainterval_array extra_infos a#get_extra_infos in let dim = self#get_dim in let new_interval_array = interval_array#join' dim ainterval_array in @@ -737,13 +736,13 @@ class poly_interval_array_t v2const poly_vs = let (restr_poly, restr_interval_array) = move_simple_ineqs_to_intervals new_poly new_interval_array in - if params#use_intervals then - {< poly = top_poly ; - interval_array = restr_interval_array ; + if params#use_intervals then + {< poly = top_poly; + interval_array = restr_interval_array; extra_infos = new_extra_infos >} else begin - let changed_poly = + let changed_poly = let restr_poly' = self#add_extra_join_ineqs restr_poly restr_interval_array poly apoly ainterval_array in @@ -751,146 +750,147 @@ class poly_interval_array_t v2const poly_vs = self#add_extra_join_ineqs restr_poly' restr_interval_array apoly poly interval_array in restr_poly'' in - {< poly = changed_poly ; - interval_array = restr_interval_array ; + {< poly = changed_poly; + interval_array = restr_interval_array; extra_infos = new_extra_infos >} end - method private get_non_bottom_intervals (ainterval_array: interval_array_t) = + method private get_non_bottom_intervals (ainterval_array: interval_array_t) = let pairs = ref [] in - let add_var v = + let add_var v = let i = self#get_index v in let interval = ainterval_array#get i in if not interval#isBottom then pairs := (i, interval) :: !pairs in - List.iter add_var poly_vars ; + List.iter add_var poly_vars; !pairs method join (a: 'a) = - + if !dbg then - pr__debug [STR "PolyIntervalArray.join "; NL; self#toPretty; NL; a#toPretty; NL] ; - - let j = - let apoly = a#get_poly in + pr__debug [STR "PolyIntervalArray.join "; NL; self#toPretty; NL; a#toPretty; NL]; + + let j = + let apoly = a#get_poly in let ainterval_array = a#get_interval_array in - let new_extra_infos = - self#join_extra_infos interval_array interval_array + let new_extra_infos = + self#join_extra_infos interval_array interval_array extra_infos a#get_extra_infos in let dim = self#get_dim in let new_interval_array = interval_array#join' dim ainterval_array in - - if params#use_intervals then - {< poly = top_poly ; - interval_array = new_interval_array ; + + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} else begin try - let big_poly = + let big_poly = let intervals = self#get_non_bottom_intervals interval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) (fst poly#restrict_number_vars) intervals in - let abig_poly = + let abig_poly = let aintervals = self#get_non_bottom_intervals ainterval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) (fst apoly#restrict_number_vars) aintervals in - - let join_poly = big_poly#join abig_poly in - - let big_join_poly = + + let join_poly = big_poly#join abig_poly in + + let big_join_poly = let intervals = self#get_non_bottom_intervals new_interval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) join_poly intervals in - - let (small_poly, removed_constraints) = big_join_poly#restrict_number_vars in - + + let (small_poly, _removed_constraints) = + big_join_poly#restrict_number_vars in + let (restr_poly, restr_interval_array) = move_simple_ineqs_to_intervals small_poly new_interval_array in - + {< poly = restr_poly; - interval_array = restr_interval_array ; + interval_array = restr_interval_array; extra_infos = new_extra_infos >} with | JCHAnalysisUtils.JCH_num_analysis_failure _ -> - params#set_use_intervals true ; - {< poly = top_poly ; - interval_array = new_interval_array ; + params#set_use_intervals true; + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end in - if !dbg then pr__debug [STR "JCHPolyIntervalArray.join res "; NL; j#toPretty; NL] ; + if !dbg then pr__debug [STR "JCHPolyIntervalArray.join res "; NL; j#toPretty; NL]; j - method private add_constrs_no_loop_counters_lengths (poly: poly_t) : poly_t = + method private add_constrs_no_loop_counters_lengths (poly: poly_t) : poly_t = let (restr_poly, _) = poly#restrict_number_vars in let (restr_poly, _) = restr_poly#restrict_number_constraints in let constrs = ConstraintCollections.set_of_list (restr_poly#get_constraints) in - let is_loop_counter_or_length var = + let is_loop_counter_or_length var = JCHSystemUtils.is_loop_counter var || JCHSystemUtils.is_length var (* || not (List.mem var !local_vars) *) in let loop_counters_and_lengths = List.filter is_loop_counter_or_length poly_vars in let p = poly#project_out (List.map self#get_index loop_counters_and_lengths) in let (p, _) = p#restrict_number_vars in let (p, _) = p#restrict_number_constraints in - constrs#addList p#get_constraints ; + constrs#addList p#get_constraints; fst (mk_poly_from_constraints false constrs#toList)#restrict_number_vars - method private get_inds_in_constrs (constrs: linear_constraint_t list) = + method private get_inds_in_constrs (constrs: linear_constraint_t list) = let inds = new IntCollections.set_t in let add_ind constr = inds#addList constr#get_used_indices in List.iter add_ind constrs; inds#toList method private add_constrs_with_fewer_vars (poly: poly_t) : poly_t = - + if !dbg then pr__debug [STR "add_constrs_no_loop_counters_lengths "; - poly#to_pretty poly_vars; NL] ; - + poly#to_pretty poly_vars; NL]; + let constrs = poly#get_constraints in let inds_in_poly = self#get_inds_in_constrs constrs in let new_constrs = ConstraintCollections.set_of_list constrs in - let add_proj ind = + let add_proj ind = let p = poly#project_out [ind] in let (p, _) = p#restrict_number_vars in new_constrs#addList p#get_constraints in - List.iter add_proj inds_in_poly ; + List.iter add_proj inds_in_poly; mk_poly_from_constraints false new_constrs#toList method join_with_old (a: 'a) (old_poly_int_array : 'a) = - + if !dbg then pr__debug [STR "PolyIntervalArray.join_with_old "; NL; old_poly_int_array#toPretty; NL; self#toPretty; NL; - a#toPretty; NL] ; - - let apoly = a#get_poly in + a#toPretty; NL]; + + let apoly = a#get_poly in let ainterval_array = a#get_interval_array in - let new_extra_infos = - self#join_extra_infos interval_array interval_array + let new_extra_infos = + self#join_extra_infos interval_array interval_array extra_infos a#get_extra_infos in let dim = self#get_dim in - let new_interval_array = interval_array#join' dim ainterval_array in + let new_interval_array = interval_array#join' dim ainterval_array in - if params#use_intervals then - {< poly = top_poly ; - interval_array = new_interval_array ; + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} else begin try - let big_poly = + let big_poly = let intervals = self#get_non_bottom_intervals interval_array in let p = List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) poly intervals in fst p#restrict_number_vars in - let abig_poly = + let abig_poly = let aintervals = self#get_non_bottom_intervals ainterval_array in let ap = List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) apoly aintervals in @@ -899,15 +899,15 @@ class poly_interval_array_t v2const poly_vs = let (join_poly, join_interval_array) = move_simple_ineqs_to_intervals (big_poly#join abig_poly) new_interval_array in - let big_join_poly = + let big_join_poly = let intervals = self#get_non_bottom_intervals new_interval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) join_poly intervals in - let (small_poly, removed_constraints) = - if params#analysis_level <= 2 then - big_join_poly#restrict_number_vars - else + let (small_poly, _removed_constraints) = + if params#analysis_level <= 2 then + big_join_poly#restrict_number_vars + else let p = self#add_constrs_with_fewer_vars big_join_poly in p#restrict_number_vars in @@ -917,138 +917,138 @@ class poly_interval_array_t v2const poly_vs = let new_poly = small_poly#meet old_poly_int_array#get_poly in {< poly = new_poly; - interval_array = restr_interval_array ; + interval_array = restr_interval_array; extra_infos = new_extra_infos >} - with JCHAnalysisUtils.JCH_num_analysis_failure _ -> - params#set_use_intervals true ; - {< poly = top_poly ; - interval_array = new_interval_array ; + with JCHAnalysisUtils.JCH_num_analysis_failure _ -> + params#set_use_intervals true; + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end (* Used for recursive calls *) method simple_widening (a: 'a) = - + let _ = if !dbg then pr__debug [STR "JCHPolyIntervalArray.widening "; NL; self#toPretty; NL; a#toPretty; NL] in - - let w = + + let w = let ainterval_array = a#get_interval_array in - let new_extra_infos = - self#join_extra_infos interval_array ainterval_array + let new_extra_infos = + self#join_extra_infos interval_array ainterval_array extra_infos a#get_extra_infos in - - let new_interval_array = + + let new_interval_array = interval_array#widening' a#get_interval_array in - - if params#use_intervals then - {< poly = top_poly ; - interval_array = new_interval_array ; + + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} - else + else begin - let new_poly = poly#widening a#get_poly in - {< poly = new_poly ; + let new_poly = poly#widening a#get_poly in + {< poly = new_poly; interval_array = - self#get_best_interval_array new_poly new_interval_array ; - extra_infos = new_extra_infos >} + self#get_best_interval_array new_poly new_interval_array; + extra_infos = new_extra_infos >} end in - + if !dbg then - pr__debug [STR "JCHPolyIntervalArray.widening res: "; w#toPretty; NL] ; + pr__debug [STR "JCHPolyIntervalArray.widening res: "; w#toPretty; NL]; w - + method widening (a: 'a) = - + let _ = if !dbg then pr__debug [STR "JCHPolyIntervalArray.widening "; NL; self#toPretty; NL; a#toPretty; NL] in - - let w = - let apoly = a#get_poly in + + let w = + let apoly = a#get_poly in let ainterval_array = a#get_interval_array in - - let new_extra_infos = - self#join_extra_infos interval_array ainterval_array + + let new_extra_infos = + self#join_extra_infos interval_array ainterval_array extra_infos a#get_extra_infos in - - let new_interval_array = + + let new_interval_array = interval_array#widening a#get_interval_array in - - if params#use_intervals then - {< poly = top_poly ; - interval_array = new_interval_array ; + + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} - else + else begin - let big_poly = + let big_poly = let intervals = self#get_non_bottom_intervals interval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) (fst poly#restrict_number_vars) intervals in - + let (small_poly, _) = big_poly#restrict_number_vars in let (small_poly, _) = small_poly#restrict_number_constraints in - - let abig_poly = + + let abig_poly = let aintervals = self#get_non_bottom_intervals ainterval_array in List.fold_left (fun res (index, interval) -> res#add_constrs_from_interval index interval) (fst apoly#restrict_number_vars) aintervals in - + let (asmall_poly, _) = abig_poly#restrict_number_vars in let (asmall_poly, _) = asmall_poly#restrict_number_constraints in - + let join_poly = small_poly#join asmall_poly in - - let new_poly = + + let new_poly = if params#analysis_level <= 2 then begin let sp = self#add_constrs_no_loop_counters_lengths small_poly in let jp = self#add_constrs_no_loop_counters_lengths join_poly in - sp#widening jp + sp#widening jp end - else + else begin let sp = self#add_constrs_with_fewer_vars small_poly in let jp = self#add_constrs_with_fewer_vars join_poly in let sp = self#add_constrs_no_loop_counters_lengths sp in let jp = self#add_constrs_no_loop_counters_lengths jp in - sp#widening jp + sp#widening jp end in let (restr_poly, _) = - move_simple_ineqs_to_intervals new_poly new_interval_array in + move_simple_ineqs_to_intervals new_poly new_interval_array in - {< poly = restr_poly ; + {< poly = restr_poly; interval_array = new_interval_array; extra_infos = new_extra_infos - >} + >} end in if !dbg then - pr__debug [STR "JCHPolyIntervalArray.widening res: "; w#toPretty; NL] ; + pr__debug [STR "JCHPolyIntervalArray.widening res: "; w#toPretty; NL]; w - method private project_out_in_interval_array interval_array vs = - interval_array#project_out (List.map self#get_index vs) + method private project_out_in_interval_array interval_array vs = + interval_array#project_out (List.map self#get_index vs) - method remove vs = + method remove vs = {< interval_array = interval_array#remove (List.map self#get_index vs) >} - method private add_intervals_to_poly' p array vs = + method private add_intervals_to_poly' p array vs = let constrs = ref [] in let add_constr v = let index = self#get_index v in let interval = array#get index in if interval#isTop || interval#isBottom then - () - else + () + else let cs = mk_constraints_from_interval true index interval in constrs := cs @ !constrs in - List.iter add_constr vs ; + List.iter add_constr vs; if !constrs = [] then p else p#add_constraints !constrs @@ -1056,22 +1056,22 @@ class poly_interval_array_t v2const poly_vs = let new_poly = self#add_intervals_to_poly' poly interval_array poly_vars in {< poly = new_poly >} - method project_out vs = - let new_extra_infos = - let remove_var new_extra_infos v = + method project_out vs = + let new_extra_infos = + let remove_var new_extra_infos v = let int = self#get_interval v in new_extra_infos#remove_var v int in List.fold_left remove_var extra_infos vs in - if params#use_intervals then - {< poly = top_poly ; - interval_array = self#project_out_in_interval_array interval_array vs ; + if params#use_intervals then + {< poly = top_poly; + interval_array = self#project_out_in_interval_array interval_array vs; extra_infos = new_extra_infos >} - else if poly#is_top then + else if poly#is_top then begin let new_interval_array = self#project_out_in_interval_array interval_array vs in - {< poly = top_poly ; - interval_array = new_interval_array; + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end @@ -1084,67 +1084,67 @@ class poly_interval_array_t v2const poly_vs = let unrelated_constrs = List.filter (fun c -> not (List.mem c related_constrs)) constrs in let related_vs = ref [] in - let add_var v = + let add_var v = if related_inds#has (self#get_index v) then - related_vs := v :: !related_vs + related_vs := v :: !related_vs else () in - List.iter add_var poly_vars ; + List.iter add_var poly_vars; let related_poly = mk_poly_from_constraints false related_constrs in - let big_related_poly = - self#add_intervals_to_poly' related_poly interval_array !related_vs in + let big_related_poly = + self#add_intervals_to_poly' related_poly interval_array !related_vs in let restr_poly = big_related_poly#project_out inds in let (restr_poly, new_interval_array) = move_simple_ineqs_to_intervals restr_poly interval_array in let new_interval_array = self#project_out_in_interval_array new_interval_array vs in - {< poly = restr_poly#add_constraints unrelated_constrs; - interval_array = new_interval_array; + {< poly = restr_poly#add_constraints unrelated_constrs; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end - method project_out_array v = - {< interval_array = self#project_out_in_interval_array interval_array [v] ; + method project_out_array v = + {< interval_array = self#project_out_in_interval_array interval_array [v]; extra_infos = extra_infos#remove_all_excluded v >} (* is_geq is true if var >= const is to be added * is_geq is false if var <= const is to be added *) - method add_ineq is_geq var const = - let const_num = new numerical_t const in + method add_ineq is_geq var const = + let const_num = new numerical_t const in let index = self#get_index var in - let interval = + let interval = let int = interval_array#get index in if int#isBottom then interval_array#get_type_interval index (* topInterval *) else int in - let ineq_interval = + let ineq_interval = if is_geq then - new interval_t (bound_of_num const_num) (new bound_t PLUS_INF) + new interval_t (bound_of_num const_num) (new bound_t PLUS_INF) else new interval_t (new bound_t CHBounds.MINUS_INF) (bound_of_num const_num) in if interval#leq ineq_interval then {< >} - else + else begin let new_interval = interval#meet ineq_interval in if new_interval#isBottom then self#mk_bottom - else + else begin let new_interval_array = interval_array#copy_set index new_interval in - let new_extra_infos = - extra_infos#remove_out_of_interval_excluded var new_interval in - let new_poly_int = - if params#use_intervals then - {< poly = top_poly ; - interval_array = new_interval_array ; + let new_extra_infos = + extra_infos#remove_out_of_interval_excluded var new_interval in + let new_poly_int = + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} - else if params#max_number_constraints_allowed <= 10 then + else if params#max_number_constraints_allowed <= 10 then {< interval_array = new_interval_array; - extra_infos = new_extra_infos >} + extra_infos = new_extra_infos >} else {< interval_array = self#get_best_interval_array poly new_interval_array; extra_infos = new_extra_infos >} in @@ -1155,182 +1155,182 @@ class poly_interval_array_t v2const poly_vs = val neg_unit_big_int = minus_big_int unit_big_int method private assert_greater is_strict_ineq x y = - + if !dbg then pr__debug [STR "assert_greater "; x#toPretty; STR " "; - y#toPretty; NL; self#toPretty] ; + y#toPretty; NL; self#toPretty]; - let res = + let res = let x_index = self#get_index x in let x_int = self#get_best_interval x_index in - let y_int = + let y_int = if self#is_const y then mkSingletonInterval (self#get_const_val_n y) else self#get_best_interval (self#get_index y) in let excluded_vals_x = NumericalCollections.set_of_list (extra_infos#get_excluded_vals x) in let excluded_vals_y = NumericalCollections.set_of_list (extra_infos#get_excluded_vals y) in - let x_int' = + let x_int' = let ymin = y_int#getMin in - if is_strict_ineq then + if is_strict_ineq then begin - if self#is_discrete x then + if self#is_discrete x then x_int#strictLowerBound ymin - else + else begin - (match ymin#getBound with - | NUMBER num -> excluded_vals_x#add num - | _ -> () ) ; + (match ymin#getBound with + | NUMBER num -> excluded_vals_x#add num + | _ -> () ); x_int#lowerBound ymin end end - else + else begin - (if not (self#is_discrete x) then - match ymin#getBound with - | NUMBER num -> + (if not (self#is_discrete x) then + match ymin#getBound with + | NUMBER num -> if excluded_vals_y#has num then excluded_vals_x#add num - | _ -> ()) ; - x_int#lowerBound ymin + | _ -> ()); + x_int#lowerBound ymin end in - let y_int' = + let y_int' = let xmax = x_int#getMax in - if is_strict_ineq then + if is_strict_ineq then begin - if self#is_discrete y then - y_int#strictUpperBound xmax - else + if self#is_discrete y then + y_int#strictUpperBound xmax + else begin - (match xmax#getBound with - | NUMBER num -> excluded_vals_y#add num - | _ -> () ) ; + (match xmax#getBound with + | NUMBER num -> excluded_vals_y#add num + | _ -> () ); y_int#upperBound xmax end end - else + else begin - (if not (self#is_discrete y) then - match xmax#getBound with - | NUMBER num -> + (if not (self#is_discrete y) then + match xmax#getBound with + | NUMBER num -> if excluded_vals_x#has num then excluded_vals_y#add num - | _ -> ()) ; - y_int#upperBound xmax + | _ -> ()); + y_int#upperBound xmax end in - if x_int'#isBottom || y_int'#isBottom then self#mk_bottom - else + if x_int'#isBottom || y_int'#isBottom then self#mk_bottom + else begin let new_interval_array = interval_array#copy in - new_interval_array#set x_index x_int' ; - if self#is_const y then () - else new_interval_array#set (self#get_index y) y_int' ; + new_interval_array#set x_index x_int'; + if self#is_const y then () + else new_interval_array#set (self#get_index y) y_int'; let new_extra_infos = extra_infos#set_excluded_vals x excluded_vals_x#toList in let new_extra_infos = new_extra_infos#remove_out_of_interval_excluded x x_int' in let new_extra_infos = new_extra_infos#set_excluded_vals y excluded_vals_y#toList in let new_extra_infos = new_extra_infos#remove_out_of_interval_excluded y y_int' in - if params#use_intervals then - let new_poly = - {< poly = top_poly; - interval_array = new_interval_array ; + if params#use_intervals then + let new_poly = + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} in new_poly - else + else begin let const = if is_strict_ineq then neg_unit_big_int else zero_big_int in - let new_poly = + let new_poly = let pairs = [(x, unit_big_int); (y, neg_unit_big_int)] in let pairs' = List.map self#put_index pairs in let constr = new linear_constraint_t false pairs' const in poly#add_constraints [constr] in if new_poly#is_bottom then - self#mk_bottom - else - {< poly = new_poly; - interval_array = self#get_best_interval_array new_poly new_interval_array ; - extra_infos = new_extra_infos >} + self#mk_bottom + else + {< poly = new_poly; + interval_array = self#get_best_interval_array new_poly new_interval_array; + extra_infos = new_extra_infos >} end end in - + if !dbg then - pr__debug [STR "assert_greater res = "; NL; res#toPretty; NL] ; - res - - + pr__debug [STR "assert_greater res = "; NL; res#toPretty; NL]; + res + + method assert_geq x y = - + if !dbg then - pr__debug [STR "assert_geq "; x#toPretty; STR " "; y#toPretty; NL] ; - - let res = - if self#is_const x then + pr__debug [STR "assert_geq "; x#toPretty; STR " "; y#toPretty; NL]; + + let res = + if self#is_const x then if self#is_const y then if ge_big_int (self#get_const_val x) (self#get_const_val y) then {< >} else - self#mk_bottom + self#mk_bottom else - self#add_ineq false y (self#get_const_val x) + self#add_ineq false y (self#get_const_val x) else if self#is_const y then - self#add_ineq true x (self#get_const_val y) + self#add_ineq true x (self#get_const_val y) else self#assert_greater false x y in - + if !dbg then - pr__debug [STR "assert_geq res = "; NL; res#toPretty; NL] ; + pr__debug [STR "assert_geq res = "; NL; res#toPretty; NL]; res method assert_gt x y = - + if !dbg then pr__debug [STR "assert_gt "; x#toPretty; STR " "; y#toPretty; NL; - self#toPretty; NL] ; + self#toPretty; NL]; - let res = - if self#is_discrete x then - if self#is_const x then + let res = + if self#is_discrete x then + if self#is_const x then if self#is_const y then if gt_big_int (self#get_const_val x) (self#get_const_val y) then {< >} - else self#mk_bottom - else + else self#mk_bottom + else begin let const = sub_big_int (self#get_const_val x) unit_big_int in - self#add_ineq false y const + self#add_ineq false y const end - else if self#is_const y then + else if self#is_const y then begin let const = add_big_int (self#get_const_val y) unit_big_int in - self#add_ineq true x const + self#add_ineq true x const end - else self#assert_greater true x y - else - if self#is_const y then + else self#assert_greater true x y + else + if self#is_const y then begin let const = add_big_int (self#get_const_val y) unit_big_int in - self#add_ineq true x const + self#add_ineq true x const end - else + else self#assert_greater true x y in - + if !dbg then - pr__debug [STR "assert_gt res = "; NL; res#toPretty; NL] ; + pr__debug [STR "assert_gt res = "; NL; res#toPretty; NL]; res method assert_neq x y = - + if !dbg then - pr__debug [STR "assert_neq "; x#toPretty; STR " "; y#toPretty; NL] ; + pr__debug [STR "assert_neq "; x#toPretty; STR " "; y#toPretty; NL]; - let res = - let x_i = + let res = + let x_i = if self#is_const x then - mkSingletonInterval (self#get_const_val_n x) - else + mkSingletonInterval (self#get_const_val_n x) + else let x_index = self#get_index x in self#get_best_interval x_index in - let y_i = - if self#is_const y then - mkSingletonInterval (self#get_const_val_n y) - else + let y_i = + if self#is_const y then + mkSingletonInterval (self#get_const_val_n y) + else let y_index = self#get_index y in self#get_best_interval y_index in match (x_i#singleton, y_i#singleton) with @@ -1341,13 +1341,13 @@ class poly_interval_array_t v2const poly_vs = begin match y_i#getMax#getBound with | NUMBER max when max#equal x_c -> self#assert_gt x y - | NUMBER max when max#lt x_c -> {< >} + | NUMBER max when max#lt x_c -> {< >} | _ -> begin match y_i#getMin#getBound with | NUMBER min when min#equal x_c -> self#assert_gt y x - | NUMBER min when min#gt x_c -> {< >} - | _ -> + | NUMBER min when min#gt x_c -> {< >} + | _ -> let new_extra_infos = extra_infos#add_excluded_val y x_c in {< extra_infos = new_extra_infos >} end @@ -1356,13 +1356,13 @@ class poly_interval_array_t v2const poly_vs = begin match x_i#getMax#getBound with | NUMBER max when max#equal y_c -> self#assert_gt y x - | NUMBER max when max#lt y_c -> {< >} + | NUMBER max when max#lt y_c -> {< >} | _ -> begin match x_i#getMin#getBound with - | NUMBER min when min#equal y_c -> self#assert_gt x y + | NUMBER min when min#equal y_c -> self#assert_gt x y | NUMBER min when min#gt y_c -> {< >} - | _ -> + | _ -> let new_extra_infos = extra_infos#add_excluded_val x y_c in {< extra_infos = new_extra_infos >} end @@ -1370,87 +1370,87 @@ class poly_interval_array_t v2const poly_vs = | _ -> {< >} in if !dbg then - pr__debug [STR "assert_neq res = "; NL; res#toPretty; NL] ; + pr__debug [STR "assert_neq res = "; NL; res#toPretty; NL]; res - + method private affine_image_i vpair pairs const = - + if !dbg then - pr__debug [STR "affine_image_i "; NL] ; - - let (var, den) = vpair in + pr__debug [STR "affine_image_i "; NL]; + + let (_var, den) = vpair in let rhs = ref (mkSingletonInterval (new numerical_t const)) in let add_pair (v, i) = let coeff = mkSingletonInterval (new numerical_t i) in let index = self#get_index v in let interval = interval_array#get index in rhs := !rhs#add (interval#mult coeff) in - List.iter add_pair pairs ; + List.iter add_pair pairs; let den = mkSingletonInterval (new numerical_t den) in let interval = !rhs#div den in interval (* Computes the image of the transformation coeff * var = sum of a * v + const * where vpair = (var, coeff) and pairs is a list of (v, a) - * In case an equality (equality = Some w) is processed then the extra + * In case an equality (equality = Some w) is processed then the extra * infos are copied *) method affine_image (equality:variable_t option) (vpair:variable_t * big_int) (pairs:(variable_t * big_int) list) - (const:big_int):('a * variable_t option * variable_t option) = + (const:big_int):('a * variable_t option * variable_t option) = let var = fst vpair in let (index, coeff) = self#put_index vpair in let old_interval = interval_array#get index in let new_interval_array = interval_array#copy in let interval = self#affine_image_i vpair pairs const in - let (min_ok, max_ok) = - if params#use_overflow then + let (min_ok, max_ok) = + if params#use_overflow then begin let tinterval = interval_array#get_type_interval index in let max_ok = tinterval#getMax#geq interval#getMax in let min_ok = tinterval#getMin#leq interval#getMin in - (min_ok, max_ok) + (min_ok, max_ok) end else (true, true) in - if min_ok && max_ok then + if min_ok && max_ok then begin - let interval = + let interval = if params#use_overflow then interval else interval#meet (interval_array#get_type_interval index) in - new_interval_array#set index interval ; - let new_poly = + new_interval_array#set index interval; + let new_poly = if params#use_intervals then - top_poly - else if Option.is_some interval#singleton then + top_poly + else if Option.is_some interval#singleton then poly#project_out [index] - else - let pairs' = List.map self#put_index pairs in + else + let pairs' = List.map self#put_index pairs in poly#affine_image index coeff pairs' const old_interval in let (restr_poly, restr_interval_array) = move_simple_ineqs_to_intervals new_poly new_interval_array in let (restr_poly, _) = restr_poly#restrict_number_constraints in let best_interval_array = self#get_best_interval_array restr_poly restr_interval_array in - let new_extra_infos = - let ei = - match equality with - | Some w -> + let new_extra_infos = + let ei = + match equality with + | Some w -> extra_infos#set_same_info var w | _ -> extra_infos in ei#remove_out_of_interval_excluded var interval in - ({< poly = restr_poly; - interval_array = best_interval_array ; + ({< poly = restr_poly; + interval_array = best_interval_array; extra_infos = new_extra_infos >}, None, None) end - else + else (self#project_out [var] , (if max_ok then None else Some var) , - (if min_ok then None else Some var) ) + (if min_ok then None else Some var) ) (* Computes the image of the transformation v = coeff * w + const or v = const *) @@ -1458,12 +1458,12 @@ class poly_interval_array_t v2const poly_vs = (v:variable_t) (w_opt:variable_t option) (coeff:big_int) - (const: big_int):('a * variable_t option * variable_t option) = + (const: big_int):('a * variable_t option * variable_t option) = let v_index = self#get_index v in let v_interval = interval_array#get v_index in let new_interval_array = interval_array#copy in - match w_opt with - | Some w -> + match w_opt with + | Some w -> begin let w_index = self#get_index w in let w_interval = interval_array#get w_index in @@ -1472,62 +1472,62 @@ class poly_interval_array_t v2const poly_vs = (mkSingletonInterval (new numerical_t coeff)))#add (mkSingletonInterval (new numerical_t const)) in - let (min_ok, max_ok) = - if params#use_overflow then + let (min_ok, max_ok) = + if params#use_overflow then begin let v_tinterval = interval_array#get_type_interval v_index in let max_ok = v_tinterval#getMax#geq new_v_interval#getMax in let min_ok = v_tinterval#getMin#leq new_v_interval#getMin in - (min_ok, max_ok) - end + (min_ok, max_ok) + end else (true, true) in - if min_ok && max_ok then + if min_ok && max_ok then begin - let new_v_interval = + let new_v_interval = if params#use_overflow then new_v_interval else new_v_interval#meet (interval_array#get_type_interval v_index) in - new_interval_array#set v_index new_v_interval ; - let new_poly = + new_interval_array#set v_index new_v_interval; + let new_poly = if params#use_intervals then top_poly - else + else begin let proj_poly = - if List.exists (fun c -> c#has_index v_index) poly#get_constraints then - (self#project_out [v])#get_poly + if List.exists (fun c -> c#has_index v_index) poly#get_constraints then + (self#project_out [v])#get_poly else poly in if Option.is_some new_v_interval#singleton then proj_poly - else + else let neg_coeff = minus_big_int coeff in let constr = new linear_constraint_t true [(v_index, unit_big_int); (w_index, neg_coeff)] (minus_big_int const) in - proj_poly#add_constraints [constr] + proj_poly#add_constraints [constr] end in - let new_extra_infos = - let ei = - if eq_big_int const zero_big_int then + let new_extra_infos = + let ei = + if eq_big_int const zero_big_int then extra_infos#set_same_info v w else extra_infos in ei#remove_out_of_interval_excluded v new_v_interval in - ({< poly = new_poly; - interval_array = new_interval_array ; + ({< poly = new_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >}, None, None) end else begin let new_poly_int_array = self#project_out [v] in - let new_poly_int_array = + let new_poly_int_array = if eq_big_int const zero_big_int && eq_big_int coeff unit_big_int then - new_poly_int_array#copy_num_info v w + new_poly_int_array#copy_num_info v w else new_poly_int_array in (new_poly_int_array, @@ -1535,116 +1535,116 @@ class poly_interval_array_t v2const poly_vs = (if min_ok then None else Some v) ) end end - | _ -> + | _ -> begin let new_v_interval = mkSingletonInterval (new numerical_t const) in - let (min_ok, max_ok) = + let (min_ok, max_ok) = if params#use_overflow then begin let v_tinterval = interval_array#get_type_interval v_index in let max_ok = v_tinterval#getMax#geq new_v_interval#getMax in let min_ok = v_tinterval#getMin#leq new_v_interval#getMin in - (min_ok, max_ok) - end + (min_ok, max_ok) + end else (true, true) in - if min_ok && max_ok then + if min_ok && max_ok then begin - new_interval_array#set v_index new_v_interval ; + new_interval_array#set v_index new_v_interval; let big_poly = poly#add_constraints (mk_constraints_from_interval true v_index v_interval) in let proj_poly = big_poly#project_out [v_index] in - ({}, None, None) end - else + else (self#project_out [v] , (if max_ok then None else Some v) , - (if min_ok then None else Some v) ) + (if min_ok then None else Some v) ) end (* Computes the image of the transformation v = v + const *) method affine_increment (var:variable_t) - (const:big_int):('a * variable_t option * variable_t option) = + (const:big_int):('a * variable_t option * variable_t option) = let index = self#get_index var in let interval = interval_array#get index in let new_interval_array = interval_array#copy in let new_interval = interval#add (mkSingletonInterval (new numerical_t const)) in - let (min_ok, max_ok) = + let (min_ok, max_ok) = if params#use_overflow then begin let tinterval = interval_array#get_type_interval index in let max_ok = tinterval#getMax#geq new_interval#getMax in let min_ok = tinterval#getMin#leq new_interval#getMin in - (min_ok, max_ok) + (min_ok, max_ok) end else (true, true) in - if min_ok && max_ok then + if min_ok && max_ok then begin - let new_interval = + let new_interval = if params#use_overflow then new_interval else new_interval#meet (interval_array#get_type_interval index) in - new_interval_array#set index new_interval ; - let new_poly = + new_interval_array#set index new_interval; + let new_poly = if params#use_intervals then - top_poly - else if Option.is_some new_interval#singleton then + top_poly + else if Option.is_some new_interval#singleton then poly#project_out [index] - else + else poly#affine_increment index const in - ({< poly = new_poly; + ({< poly = new_poly; interval_array = new_interval_array >}, None, None) end - else + else (self#project_out [var] , (if max_ok then None else Some var) , - (if min_ok then None else Some var) ) + (if min_ok then None else Some var) ) method affine_preimage (vpair:variable_t * big_int) (pairs:(variable_t * big_int) list) - (const:big_int):'a = + (const:big_int):'a = let (col, coeff) = self#put_index vpair in - let pairs' = List.map self#put_index pairs in + let pairs' = List.map self#put_index pairs in let var = fst vpair in let new_interval_array = self#project_out_in_interval_array interval_array [var] in - let new_extra_infos = + let new_extra_infos = let int = self#get_interval var in extra_infos#remove_var var int in - if params#use_intervals then - {< poly = top_poly; - interval_array = new_interval_array ; + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} - else - {< poly = poly#affine_preimage col coeff pairs' const ; + else + {< poly = poly#affine_preimage col coeff pairs' const; interval_array = new_interval_array; extra_infos = new_extra_infos >} method add_vars (jproc_info:JCHProcInfo.jproc_info_t) (other_vars: variable_t list):'a = - + let _ = if !dbg then pr__debug [STR "add_vars "; pp_list other_vars; NL; self#toPretty; NL] in - let res = + let res = if self#is_bottom then - {< >} - else + {< >} + else begin let is_new var = not (self#is_const var) && not (List.mem var poly_vars) in let vars_to_add = List.filter is_new other_vars in if vars_to_add = [] then {< >} - else + else begin let new_vars = poly_vars @ vars_to_add in let new_dim = List.length new_vars in @@ -1654,7 +1654,7 @@ class poly_interval_array_t v2const poly_vs = let new_interval_array = new_interval_array#set_type_intervals jproc_info new_vars in {< poly_vars = new_vars; - var_to_index = new_var_to_index ; + var_to_index = new_var_to_index; interval_array = new_interval_array >} end @@ -1662,79 +1662,79 @@ class poly_interval_array_t v2const poly_vs = let _ = if !dbg then pr__debug [STR "after add_vars, res = "; NL; res#toPretty; NL] in - res + res method mult (v:variable_t) (x:variable_t) - (y:variable_t):('a * variable_t option * variable_t option * bool) = + (y:variable_t):('a * variable_t option * variable_t option * bool) = let new_interval_array = interval_array#copy in - let x_int = + let x_int = let index = (self#get_index x) in let int = self#get_best_interval index in begin - new_interval_array#set index int ; + new_interval_array#set index int; int end in - let y_int = + let y_int = let index = (self#get_index y) in let int = self#get_best_interval index in begin - new_interval_array#set index int ; + new_interval_array#set index int; int end in - let mult_int = - if x = y then + let mult_int = + if x = y then let x_min = x_int#getMin in let x_max = x_int#getMax in let max = (x_min#mult x_min)#max (x_max#mult x_max) in - new interval_t zero_bound max + new interval_t zero_bound max else x_int#mult y_int in - let v_ind = self#get_index v in + let v_ind = self#get_index v in let x_ind = self#get_index x in let y_ind = self#get_index y in - new_interval_array#set v_ind mult_int ; - - let v_int = + new_interval_array#set v_ind mult_int; + + let v_int = if params#use_intervals then - mult_int - else + mult_int + else let divisions = extra_infos#get_divisions y in if divisions = [] then - mult_int - else + mult_int + else begin - let process_division p (dividend, quotient) = + let process_division p (dividend, quotient) = try (* ?? *) - let quot_ind = self#get_index quotient in - let (dividend_ind_opt, const_opt) = - if self#is_const dividend then + let quot_ind = self#get_index quotient in + let (dividend_ind_opt, const_opt) = + if self#is_const dividend then (None, Some (self#get_const_val dividend)) else (Some (self#get_index dividend), None) in - if zero_bound#leq y_int#getMin then + if zero_bound#leq y_int#getMin then p#add_mult_constr - v_ind x_ind quot_ind dividend_ind_opt const_opt true - else if y_int#getMax#leq zero_bound then + v_ind x_ind quot_ind dividend_ind_opt const_opt true + else if y_int#getMax#leq zero_bound then p#add_mult_constr - v_ind x_ind y_ind dividend_ind_opt const_opt false - else p + v_ind x_ind y_ind dividend_ind_opt const_opt false + else p with _ -> p in let poly' = List.fold_left process_division poly divisions in let interval = self#_get_best_interval poly' new_interval_array v_ind in - interval#meet mult_int + interval#meet mult_int end in let v_index = self#get_index v in let new_poly = poly#project_out [v_index] in let tinterval = interval_array#get_type_interval v_ind in - let (min_ok, max_ok) = + let (min_ok, max_ok) = if params#use_overflow then - (tinterval#getMin#leq v_int#getMin, tinterval#getMax#geq v_int#getMax) + (tinterval#getMin#leq v_int#getMin, tinterval#getMax#geq v_int#getMax) else (true, true) in let interval = v_int#meet tinterval in - new_interval_array#set v_index interval ; + new_interval_array#set v_index interval; let overflow = if max_ok then None else Some v in let underflow = if min_ok then None else Some v in let v_lost_info = @@ -1742,22 +1742,22 @@ class poly_interval_array_t v2const poly_vs = || poly#is_used_ind y_ind || extra_infos#has_fields x || extra_infos#has_fields y in - ({< poly = new_poly; - interval_array = new_interval_array >}, + ({< poly = new_poly; + interval_array = new_interval_array >}, overflow, underflow, v_lost_info) - method private is_not_excluded v c = + method private is_not_excluded v c = let excluded_vals = extra_infos#get_excluded_vals v in not (List.exists c#equal excluded_vals) - method private _can_be_0 y y_int = - y_int#contains numerical_zero && self#is_not_excluded y numerical_zero ; + method private _can_be_0 y y_int = + y_int#contains numerical_zero && self#is_not_excluded y numerical_zero; - method can_be_0 y = - if self#is_const y then + method can_be_0 y = + if self#is_const y then (self#get_const_val_n y)#equal numerical_zero - else - let int = self#get_best_interval (self#get_index y) in + else + let int = self#get_best_interval (self#get_index y) in int#contains numerical_zero && self#is_not_excluded y numerical_zero method div @@ -1765,34 +1765,34 @@ class poly_interval_array_t v2const poly_vs = (v:variable_t) (x:variable_t) (y:variable_t):'a * variable_t option * variable_t option * variable_t option = - + if !dbg then pr__debug [STR "div "; v#toPretty; STR " "; x#toPretty; STR " "; - y#toPretty; NL; self#toPretty; NL] ; + y#toPretty; NL; self#toPretty; NL]; let new_interval_array = interval_array#copy in - let x_int = - if self#is_const x then mkSingletonInterval (self#get_const_val_n x) - else + let x_int = + if self#is_const x then mkSingletonInterval (self#get_const_val_n x) + else let index = (self#get_index x) in let int = self#get_best_interval index in begin - new_interval_array#set index int ; + new_interval_array#set index int; int end in let y_int = (* not constant *) if self#is_const y then - mkSingletonInterval (self#get_const_val_n y) - else + mkSingletonInterval (self#get_const_val_n y) + else let index = (self#get_index y) in let int = self#get_best_interval index in begin - new_interval_array#set index int ; - int + new_interval_array#set index int; + int end in let v_int = JCHAnalysisUtils.integer_div x_int y_int in let divided_by_0 = - if self#_can_be_0 y y_int then + if self#_can_be_0 y y_int then if is_float then None else @@ -1803,65 +1803,65 @@ class poly_interval_array_t v2const poly_vs = let new_poly = poly#project_out [v_index] in let tinterval = interval_array#get_type_interval v_index in let interval = v_int#meet tinterval in - new_interval_array#set v_index interval ; - - let overflow = - if params#use_overflow then - if y_int#contains numerical_one#neg + new_interval_array#set v_index interval; + + let overflow = + if params#use_overflow then + if y_int#contains numerical_one#neg && x_int#getMin#leq tinterval#getMin then - Some v + Some v else - None + None else None in - let new_poly_int_array = - if not is_float && Option.is_some divided_by_0 then + let new_poly_int_array = + if not is_float && Option.is_some divided_by_0 then begin if Option.is_some y_int#singleton then - self#mk_bottom - else if self#is_const y then + self#mk_bottom + else if self#is_const y then {< poly = new_poly; interval_array = new_interval_array >} else let min = y_int#getMin in let max = y_int#getMax in - if min#equal zero_bound then + if min#equal zero_bound then let new_y_int = new interval_t one_bound max in begin - new_interval_array#set (self#get_index y) new_y_int ; + new_interval_array#set (self#get_index y) new_y_int; {< poly = new_poly; interval_array = new_interval_array >} end - else if max#equal zero_bound then + else if max#equal zero_bound then let new_y_int = new interval_t min (max#sub one_bound) in begin - new_interval_array#set (self#get_index y) new_y_int ; + new_interval_array#set (self#get_index y) new_y_int; {< poly = new_poly; interval_array = new_interval_array >} end - else + else let new_extra_infos = extra_infos#add_excluded_val y numerical_zero in begin {< poly = new_poly; - interval_array = new_interval_array ; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end end else - {< poly = new_poly; interval_array = new_interval_array >} in + {< poly = new_poly; interval_array = new_interval_array >} in (new_poly_int_array, divided_by_0, overflow, None) method rem (is_float:bool) (v:variable_t) (x:variable_t) (y:variable_t) = - + if !dbg then - pr__debug [STR "rem "; v#toPretty; STR " "; y#toPretty; NL] ; - - let y_int = + pr__debug [STR "rem "; v#toPretty; STR " "; y#toPretty; NL]; + + let y_int = if self#is_const y then mkSingletonInterval (self#get_const_val_n y) else self#get_best_interval (self#get_index y) in - match y_int#singleton with - | Some n -> + match y_int#singleton with + | Some n -> if n#equal numerical_zero then (* y = 0 *) - if is_float then (self#project_out [v], None) + if is_float then (self#project_out [v], None) else (self#mk_bottom, Some y) else if n#gt numerical_zero then (* y > 0 *) @@ -1870,20 +1870,20 @@ class poly_interval_array_t v2const poly_vs = begin let num = self#get_const_val_n x in let is_x_pos = num#geq numerical_zero in - if is_x_pos then + if is_x_pos then let (pia, _, _) = self#affine_image None (v, unit_big_int) [] num#getNum in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end else begin let is_x_pos = self#leq (self#drop_all#add_ineq true x zero_big_int) in - if is_x_pos then + if is_x_pos then let (pia, _, _) = self#affine_image None (v, unit_big_int) [(x, unit_big_int)] zero_big_int in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end end else (* y < 0 *) @@ -1892,74 +1892,74 @@ class poly_interval_array_t v2const poly_vs = begin let num = self#get_const_val_n x in let is_x_neg = num#leq numerical_zero in - if is_x_neg then + if is_x_neg then let (pia, _, _) = self#affine_image None (v, unit_big_int) [] num#getNum in - (pia, None) - else (self#project_out [v], None) - + (pia, None) + else (self#project_out [v], None) + end else begin let is_x_neg = self#leq (self#drop_all#add_ineq false x zero_big_int) in - if is_x_neg then + if is_x_neg then let (pia, _, _) = self#affine_image None (v, unit_big_int) [(x, unit_big_int)] zero_big_int in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end end - | _ -> - if self#_can_be_0 y y_int then + | _ -> + if self#_can_be_0 y y_int then if is_float then - (self#project_out [v], None) - else + (self#project_out [v], None) + else begin let v_index = self#get_index v in let new_interval_array = interval_array#project_out [v_index] in let new_poly = poly#project_out [v_index] in let min = y_int#getMin in let max = y_int#getMax in - if min#equal zero_bound then + if min#equal zero_bound then let new_y_int = new interval_t one_bound max in - new_interval_array#set (self#get_index y) new_y_int ; + new_interval_array#set (self#get_index y) new_y_int; let new_poly_interval_array = {< poly = new_poly; interval_array = new_interval_array >} in - (new_poly_interval_array, Some y) - else if max#equal zero_bound then + (new_poly_interval_array, Some y) + else if max#equal zero_bound then let new_y_int = new interval_t min (max#sub one_bound) in - new_interval_array#set (self#get_index y) new_y_int ; + new_interval_array#set (self#get_index y) new_y_int; let new_poly_interval_array = {< poly = new_poly; interval_array = new_interval_array >} in (new_poly_interval_array, Some y) - else + else let new_extra_infos = extra_infos#add_excluded_val y numerical_zero in let new_poly_interval_array = {< poly = new_poly; - interval_array = new_interval_array ; + interval_array = new_interval_array; extra_infos = new_extra_infos >} in (new_poly_interval_array, Some y) end - else - if y_int#getMin#geq zero_bound then (* y >= 0 *) + else + if y_int#getMin#geq zero_bound then (* y >= 0 *) begin if self#is_const x then begin let num = self#get_const_val_n x in let is_x_pos = num#geq numerical_zero in - if is_x_pos then + if is_x_pos then let (pia, _, _) = self#affine_image None (v, unit_big_int) [] num#getNum in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end else begin let is_x_pos = self#leq (self#drop_all#add_ineq true x zero_big_int) in - if is_x_pos then (* x >= 0 *) + if is_x_pos then (* x >= 0 *) let (pia, _, _) = self#affine_image None (v, unit_big_int) [(x, unit_big_int)] zero_big_int in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end end else if y_int#getMax#leq zero_bound then (* y <= 0 *) @@ -1968,24 +1968,24 @@ class poly_interval_array_t v2const poly_vs = begin let num = self#get_const_val_n x in let is_x_neg = num#leq numerical_zero in - if is_x_neg then + if is_x_neg then let (pia, _, _) = self#affine_image None (v, unit_big_int) [] num#getNum in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end else begin let is_x_neg = self#leq (self#drop_all#add_ineq false x zero_big_int) in - if is_x_neg then (* x <= 0 *) + if is_x_neg then (* x <= 0 *) let (pia, _, _) = self#affine_image None (v, unit_big_int) [(x, unit_big_int)] zero_big_int in - (pia, None) - else (self#project_out [v], None) + (pia, None) + else (self#project_out [v], None) end end - else (self#project_out [v] , None) - - method log_and (v:variable_t) (x:variable_t) (y:variable_t):'a = + else (self#project_out [v] , None) + + method log_and (v:variable_t) (x:variable_t) (y:variable_t):'a = let x_int = self#get_interval x in let y_int = self#get_interval y in let x_min = x_int#getMin in @@ -1996,19 +1996,19 @@ class poly_interval_array_t v2const poly_vs = let y_pos = y_min#geq zero_bound in if x_pos || y_pos then begin - let v_max = - if x_pos then + let v_max = + if x_pos then if y_pos then x_max#min y_max - else x_int#getMax + else x_int#getMax else y_int#getMax in let v_int = new interval_t zero_bound v_max in self#set_interval v v_int end - else + else begin let x_neg = x_max#leq zero_bound in let y_neg = y_max#leq zero_bound in - if x_neg && y_neg then + if x_neg && y_neg then begin let v_min = x_min#max y_min in let v_int = new interval_t v_min zero_bound in @@ -2018,7 +2018,7 @@ class poly_interval_array_t v2const poly_vs = self#project_out [v] end - method log_or (v:variable_t) (x:variable_t) (y:variable_t):'a = + method log_or (v:variable_t) (x:variable_t) (y:variable_t):'a = let x_int = self#get_interval x in let y_int = self#get_interval y in let x_min = x_int#getMin in @@ -2027,19 +2027,19 @@ class poly_interval_array_t v2const poly_vs = let y_max = y_int#getMax in let x_pos = x_min#geq zero_bound in let y_pos = y_min#geq zero_bound in - if x_pos && y_pos then + if x_pos && y_pos then let v_max = x_max#max y_max in let v_int = new interval_t zero_bound v_max in self#set_interval v v_int else self#project_out [v] - method shr (v:variable_t) (x:variable_t):'a = + method shr (v:variable_t) (x:variable_t):'a = let x_int = self#get_interval x in let x_min = x_int#getMin in let x_max = x_int#getMax in let x_pos = x_min#geq zero_bound in - if x_pos then + if x_pos then let v_max = x_max#div_floor (bound_of_num (mkNumerical 2)) in let v_int = new interval_t zero_bound v_max in self#set_interval v v_int @@ -2047,69 +2047,69 @@ class poly_interval_array_t v2const poly_vs = self#project_out [v] method private assert_eq_const v n = - + if !dbg then pr__debug [STR "assert_eq_const "; v#toPretty; STR " "; - n#toPretty; NL; self#toPretty; NL] ; - - let new_interval_array = interval_array#copy in + n#toPretty; NL; self#toPretty; NL]; + + let new_interval_array = interval_array#copy in let index = (self#get_index v) in let interval = self#get_best_interval index in let int = mkSingletonInterval n in let meet_int = interval#meet int in if meet_int#isBottom then - self#mk_bottom - else if params#use_intervals then + self#mk_bottom + else if params#use_intervals then begin - new_interval_array#set index meet_int ; - {< poly = top_poly; + new_interval_array#set index meet_int; + {< poly = top_poly; interval_array = new_interval_array >} end - else + else begin - new_interval_array#set index meet_int ; + new_interval_array#set index meet_int; {< interval_array = new_interval_array >} end method assert_non_const_eq (x:variable_t) (y:variable_t):'a = - + let _ = if !dbg then pr__debug [STR "assert_non_const_eq "; x#toPretty; STR " "; y#toPretty; NL; self#toPretty] in - let res = + let res = let x_index = self#get_index x in let y_index = self#get_index y in let x_int = self#get_best_interval x_index in let y_int = self#get_best_interval y_index in - let int = x_int#meet y_int in + let int = x_int#meet y_int in if int#isBottom then - self#mk_bottom - else + self#mk_bottom + else begin let new_interval_array = interval_array#copy in - new_interval_array#set x_index int ; - new_interval_array#set y_index int ; - if params#use_intervals then - {< poly = top_poly; + new_interval_array#set x_index int; + new_interval_array#set y_index int; + if params#use_intervals then + {< poly = top_poly; interval_array = new_interval_array >} - else - match int#singleton with - | Some n -> + else + match int#singleton with + | Some _ -> {< interval_array = new_interval_array >} - | None -> - let new_poly = - let pairs = [(x_index, unit_big_int); (y_index, neg_unit_big_int)] in + | None -> + let new_poly = + let pairs = [(x_index, unit_big_int); (y_index, neg_unit_big_int)] in let constr = new linear_constraint_t true pairs zero_big_int in poly#add_constraints [constr] in - let new_excluded_vals = + let new_excluded_vals = let excluded_x = extra_infos#get_excluded_vals x in let excluded_y = extra_infos#get_excluded_vals y in List.filter (fun vl -> List.exists vl#equal excluded_x) excluded_y in let new_extra_infos = extra_infos#set_excluded_vals x new_excluded_vals in let new_extra_infos = new_extra_infos#set_excluded_vals y new_excluded_vals in - {< poly = new_poly ; - interval_array = new_interval_array ; + {< poly = new_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} end in let _ = @@ -2118,52 +2118,52 @@ class poly_interval_array_t v2const poly_vs = res method assert_eq (x:variable_t) (y:variable_t):'a = - + if !dbg then pr__debug [STR "assert_eq "; x#toPretty; STR " "; - y#toPretty; NL; self#toPretty; NL] ; + y#toPretty; NL; self#toPretty; NL]; - let res = + let res = if self#is_bottom then - self#mk_bottom - else if self#is_const x then + self#mk_bottom + else if self#is_const x then let x_n = self#get_const_val_n x in - if self#is_const y then + if self#is_const y then if x_n#equal (self#get_const_val_n y) then {< >} else - self#mk_bottom + self#mk_bottom else - self#assert_eq_const y x_n - else if self#is_const y then + self#assert_eq_const y x_n + else if self#is_const y then self#assert_eq_const x (self#get_const_val_n y) else self#assert_non_const_eq x y in - + let _ = if !dbg then pr__debug [STR "after assert_eq "; NL; res#toPretty; NL] in res method private add_const_intervals_and_eqs - var_to_index int_array eqs vars = - let add eqs var = - if self#is_const var then + var_to_index int_array eqs vars = + let add eqs var = + if self#is_const var then begin - let i = + let i = try - List.assoc var#getIndex var_to_index + List.assoc var#getIndex var_to_index with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "Index not found for " ; INT var#getIndex ; + (JCH_failure + (LBLOCK [ STR "Index not found for "; INT var#getIndex; STR " in JCHPolyIntervalArray.add_const_intervals_and_eqs" ])) in - let big_int_const = self#get_const_val var in - int_array#set i (mkSingletonInterval (new numerical_t big_int_const)) ; - + let big_int_const = self#get_const_val var in + int_array#set i (mkSingletonInterval (new numerical_t big_int_const)); + let eq = ([(i, unit_big_int)], minus_big_int big_int_const) in - eq :: eqs + eq :: eqs end else eqs in @@ -2175,86 +2175,86 @@ class poly_interval_array_t v2const poly_vs = method get_call (jproc_info:JCHProcInfo.jproc_info_t) (invoked_vars:variable_t list):'a = - + if !dbg then - pr__debug [STR "get_call "; pp_list invoked_vars; NL] ; - - let call_var_to_index = ref [] in + pr__debug [STR "get_call "; pp_list invoked_vars; NL]; + + let call_var_to_index = ref [] in let repeat_to_index = ref [] in - let rec add_var i vars = - match vars with - | var :: rest_vars -> - if List.mem_assoc var !call_var_to_index then + let rec add_var i vars = + match vars with + | var :: rest_vars -> + if List.mem_assoc var !call_var_to_index then begin - let j = + let j = try List.assoc var !call_var_to_index with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "Call var not found for " ; var#toPretty ; + (LBLOCK [ STR "Call var not found for "; var#toPretty; STR " in JCHPolyIntervalArray.get_call" ])) in - repeat_to_index := (i, j) :: !repeat_to_index + repeat_to_index := (i, j) :: !repeat_to_index end - else - begin - call_var_to_index := (var, i) :: !call_var_to_index - end ; + else + begin + call_var_to_index := (var, i) :: !call_var_to_index + end; add_var (succ i) rest_vars | _ -> () in - add_var 0 invoked_vars ; - - let call_var_to_index = List.rev !call_var_to_index in - let unique_vars = List.map fst call_var_to_index in + add_var 0 invoked_vars; + + let call_var_to_index = List.rev !call_var_to_index in + let unique_vars = List.map fst call_var_to_index in let repeats = List.length !repeat_to_index in - (* CHANGE : Does not work with array lengths *) - let (call_poly, call_interval_array, call_extra_infos) = + (* CHANGE : Does not work with array lengths *) + let (call_poly, call_interval_array, call_extra_infos) = let restr_dom = self#restrict_to_vars jproc_info unique_vars in let new_vars = restr_dom#get_poly_vars in let p = restr_dom#get_poly in let i_array = restr_dom#get_interval_array in let call_extra_infos = restr_dom#get_extra_infos in let mk_const_constr int_array constrs var = (* add constant value constraints *) - if self#is_const var then + if self#is_const var then begin - let i = + let i = try List.assoc var call_var_to_index with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "Call var index not found for " ; var#toPretty ; + (JCH_failure + (LBLOCK [ STR "Call var index not found for "; var#toPretty; STR " in JCHPolyIntervalArray.get_call" ])) in - let big_int_const = self#get_const_val var in - int_array#set i (mkSingletonInterval (new numerical_t big_int_const)) ; - + let big_int_const = self#get_const_val var in + int_array#set i (mkSingletonInterval (new numerical_t big_int_const)); + let constr = new linear_constraint_t true [(i, unit_big_int)] (minus_big_int big_int_const) in - constr :: constrs + constr :: constrs end else constrs in let number_invoked_vars = List.length invoked_vars in - if repeats > 0 then + if repeats > 0 then let map = ref [] in - let rec add_to_map i i_pos repeat_pos = + let rec add_to_map i i_pos repeat_pos = if i_pos = number_invoked_vars then - () + () else if List.mem_assoc i_pos !repeat_to_index then (* In this case we have to add equalities for the repeats *) begin - map := (repeat_pos, i_pos) :: !map ; (* A position at the end -> current pos *) + map := (repeat_pos, i_pos) :: !map; (* A position at the end -> current pos *) add_to_map i (succ i_pos) (succ repeat_pos) end - else + else begin - map := (i, i_pos) :: !map ; + map := (i, i_pos) :: !map; add_to_map (succ i) (succ i_pos) repeat_pos end in - add_to_map 0 0 (List.length new_vars) ; + add_to_map 0 0 (List.length new_vars); let big_poly = p#remap_indices !map in let big_array = @@ -2270,14 +2270,14 @@ class poly_interval_array_t v2const poly_vs = let constrs = List.map mk_eq_constr !repeat_to_index in let constrs = List.fold_left (mk_const_constr big_array) constrs new_vars in (* unique_vars *) - (big_poly#add_constraints constrs, big_array, call_extra_infos) - else + (big_poly#add_constraints constrs, big_array, call_extra_infos) + else let constrs = List.fold_left (mk_const_constr i_array) [] new_vars in (p#add_constraints constrs, i_array, call_extra_infos) in - let call_poly_int_array = self#mk_top [] invoked_vars in + let call_poly_int_array = self#mk_top [] invoked_vars in let call_poly_int_array = call_poly_int_array#set_poly call_poly in let call_poly_int_array = call_poly_int_array#set_interval_array call_interval_array in - call_poly_int_array#set_extra_infos call_extra_infos + call_poly_int_array#set_extra_infos call_extra_infos method meet_invoked (a:'a) @@ -2288,101 +2288,104 @@ class poly_interval_array_t v2const poly_vs = (target_lengths:variable_t list) (num_wvars:variable_t list) (coll_rvars:variable_t list):'a = - + if !dbg then pr__debug [STR "meet_invoked "; pp_list_int cols_to_eliminate; - STR " "; INT arg_length; STR " "; + STR " "; INT arg_length; STR " "; pp_list invoked_vars; STR " "; pp_list invoked_lengths; STR " "; pp_list target_lengths; STR " "; pp_list num_wvars; STR " "; pp_list coll_rvars; NL; - a#toPretty; NL; self#toPretty; NL] ; - + a#toPretty; NL; self#toPretty; NL]; + let all_invoked_vars = invoked_vars @ target_lengths in let ainterval_array = a#get_interval_array in let constrs = a#get_poly#get_constraints in let constr_red = ref [] in - let add_constr constr = + let add_constr constr = if not constr#is_0_geq_0 then constr_red := constr :: !constr_red in - List.iter add_constr constrs ; + List.iter add_constr constrs; let apoly = mk_poly_from_constraints false !constr_red in - let red_poly = apoly#project_out_and_remove cols_to_eliminate in - let red_int_array = ainterval_array#remove_entries arg_length cols_to_eliminate in - let (eliminated_var_to_index, red_var_to_index) = - List.partition (fun (_, c) -> List.mem c cols_to_eliminate) a#get_var_to_index in - let (eliminated_vars, kept_vars) = + let red_poly = apoly#project_out_and_remove cols_to_eliminate in + let red_int_array = + ainterval_array#remove_entries arg_length cols_to_eliminate in + let (eliminated_var_to_index, _red_var_to_index) = + List.partition (fun (_, c) -> + List.mem c cols_to_eliminate) a#get_var_to_index in + let (eliminated_vars, kept_vars) = List.partition (fun v -> List.exists (fun (i, _) -> i = v#getIndex) eliminated_var_to_index) a#get_poly_vars in - + let red_extra_infos = a#get_extra_infos#remove_vars eliminated_vars in - + (* Add constant constraints and remove the constant unused indices *) - let (changed_vars, changed_poly, changed_int_array) = + let (changed_vars, changed_poly, changed_int_array) = if red_poly#is_bottom then (all_invoked_vars, red_poly, red_int_array) - else - let mk_constr i c = - new linear_constraint_t true [(i, unit_big_int)] (minus_big_int c#getNum) in - let rec get_const_constrs (new_vs, const_cols, constrs) i vs = - match vs with - | v :: rest_vs -> + else + let mk_constr i c = + new linear_constraint_t + true [(i, unit_big_int)] (minus_big_int c#getNum) in + let rec get_const_constrs (new_vs, const_cols, constrs) i vs = + match vs with + | v :: rest_vs -> begin - if self#is_const v then + if self#is_const v then let c = self#get_const_val_n v in get_const_constrs (new_vs, i :: const_cols, (mk_constr i c) :: constrs) (succ i) rest_vs else get_const_constrs (v :: new_vs, const_cols, constrs) (succ i) rest_vs end - | _ -> (List.rev new_vs, const_cols, constrs) in + | _ -> (List.rev new_vs, const_cols, constrs) in let (new_vars, is, constrs) = get_const_constrs ([], [], []) 0 all_invoked_vars in - let new_poly = + let new_poly = if red_poly#is_top then red_poly - else + else let poly' = if constrs = [] then red_poly else red_poly#add_constraints constrs in - poly'#project_out_and_remove is in + poly'#project_out_and_remove is in let new_int_array = red_int_array#remove_entries (List.length all_invoked_vars) is in (new_vars, new_poly, new_int_array) in - (* add variables and reorder to get the same variables as in the callee poly *) - let (invoked_poly, invoked_interval_array, invoked_extra_infos) = + (* add variables and reorder to get the same variables as in the callee poly *) + let (invoked_poly, invoked_interval_array, invoked_extra_infos) = if changed_poly#is_bottom then (changed_poly, changed_int_array, red_extra_infos) else begin let changed_var_to_index = mk_var_to_index changed_vars in - let old_col_to_new_col = - List.map (fun (index, old_col) -> + let old_col_to_new_col = + List.map (fun (index, old_col) -> try (old_col, List.assoc index var_to_index) with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "variable not found for " ; INT index ; + (JCH_failure + (LBLOCK [ STR "variable not found for "; INT index; STR " in JCHPolyIntervalArray.meet_invoked" ])) - ) changed_var_to_index in + ) changed_var_to_index in - let new_poly = + let new_poly = if changed_poly#is_top || changed_poly#is_bottom then changed_poly - else + else begin - let constrs = changed_poly#get_constraints in + let constrs = changed_poly#get_constraints in let new_constrs = List.map (fun c -> c#remap old_col_to_new_col) constrs in - mk_poly_from_constraints true new_constrs + mk_poly_from_constraints true new_constrs end in let new_int_array = interval_array#make_bottom_intervals self#get_dim in let add_pair (old_ind, new_ind) = new_int_array#set new_ind (changed_int_array#get old_ind) in - List.iter add_pair old_col_to_new_col ; + List.iter add_pair old_col_to_new_col; let new_extra_infos = - (* called variable has length vars that the caller does not have *) - if List.length kept_vars = List.length all_invoked_vars then + (* called variable has length vars that the caller does not have *) + if List.length kept_vars = List.length all_invoked_vars then begin let old_v_to_new_v = List.combine kept_vars all_invoked_vars in let old_ind_to_new_var = List.map (fun (old_v, new_v) -> (old_v#getIndex, new_v)) old_v_to_new_v in - red_extra_infos#replace_vars old_v_to_new_v old_ind_to_new_var + red_extra_infos#replace_vars old_v_to_new_v old_ind_to_new_var end else new numeric_info_t in @@ -2390,11 +2393,11 @@ class poly_interval_array_t v2const poly_vs = end in if invoked_poly#is_bottom then - self#mk_bottom - else + self#mk_bottom + else begin let top_poly_int_array = self#mk_top var_to_const poly_vars in - let invoked_poly_int_array = + let invoked_poly_int_array = let pia = if params#use_intervals then top_poly_int_array @@ -2408,58 +2411,58 @@ class poly_interval_array_t v2const poly_vs = invoked_poly_int_array#get_extra_infos#add_changed_sym_params changed_vars in let invoked_poly_int_array = invoked_poly_int_array#set_extra_infos invoked_extra_infos in - let proc_poly_int_array = self#project_out (num_wvars @ target_lengths) in + let proc_poly_int_array = self#project_out (num_wvars @ target_lengths) in proc_poly_int_array#meet' invoked_poly_int_array coll_rvars end (* It returns a poly for the new_vars * The variables in poly that are not in the new_vars are projected away * For the constant variables in new_vars, constant constraints are added - * All the other variables have a column in the constructed poly but no constraints *) + * All the other variables have a column in the constructed poly but no constraints *) method restrict_to_vars (jproc_info:JCHProcInfo.jproc_info_t) (new_vars:variable_t list) = - + if !dbg then - pr__debug [STR "restrict_to_vars "; pp_list new_vars ; NL; self#toPretty; NL] ; - + pr__debug [STR "restrict_to_vars "; pp_list new_vars; NL; self#toPretty; NL]; + if poly#is_bottom then - {< >} - else + {< >} + else let (new_poly_vars, other_vars) = List.partition (fun v -> List.mem v poly_vars) new_vars in let (vars_that_stay, vars_to_remove) = List.partition (fun v -> List.mem v new_poly_vars) poly_vars in let inds_to_remove = List.map self#get_index vars_to_remove in let new_var_to_index = mk_var_to_index new_vars in - + let mk_index_map (next, map) v = (succ next, (v, next) :: map) in let (_, red_poly_map) = - List.fold_left mk_index_map (0, []) (vars_that_stay @ other_vars) in + List.fold_left mk_index_map (0, []) (vars_that_stay @ other_vars) in let (_, new_poly_map) = List.fold_left mk_index_map (0, []) new_vars in - let mk_map_pair v = + let mk_map_pair v = try (List.assoc v red_poly_map, List.assoc v new_poly_map) with | Not_found -> - raise (JCH_failure - (LBLOCK [ STR "poly map not found for " ; v#toPretty ; + raise (JCH_failure + (LBLOCK [ STR "poly map not found for "; v#toPretty; STR " in JCHPolyIntervalArray.restrict_to_vars" ])) in let map = List.map mk_map_pair new_vars in - let red_poly = + let red_poly = if poly#is_top then poly - else + else begin let rp1 = poly#project_out_and_remove inds_to_remove in - rp1#remap_indices map + rp1#remap_indices map end in let new_dim = List.length new_vars in let red_interval_array1 = - interval_array#remove_entries self#get_dim (List.rev inds_to_remove) in + interval_array#remove_entries self#get_dim (List.rev inds_to_remove) in let dim1 = self#get_dim - List.length inds_to_remove in let red_interval_array2 = - red_interval_array1#augment dim1 new_dim topInterval in + red_interval_array1#augment dim1 new_dim topInterval in let red_interval_array = red_interval_array2#remap new_dim map in let red_interval_array = red_interval_array#set_type_intervals jproc_info new_vars in @@ -2474,71 +2477,71 @@ class poly_interval_array_t v2const poly_vs = let red_extra_infos = extra_infos#change_vars new_vars in let new_poly = red_poly#add_constraints constrs in - {< poly = new_poly ; - poly_vars = new_vars ; - var_to_index = new_var_to_index ; - interval_array = red_interval_array ; + {< poly = new_poly; + poly_vars = new_vars; + var_to_index = new_var_to_index; + interval_array = red_interval_array; extra_infos = red_extra_infos >} (* It returns a poly for the new_vars - * The variables in poly that are not in the new_vars are projected + * The variables in poly that are not in the new_vars are projected * away and removed *) method restrict_to_vars_2 (new_vars: variable_t list) = let new_vars = List.map (fun v -> List.find (fun v' -> v'#getName#equal v#getName) poly_vars) new_vars in - + if !dbg then - pr__debug [STR "restrict_to_vars_2 "; pp_list new_vars ; NL; self#toPretty; NL] ; - + pr__debug [STR "restrict_to_vars_2 "; pp_list new_vars; NL; self#toPretty; NL]; + if poly#is_bottom then - {< >} + {< >} else let (new_poly_vars, other_vars) = - List.partition (fun v -> List.mem v poly_vars) new_vars in + List.partition (fun v -> List.mem v poly_vars) new_vars in let (vars_that_stay, vars_to_remove) = - List.partition (fun v -> List.mem v new_poly_vars) poly_vars in + List.partition (fun v -> List.mem v new_poly_vars) poly_vars in let inds_to_remove = List.map self#get_index vars_to_remove in let new_var_to_index = mk_var_to_index new_vars in - + let mk_index_map (next, map) v = (succ next, (v, next) :: map) in let (_, red_poly_map) = - List.fold_left mk_index_map (0, []) (vars_that_stay @ other_vars) in + List.fold_left mk_index_map (0, []) (vars_that_stay @ other_vars) in let (_, new_poly_map) = List.fold_left mk_index_map (0, []) new_vars in - let mk_map_pair v = + let mk_map_pair v = try (List.assoc v red_poly_map, List.assoc v new_poly_map) with | Not_found -> - raise (JCH_failure - (LBLOCK [ STR "poly map not found for " ; v#toPretty ; + raise (JCH_failure + (LBLOCK [ STR "poly map not found for "; v#toPretty; STR " in JCHPolyIntervalArray.restrict_to_vars" ])) in let map = List.map mk_map_pair new_vars in - let red_poly = + let red_poly = if poly#is_top then poly - else + else begin let rp1 = poly#project_out_and_remove inds_to_remove in - rp1#remap_indices map + rp1#remap_indices map end in let red_interval_array = - interval_array#remove_entries self#get_dim (List.rev inds_to_remove) in + interval_array#remove_entries self#get_dim (List.rev inds_to_remove) in let red_extra_infos = extra_infos#change_vars new_vars in - {< poly = red_poly ; - poly_vars = new_vars ; - var_to_index = new_var_to_index ; - interval_array = red_interval_array ; + {< poly = red_poly; + poly_vars = new_vars; + var_to_index = new_var_to_index; + interval_array = red_interval_array; extra_infos = red_extra_infos >} method check_type (var:variable_t) = - + if !dbg then - pr__debug [STR "check_type "; var#toPretty; NL] ; - + pr__debug [STR "check_type "; var#toPretty; NL]; + let index = self#get_index var in let interval = self#get_best_interval index in let tinterval = interval_array#get_type_interval (self#get_index var) in @@ -2552,121 +2555,121 @@ class poly_interval_array_t v2const poly_vs = (dst:variable_t) (src_interval:interval_t) (src_excluded_vals:numerical_t list):'a = - + if !dbg then pr__debug [STR "copy_info "; dst#toPretty; STR " "; - src_interval#toPretty; NL; self#toPretty; NL] ; - + src_interval#toPretty; NL; self#toPretty; NL]; + let new_interval_array = interval_array#copy in - new_interval_array#set (self#get_index dst) src_interval ; - + new_interval_array#set (self#get_index dst) src_interval; + let new_extra_infos = extra_infos#set_excluded_vals dst src_excluded_vals in - {< interval_array = new_interval_array ; - extra_infos = new_extra_infos >} + {< interval_array = new_interval_array; + extra_infos = new_extra_infos >} method restrict_to_type (vars:variable_t list):'a = - - if !dbg then pr__debug [STR "restrict_to_type "; pp_list vars ; NL] ; - + + if !dbg then pr__debug [STR "restrict_to_type "; pp_list vars; NL]; + if self#is_bottom then - {< >} + {< >} else {< interval_array = - interval_array#restrict_to_type (List.map self#get_index vars) >} + interval_array#restrict_to_type (List.map self#get_index vars) >} - method private get_join_excluded (var1:variable_t) (var2:variable_t) = + method private get_join_excluded (var1:variable_t) (var2:variable_t) = let interval1 = interval_array#get (self#get_index var1) in let interval2 = interval_array#get (self#get_index var2) in let excluded1 = extra_infos#get_excluded_vals var1 in let excluded2 = extra_infos#get_excluded_vals var2 in - let common_excluded = + let common_excluded = List.filter (fun vl -> List.exists vl#equal excluded2) excluded1 in let new_set = NumericalCollections.set_of_list common_excluded in - let add_val other_interval vl = + let add_val other_interval vl = if not (other_interval#contains vl) then new_set#add vl in - List.iter (add_val interval2) excluded1 ; - List.iter (add_val interval1) excluded2 ; + List.iter (add_val interval2) excluded1; + List.iter (add_val interval1) excluded2; new_set#toList - method add_empty_collection (var:variable_t):'a = + method add_empty_collection (var:variable_t):'a = {< extra_infos = extra_infos#add_empty_collection var >} method set_join (dst:variable_t) (src1:variable_t) (src2:variable_t):'a = - + if !dbg then - pr__debug [STR "set_join "; dst#toPretty ; STR " = "; - src1#toPretty; STR " U "; src2#toPretty; NL] ; - - let new_interval_array = interval_array#copy in - let dst_index = self#get_index dst in - let src1_int = - if self#is_const src1 then + pr__debug [STR "set_join "; dst#toPretty; STR " = "; + src1#toPretty; STR " U "; src2#toPretty; NL]; + + let new_interval_array = interval_array#copy in + let dst_index = self#get_index dst in + let src1_int = + if self#is_const src1 then let const = self#get_const_val_n src1 in - mkSingletonInterval const - else + mkSingletonInterval const + else let src1_index = self#get_index src1 in self#get_best_interval src1_index in - let src2_int = - if self#is_const src2 then + let src2_int = + if self#is_const src2 then let const = self#get_const_val_n src2 in - mkSingletonInterval const - else + mkSingletonInterval const + else let src2_index = self#get_index src2 in self#get_best_interval src2_index in - let jint = + let jint = if extra_infos#is_empty_collection src1 then src2_int else if extra_infos#is_empty_collection src2 then src1_int else src1_int#join src2_int in - let new_interval = + let new_interval = let ctp_int = interval_array#get_type_interval dst_index in jint#meet ctp_int in - new_interval_array#set dst_index new_interval ; + new_interval_array#set dst_index new_interval; - let new_extra_infos = - if self#is_const src1 then + let new_extra_infos = + if self#is_const src1 then if self#is_const src2 then - extra_infos - else + extra_infos + else let new_excluded = extra_infos#get_excluded_vals src2 in - extra_infos#set_excluded_vals dst new_excluded - else if self#is_const src2 then + extra_infos#set_excluded_vals dst new_excluded + else if self#is_const src2 then let new_excluded = extra_infos#get_excluded_vals src1 in - extra_infos#set_excluded_vals dst new_excluded - else + extra_infos#set_excluded_vals dst new_excluded + else let new_excluded = self#get_join_excluded src1 src2 in extra_infos#set_excluded_vals dst new_excluded in - {< interval_array = new_interval_array; + {< interval_array = new_interval_array; extra_infos = new_extra_infos >} - (* values of collections are always in intervals. However, + (* values of collections are always in intervals. However, if two variables point to the same object, then they are equal in poly *) method add_val_to_collection (is_empty_collection:bool) (coll_var:variable_t) (val_var:variable_t) - (coll_interval: interval_t):'a = + (coll_interval: interval_t):'a = let _ = if !dbg then pr__debug [STR "add_val_to_collection "; - (if is_empty_collection then STR " empty collection " else STR "") ; + (if is_empty_collection then STR " empty collection " else STR ""); coll_var#toPretty; STR " "; val_var#toPretty; STR " "; coll_interval#toPretty; NL; self#toPretty; NL] in - + let new_extra_infos = extra_infos#remove_empty_collection coll_var in - let new_interval_array = interval_array#copy in - let coll_index = self#get_index coll_var in - let (val_interval, new_extra_infos) = - if self#is_const val_var then + let new_interval_array = interval_array#copy in + let coll_index = self#get_index coll_var in + let (val_interval, new_extra_infos) = + if self#is_const val_var then let const = self#get_const_val_n val_var in let int = mkSingletonInterval const in (int, new_extra_infos#remove_excluded_val coll_var (self#get_const_val_n val_var)) - else + else let val_index = self#get_index val_var in let val_int = self#get_best_interval val_index in let new_excluded = self#get_join_excluded coll_var val_var in @@ -2678,8 +2681,8 @@ class poly_interval_array_t v2const poly_vs = new_interval_array#set coll_index val_interval (* first element of the collection *) else let join_interval = coll_interval#join val_interval in - new_interval_array#set coll_index join_interval) ; - {< interval_array = new_interval_array; + new_interval_array#set coll_index join_interval); + {< interval_array = new_interval_array; extra_infos = new_extra_infos >} end @@ -2688,96 +2691,96 @@ class poly_interval_array_t v2const poly_vs = (jproc_info: JCHProcInfo.jproc_info_t) (field_info: JCHPreAPI.field_info_int) (intervals: interval_t list) var = - + if !dbg then - pr__debug [STR "get_field "; var#toPretty; NL; pp_list intervals; NL] ; - + pr__debug [STR "get_field "; var#toPretty; NL; pp_list intervals; NL]; + let index = self#get_index var in - let new_interval_array = - match intervals with - | [interval] -> + let new_interval_array = + match intervals with + | [interval] -> begin let interval_array' = interval_array#copy_set_typed index interval in try (* If var is an array but the field is not known to be an array. Is that possible ? *) let length_var = Option.get (jproc_info#get_length var) in interval_array'#copy_set_typed - (self#get_index length_var) (JCHTypeUtils.length_interval) + (self#get_index length_var) (JCHTypeUtils.length_interval) with _ -> interval_array' end - | interval :: length_interval :: _ -> + | interval :: length_interval :: _ -> begin let interval_array' = interval_array#copy_set_typed index interval in try let length_var = Option.get (jproc_info#get_length var) in - interval_array'#copy_set_typed (self#get_index length_var) length_interval + interval_array'#copy_set_typed (self#get_index length_var) length_interval with _ -> interval_array' end | _ -> begin pr__debug [STR "Analysis failed: "; - STR "JCHPolyIntervalArray.get_field expected intervals <> [] "; NL] ; + STR "JCHPolyIntervalArray.get_field expected intervals <> [] "; NL]; raise (JCHAnalysisUtils.numeric_params#analysis_failed 3 "JCHPolyIntervalArray.get_field expected intervals <> [] ") end in - {< interval_array = new_interval_array ; + {< interval_array = new_interval_array; extra_infos = extra_infos#set_fields var [field_info] >} method new_array (array:variable_t) (dims:variable_t list):'a = - + if !dbg then - pr__debug [STR "new_array "; array#toPretty; STR " "; pp_list dims; NL] ; - + pr__debug [STR "new_array "; array#toPretty; STR " "; pp_list dims; NL]; + let index = self#get_index array in let new_interval_array = interval_array#copy_set index (mkSingletonInterval numerical_zero) in - let add_dim_interval dim = - let interval = self#get_interval dim in + let add_dim_interval dim = + let interval = self#get_interval dim in let new_interval = interval#meet JCHTypeUtils.length_interval in - if not (self#is_const dim) then + if not (self#is_const dim) then new_interval_array#set (self#get_index dim) new_interval in begin - List.iter add_dim_interval dims ; + List.iter add_dim_interval dims; {< interval_array = new_interval_array >} end - - method array_load (array:variable_t) (element:variable_t):'a = + + method array_load (array:variable_t) (element:variable_t):'a = let acol = self#get_index array in - let ecol = self#get_index element in + let ecol = self#get_index element in let a_int = self#get_best_interval acol in let new_interval_array = interval_array#copy_set_typed ecol a_int in if params#use_intervals then {< poly = top_poly; interval_array = new_interval_array >} - else + else let new_poly = poly#copy_other_col_constrs acol ecol in {< poly = new_poly; interval_array = new_interval_array >} method down_cast_float (src:variable_t) (dst:variable_t):('a * bool) = - + if !dbg then - pr__debug [STR "down_cast "; src#toPretty; STR " "; dst#toPretty; NL] ; - + pr__debug [STR "down_cast "; src#toPretty; STR " "; dst#toPretty; NL]; + let src_index = self#get_index src in let interval = self#get_best_interval src_index in let dst_index = self#get_index dst in let tinterval = interval_array#get_type_interval dst_index in - if interval#leq tinterval then + if interval#leq tinterval then let mx = interval#getMax in let mn = interval#getMin in - let (max, min) = + let (max, min) = let excluded_vals = extra_infos#get_excluded_vals src in - let max = - match mx#getBound with - | NUMBER num -> + let max = + match mx#getBound with + | NUMBER num -> if num#gt numerical_zero && List.exists num#equal excluded_vals then mx#sub one_bound else mx | _ -> mx in - let min = - match mn#getBound with - | NUMBER num -> + let min = + match mn#getBound with + | NUMBER num -> if num#lt numerical_zero && List.exists num#equal excluded_vals then mn#add one_bound @@ -2791,37 +2794,37 @@ class poly_interval_array_t v2const poly_vs = else (self#project_out [dst], true) - method float_const (dst1:variable_t) (f:float):'a = + method float_const (dst1:variable_t) (f:float):'a = let dst1_index = self#get_index dst1 in try (* for the case when f is not a number *) let dst1_ind = self#get_index dst1 in let (min, max, interval) = JCHAnalysisUtils.float_to_interval f in let new_interval_array = interval_array#copy_set dst1_index interval in - let new_extra_infos = + let new_extra_infos = if min#equal max then extra_infos else extra_infos#set_excluded_vals dst1 [min; max] in - if params#use_intervals then - {< poly = top_poly; - interval_array = new_interval_array ; + if params#use_intervals then + {< poly = top_poly; + interval_array = new_interval_array; extra_infos = new_extra_infos >} else let constrs = mk_constraints_from_interval false dst1_ind interval in - {< poly = poly#add_constraints constrs ; - interval_array = new_interval_array ; + {< poly = poly#add_constraints constrs; + interval_array = new_interval_array; extra_infos = new_extra_infos >} - with _ -> self#project_out [dst1] + with _ -> self#project_out [dst1] (* This is used for stubs * It eliminates the constraints that derive from the intervals for arguments *) method simplify_with_intervals = - + if !dbg then - pr__debug [STR "simplify_with_intervals "; NL; self#toPretty; NL] ; - + pr__debug [STR "simplify_with_intervals "; NL; self#toPretty; NL]; + let (returns, params) = List.partition (fun v -> JCHSystemUtils.is_return v) poly_vars in let vars' = params @ returns in @@ -2834,45 +2837,45 @@ class poly_interval_array_t v2const poly_vs = let remap_interval_array = interval_array#remap dim map in let (restr_poly, restr_interval_array) = move_simple_ineqs_to_intervals reordered_poly remap_interval_array in - - let inv_map = + + let inv_map = List.map (fun v -> (List.assoc v#getIndex var_to_index', self#get_index v)) poly_vars in let restr_poly' = restr_poly#remap_indices inv_map in let restr_interval_array' = restr_interval_array#remap dim inv_map in - + {< poly = restr_poly'; interval_array = restr_interval_array' >} (* CHANGE: It does not deal with array lengths *) - method to_postconditions2 (jproc_info: JCHProcInfo.jproc_info_t) = + method to_postconditions2 (jproc_info: JCHProcInfo.jproc_info_t) = let vars = List.filter (fun v -> not (JCHSystemUtils.is_exception v)) poly_vars in (* map from variable index to parameter_index *) - let map = - let get_pair v = + let map = + let get_pair v = let info = jproc_info#get_jvar_info v in - let param_index = + let param_index = match info#get_param_index with | Some i -> i - | _ -> -1 in - (self#get_index v, param_index) in + | _ -> -1 in + (self#get_index v, param_index) in List.map get_pair vars in - (* Add predicates for poly *) - let post_preds = + (* Add predicates for poly *) + let post_preds = if poly#is_bottom then [] - else - begin + else + begin let constrs = List.filter (fun c -> - not c#is_const_equality) poly#get_constraints in - let add_cond post constr = - try (* For the case when in the transformed chif, - there is a local variable variant which corresponds to a + not c#is_const_equality) poly#get_constraints in + let add_cond post constr = + try (* For the case when in the transformed chif, + there is a local variable variant which corresponds to a value that was not stored yet, ... *) - (constr#to_post_predicate map [] [] [] []) :: post + (constr#to_post_predicate map [] [] [] []) :: post with _ -> post in List.fold_left add_cond [] constrs end in @@ -2880,12 +2883,12 @@ class poly_interval_array_t v2const poly_vs = (* Add predicates for the intervals. * Parameter intervals that are max intervals are not added. *) let post_preds = - let add_pred post var = + let add_pred post var = let var_index = self#get_index var in let interval = interval_array#get var_index in let arg_index = List.assoc var_index map in (* if the variable is return then make a predicate *) - if not (interval#equal topInterval) && (JCHSystemUtils.is_number var) then + if not (interval#equal topInterval) && (JCHSystemUtils.is_number var) then begin (interval_to_summary_post_predicates2 ~is_loc:true @@ -2902,21 +2905,21 @@ class poly_interval_array_t v2const poly_vs = (* Add predicates for the excluded values *) let post_preds = - let add_pred post var = + let add_pred post var = let excluded = extra_infos#get_excluded_vals var in - let arg_index = + let arg_index = try - List.assoc (self#get_index var) map + List.assoc (self#get_index var) map with | Not_found -> raise - (JCH_failure - (LBLOCK [ STR "argument index not found for " ; - INT (self#get_index var) ; + (JCH_failure + (LBLOCK [ STR "argument index not found for "; + INT (self#get_index var); STR " in JCHPolyIntervalArray.to_postconditions2" ])) in if excluded = [] then post_preds - else if JCHSystemUtils.is_number var then + else if JCHSystemUtils.is_number var then (excluded_vals_to_summary_post_predicates arg_index excluded) @ post else post in @@ -2924,96 +2927,96 @@ class poly_interval_array_t v2const poly_vs = post_preds - (* This is to be used for a poly_interval_array reduced to the + (* This is to be used for a poly_interval_array reduced to the * local vars and return *) method to_postconditions (include_loop_counters:bool) (jproc_info:JCHProcInfo.jproc_info_t) (local_var_map:(variable_t * variable_t) list) - (aux_vars:variable_t list) = + (aux_vars:variable_t list) = let local_vars = List.filter (fun v -> List.mem v poly_vars) (List.map snd local_var_map) in - let (rev_local_var_map, equal_orig_vars) = + let (rev_local_var_map, equal_orig_vars) = let m : VariableCollections.set_t VariableCollections.table_t = new VariableCollections.table_t in - let add_pair (orig_var, var) = - match m#get var with + let add_pair (orig_var, var) = + match m#get var with | Some set -> set#add orig_var | _ -> m#set var (VariableCollections.set_of_list [orig_var]) in - List.iter add_pair local_var_map ; + List.iter add_pair local_var_map; let eq_orig_vars = ref [] in let ls = ref [] in let add_equal_orig_vars - (var: variable_t) (orig_vars: VariableCollections.set_t) = - match orig_vars#toList with + (var: variable_t) (orig_vars: VariableCollections.set_t) = + match orig_vars#toList with | [orig_var] -> ls := (var#getIndex, orig_var) :: !ls - | orig_var :: rest_orig_vars -> + | orig_var :: rest_orig_vars -> let is_argument orig_v = List.mem orig_v poly_vars in - let orig_arg = + let orig_arg = try List.find is_argument (orig_var :: rest_orig_vars) with _ -> orig_var in begin - ls := (var#getIndex, orig_var) :: !ls ; - orig_vars#remove orig_arg ; + ls := (var#getIndex, orig_var) :: !ls; + orig_vars#remove orig_arg; eq_orig_vars := (orig_arg :: (orig_vars#toList)) :: !eq_orig_vars end | _ -> () in begin - m#iter add_equal_orig_vars ; + m#iter add_equal_orig_vars; (!ls, !eq_orig_vars) end in - - let length_vars = + + let length_vars = let length_vars = ref [] in - let add_length_var var = - match jproc_info#get_length var with - | Some length_var -> + let add_length_var var = + match jproc_info#get_length var with + | Some length_var -> if List.mem length_var poly_vars then - length_vars := length_var :: !length_vars + length_vars := length_var :: !length_vars | _ -> () in - List.iter add_length_var local_vars ; + List.iter add_length_var local_vars; !length_vars in - + let vars = local_vars @ length_vars in - let (lc_vars, lc_map) = - if include_loop_counters then + let (lc_vars, lc_map) = + if include_loop_counters then begin - let add_wto (vars, pairs) w = - try - let lc = w#get_var in + let add_wto (vars, pairs) w = + try + let lc = w#get_var in (lc::vars, (self#get_index lc, w#get_first_pc) :: pairs) with _ -> (vars, pairs) in - List.fold_left add_wto ([], []) jproc_info#get_wto_infos + List.fold_left add_wto ([], []) jproc_info#get_wto_infos end else ([], []) in (* local var index of an original variable *) - let get_orig_local_var_index orig_var = + let get_orig_local_var_index orig_var = let name = orig_var#getName#getBaseName in - if name.[0] = 'r' && name.[1] <> 'e' then + if name.[0] = 'r' && name.[1] <> 'e' then int_of_string (Str.string_after name 1) else -1 in - + (* map from variable index in the poly to original local var index *) - let map = - let get_pair v = + let map = + let get_pair v = let orig_var = List.assoc v#getIndex rev_local_var_map in let local_var_index = get_orig_local_var_index orig_var in (self#get_index v, local_var_index) in List.map get_pair local_vars in (* map from length var index to the array local var index *) - let length_map = - let get_pair v = + let length_map = + let get_pair v = let var = Option.get (jproc_info#get_variable_from_length v) in let orig_var = List.assoc var#getIndex rev_local_var_map in - let local_var_index = + let local_var_index = let name = orig_var#getName#getBaseName in - if name.[0] = 'r' && name.[1] <> 'e' then + if name.[0] = 'r' && name.[1] <> 'e' then int_of_string (Str.string_after name 1) else -1 in @@ -3021,74 +3024,74 @@ class poly_interval_array_t v2const poly_vs = List.map get_pair length_vars in let aux_map = - let get_pair v = + let get_pair v = (self#get_index v, "aux_" ^ (string_of_int v#getIndex)) in List.map get_pair aux_vars in let aux_length_vars = let length_vars = ref [] in - let add_length_var var = - match jproc_info#get_length var with - | Some length_var -> + let add_length_var var = + match jproc_info#get_length var with + | Some length_var -> if List.mem length_var poly_vars then - length_vars := length_var :: !length_vars + length_vars := length_var :: !length_vars | _ -> () in begin - List.iter add_length_var aux_vars ; + List.iter add_length_var aux_vars; !length_vars end in - + let aux_length_map = let get_pair v = let var = Option.get (jproc_info#get_variable_from_length v) in (self#get_index v, "aux_" ^ (string_of_int var#getIndex)) in - List.map get_pair aux_length_vars in - + List.map get_pair aux_length_vars in + (* Add predicates for the local variables that are equal *) - let post_preds = + let post_preds = let pps = ref [] in - let add_eqs orig_vars = - match orig_vars with - | orig_var :: rest_orig_vars -> + let add_eqs orig_vars = + match orig_vars with + | orig_var :: rest_orig_vars -> let arg_index = get_orig_local_var_index orig_var in - let add_eq ov = + let add_eq ov = let i = get_orig_local_var_index ov in pps := (equality_to_summary_post_predicate i arg_index) :: !pps in - List.iter add_eq rest_orig_vars + List.iter add_eq rest_orig_vars | _ -> () in begin - List.iter add_eqs equal_orig_vars ; + List.iter add_eqs equal_orig_vars; !pps end in - (* Add predicates for poly *) - let post_preds = + (* Add predicates for poly *) + let post_preds = if poly#is_bottom || params#use_intervals then [] - else - begin - let not_included var = - if include_loop_counters then + else + begin + let not_included var = + if include_loop_counters then not ((List.mem var vars) || (JCHSystemUtils.is_loop_counter var) || (List.mem var aux_vars)) else not ((List.mem var vars) || (List.mem var aux_vars)) in let other_vars = List.filter not_included poly_vars in let constrs = - let restr_constrs = + let restr_constrs = try let restr_poly = (self#project_out other_vars)#get_poly in - restr_poly#get_constraints + restr_poly#get_constraints with (JCHAnalysisUtils.JCH_num_analysis_failure _) -> let cs = poly#get_constraints in let other_inds = List.map self#get_index other_vars in - let does_not_have_other_vars c = + let does_not_have_other_vars c = not (List.exists (fun i -> c#has_index i) other_inds) in List.filter does_not_have_other_vars cs in List.filter (fun c -> not c#is_const_equality) restr_constrs in - let add_cond post constr = - try (* For the case when in the transformed chif, there is a local + let add_cond post constr = + try (* For the case when in the transformed chif, there is a local * variable variant which corresponds to a value that was not * stored yet, ... *) (constr#to_post_predicate @@ -3100,10 +3103,10 @@ class poly_interval_array_t v2const poly_vs = (* Add predicates for the intervals. * Parameter intervals that are max intervals are not added. *) let post_preds = - let add_pred is_loc is_lc is_length is_aux is_aux_length post var = + let add_pred is_loc is_lc is_length is_aux is_aux_length post var = let var_index = self#get_index var in let interval = interval_array#get var_index in - let (arg_index, name) = + let (arg_index, name) = if is_loc then (List.assoc var_index map , "") else if is_lc then @@ -3118,7 +3121,7 @@ class poly_interval_array_t v2const poly_vs = raise (JCHBasicTypes.JCH_failure (STR "expected variable type ")) in if not (interval#equal topInterval) - && (JCHSystemUtils.is_number var) then + && (JCHSystemUtils.is_number var) then begin (interval_to_summary_post_predicates2 ~is_loc @@ -3142,13 +3145,13 @@ class poly_interval_array_t v2const poly_vs = List.fold_left (add_pred false false false false true) pps aux_length_vars in (* Add predicates for the constants *) - let post_preds = - let add_pred post (ind, const) = - try + let post_preds = + let add_pred post (ind, const) = + try let orig_var = List.assoc ind rev_local_var_map in - let local_var_index = + let local_var_index = let name = orig_var#getName#getBaseName in - if name.[0] = 'r' && name.[1] <> 'e' then + if name.[0] = 'r' && name.[1] <> 'e' then int_of_string (Str.string_after name 1) else -1 in let interval = mkSingletonInterval const in @@ -3158,46 +3161,46 @@ class poly_interval_array_t v2const poly_vs = (* Add predicates for the excluded values. Does not deal with excluded values for length vars *) let post_preds = - let add_pred post var = - if not (JCHSystemUtils.is_length var) then + let add_pred post var = + if not (JCHSystemUtils.is_length var) then begin let excluded = extra_infos#get_excluded_vals var in let arg_index = List.assoc (self#get_index var) map in if excluded = [] then post_preds - else if JCHSystemUtils.is_number var then + else if JCHSystemUtils.is_number var then (excluded_vals_to_summary_post_predicates arg_index excluded) @ post else post - end + end else post in List.fold_left add_pred post_preds vars in post_preds - method init_assumptions (jproc_info: JCHProcInfo.jproc_info_t) : 'a = + method init_assumptions (jproc_info: JCHProcInfo.jproc_info_t) : 'a = let name_to_index = ref [] in let index_to_types = ref [] in - let add_var_name var = - let jvar_info = jproc_info#get_jvar_info var in + let add_var_name var = + let jvar_info = jproc_info#get_jvar_info var in let var_index = self#get_index var in - index_to_types := (var_index, jvar_info#get_types) :: !index_to_types ; - if jvar_info#is_parameter then + index_to_types := (var_index, jvar_info#get_types) :: !index_to_types; + if jvar_info#is_parameter then let index = Option.get (jvar_info#get_param_index) in - name_to_index := ("arg" ^ (string_of_int index), var_index) :: !name_to_index - else if jvar_info#is_return then - name_to_index := ("return", var_index) :: !name_to_index - else if JCHSystemUtils.is_length var then + name_to_index := ("arg" ^ (string_of_int index), var_index) :: !name_to_index + else if jvar_info#is_return then + name_to_index := ("return", var_index) :: !name_to_index + else if JCHSystemUtils.is_length var then begin let var_with_l = Option.get (jproc_info#get_variable_from_length var) in let var_with_l_info = jproc_info#get_jvar_info var_with_l in - if var_with_l_info#is_return then - name_to_index := ("length_return", var_index) :: !name_to_index + if var_with_l_info#is_return then + name_to_index := ("length_return", var_index) :: !name_to_index else if var_with_l_info#is_parameter then begin let index = List.hd var_with_l_info#get_local_indices in - name_to_index := ("length_arg" ^ (string_of_int index), var_index) :: !name_to_index + name_to_index := ("length_arg" ^ (string_of_int index), var_index) :: !name_to_index end end in List.iter add_var_name poly_vars; @@ -3211,10 +3214,10 @@ class poly_interval_array_t v2const poly_vs = self#get_best_interval_array new_poly pia#get_interval_array in {< poly = new_poly; interval_array = new_interval_array >} - method remove_duplicates : 'a = + method remove_duplicates : 'a = if self#is_top || self#is_bottom then - {< >} - else + {< >} + else begin let new_poly = poly#remove_duplicates in let (restr_poly, restr_interval_array) = @@ -3223,42 +3226,42 @@ class poly_interval_array_t v2const poly_vs = end method set_type_intervals - (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = + (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = {< interval_array = interval_array#set_type_intervals jproc_info vars >} - + method set_type_intervals_and_restrict - (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = + (jproc_info:JCHProcInfo.jproc_info_t) (vars:variable_t list) = {< interval_array = interval_array#set_type_intervals_and_restrict jproc_info vars >} method add_field (v:variable_t) (fInfo:field_info_int):'a = {< extra_infos = extra_infos#add_field v fInfo >} - + method remove_field (v:variable_t) (fInfo:field_info_int):'a = {< extra_infos = extra_infos#remove_field v fInfo >} - + method set_fields (v:variable_t) (fInfos:field_info_int list):'a = {< extra_infos = extra_infos#set_fields v fInfos >} - + method get_vars_with_fields (jproc_info:JCHProcInfo.jproc_info_t):variable_t list = - let vars = ref [] in + let vars = ref [] in let length_vars = ref [] in let add_var v = if extra_infos#has_fields v then begin - vars := v :: !vars ; + vars := v :: !vars; let jvar_info = jproc_info#get_jvar_info v in match jvar_info#get_length with | (Some len, _) -> length_vars := len :: !length_vars - | _ -> () + | _ -> () end in begin - List.iter add_var poly_vars ; + List.iter add_var poly_vars; List.rev_append !vars !length_vars end - + method transfer_fields (remove:bool) (dst_var:variable_t) (src_var:variable_t):'a = let src_fields = extra_infos#get_fields src_var in @@ -3273,7 +3276,7 @@ class poly_interval_array_t v2const poly_vs = method copy_num_info (dst_var:variable_t) (src_var:variable_t):'a = {< extra_infos = extra_infos#set_same_info dst_var src_var >} - method to_pretty = + method to_pretty = let pp_vars = pretty_print_list poly_vars @@ -3287,7 +3290,7 @@ class poly_interval_array_t v2const poly_vs = STR "var_to_index: "; INDENT (5, pp_assoc_list_ints var_to_index); NL; STR "poly: "; NL; STR "{"; NL; INDENT (5, pp_poly); NL; STR "}"; NL; STR "interval array: "; NL; INDENT (5, pp_ints); NL; - STR "extra_infos: "; NL; INDENT (5, extra_infos#toPretty); NL] + STR "extra_infos: "; NL; INDENT (5, extra_infos#toPretty); NL] method toPretty = self#to_pretty @@ -3306,29 +3309,23 @@ class poly_interval_array_t v2const poly_vs = interval_array#pr__debug_large_interval_array extra_infos " " poly_vars; pr__debug [NL; STR "extra_infos: "; NL; extra_infos#to_pretty_no_excluded poly_vars; NL]; - with _ -> () + with _ -> () end let bottom_poly_interval_array = let p = new poly_interval_array_t [] [] in - p#set_poly bottom_poly + p#set_poly bottom_poly -let top_poly_interval_array v2const poly_vs = - let top_poly_int_array = +let top_poly_interval_array v2const poly_vs = + let top_poly_int_array = new poly_interval_array_t v2const poly_vs in let int_array = make_top_intervals (List.length poly_vs) in - top_poly_int_array#set_interval_array int_array + top_poly_int_array#set_interval_array int_array -let bottom_poly_int_array = +let bottom_poly_int_array = let p = new poly_interval_array_t [] [] in - p#set_poly bottom_poly - -let top_poly_int_array = - new poly_interval_array_t [] [] - - - - - + p#set_poly bottom_poly +let top_poly_int_array = + new poly_interval_array_t [] [] diff --git a/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.mli b/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.mli index 411da157..67b8a437 100644 --- a/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.mli +++ b/CodeHawk/CHJ/jchpoly/jCHPolyIntervalArray.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -40,7 +41,7 @@ open JCHPreAPI val set_local_vars : variable_t list -> unit class poly_interval_array_t : - (int * CHNumerical.numerical_t) list -> + (int * CHNumerical.numerical_t) list -> variable_t list -> object ('a) method add_empty_collection : variable_t -> 'a @@ -50,32 +51,32 @@ class poly_interval_array_t : method add_val_to_collection : bool -> variable_t -> variable_t -> interval_t -> 'a method add_vars : JCHProcInfo.jproc_info_t -> variable_t list -> 'a - + method affine_increment : variable_t -> big_int -> 'a * variable_t option * variable_t option - - method affine_image : + + method affine_image : variable_t option -> variable_t * big_int -> (variable_t * big_int) list -> big_int -> 'a * variable_t option * variable_t option - + method affine_preimage : variable_t * big_int -> (variable_t * big_int) list -> big_int -> 'a - - method affine_subst : + + method affine_subst : variable_t -> variable_t option -> big_int -> big_int -> 'a * variable_t option * variable_t option - + method array_load : variable_t -> variable_t -> 'a method assert_eq : variable_t -> variable_t -> 'a method assert_geq : variable_t -> variable_t -> 'a @@ -85,9 +86,9 @@ class poly_interval_array_t : method can_be_0 : variable_t -> bool method change_vars : symbol_t -> symbol_t -> variable_t list -> variable_t list -> 'a - + method check_type : variable_t -> 'a - method clone : 'a + method clone : 'a method copy_info : variable_t -> interval_t -> numerical_t list -> 'a method copy_num_info : variable_t -> variable_t -> 'a method div : @@ -96,7 +97,7 @@ class poly_interval_array_t : -> variable_t -> variable_t -> 'a * variable_t option * variable_t option * variable_t option - + method down_cast_float : variable_t -> variable_t -> 'a * bool method drop_all : 'a method drop_poly : 'a @@ -105,7 +106,7 @@ class poly_interval_array_t : method get_best_interval : IntCollections.ObjectSet.elt -> interval_t method get_call : JCHProcInfo.jproc_info_t -> variable_t list -> 'a method get_const_val : variable_t -> big_int - method get_const_val_n : variable_t -> numerical_t + method get_const_val_n : variable_t -> numerical_t method get_excluded_vals : variable_t -> numerical_t list method get_extra_infos : JCHNumericInfo.numeric_info_t method get_field : @@ -114,17 +115,17 @@ class poly_interval_array_t : -> interval_t list -> variable_t -> 'a - + method get_index : variable_t -> int method get_interval : variable_t -> interval_t method get_interval_array : JCHIntervalArray.interval_array_t method set_join : variable_t -> variable_t -> variable_t -> 'a method set_type_intervals: JCHProcInfo.jproc_info_t -> variable_t list -> 'a - + method set_type_intervals_and_restrict: JCHProcInfo.jproc_info_t -> variable_t list -> 'a - + method get_poly : JCHPoly.poly_t method get_poly_vars : variable_t list method get_var_to_const : (int * numerical_t) list @@ -133,10 +134,10 @@ class poly_interval_array_t : method has_var : variable_t -> bool method init_assumptions : JCHProcInfo.jproc_info_t -> 'a method is_bottom : bool - method is_const : variable_t -> bool + method is_const : variable_t -> bool method is_top : bool method join : 'a -> 'a - method join_with_old : 'a -> 'a -> 'a + method join_with_old : 'a -> 'a -> 'a method leq : 'a -> bool method log_and : variable_t -> variable_t -> variable_t -> 'a method log_or : variable_t -> variable_t -> variable_t -> 'a @@ -152,7 +153,7 @@ class poly_interval_array_t : -> variable_t list -> variable_t list -> 'a - + method mk_empty : (int * numerical_t) list -> variable_t list -> 'a method move_simple_ineqs : 'a method mult : @@ -160,7 +161,7 @@ class poly_interval_array_t : -> variable_t -> variable_t -> 'a * variable_t option * variable_t option * bool - + method new_array : variable_t -> variable_t list -> 'a method project_out : variable_t list -> 'a method project_out_array : variable_t -> 'a @@ -171,7 +172,7 @@ class poly_interval_array_t : -> variable_t -> variable_t -> 'a * variable_t option - + method remove : variable_t list -> 'a method remove_duplicates : 'a method remove_field : variable_t -> field_info_int -> 'a @@ -183,7 +184,7 @@ class poly_interval_array_t : method set_interval : variable_t -> interval_t -> 'a method set_interval_array : JCHIntervalArray.interval_array_t -> 'a method set_fields : variable_t -> field_info_int list -> 'a - method set_poly : JCHPoly.poly_t -> 'a + method set_poly : JCHPoly.poly_t -> 'a method shr : variable_t -> variable_t -> 'a method simple_join : 'a -> 'a method simple_widening : 'a -> 'a @@ -193,7 +194,7 @@ class poly_interval_array_t : bool -> JCHProcInfo.jproc_info_t -> (variable_t * variable_t) list - -> variable_t list + -> variable_t list -> postcondition_predicate_t list method to_postconditions2 : JCHProcInfo.jproc_info_t -> postcondition_predicate_t list @@ -203,7 +204,7 @@ class poly_interval_array_t : end val bottom_poly_interval_array : poly_interval_array_t -val top_poly_interval_array : +val top_poly_interval_array : (int * numerical_t) list -> variable_t list -> poly_interval_array_t @@ -212,5 +213,3 @@ val bottom_poly_int_array : poly_interval_array_t val top_poly_int_array : poly_interval_array_t val dbg : bool ref - - diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraph.ml b/CodeHawk/CHJ/jchpoly/jCHTGraph.ml index 8bbf8d13..49472109 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraph.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTGraph.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -26,13 +27,12 @@ ============================================================================= *) (* chlib *) -open CHLanguage +open CHLanguage open CHUtils -open CHPretty +open CHPretty open CHPrettyUtil (* jchlib *) -open JCHBytecode open JCHBasicTypes open JCHBasicTypesAPI open JCHBytecodeLocation @@ -40,213 +40,213 @@ open JCHDictionary (* jchpre *) open JCHApplication -open JCHInstructionInfo open JCHPreAPI open JCHTaintOrigin (* jchsys *) open JCHGlobals -open JCHPrintUtils -open JCHSystemUtils +open JCHPrintUtils (* jchpoly *) -open JCHTNode +open JCHTNode -let dbg = ref false +let dbg = ref false let call_index = ref (-1) (* index for the CALL nodes *) -let get_call_args args = +let get_call_args args = let return_opt = ref None in let other_vars = ref [] in - let get_vars (s,v,m) = - match s with - | "return" -> return_opt := Some v + let get_vars (s, v, _m) = + match s with + | "return" -> return_opt := Some v | "throw" -> () | _ -> other_vars := v :: !other_vars in List.iter get_vars args ; (!return_opt, exception_var, List.rev !other_vars) -class collect_taint_var_graph_t - (var_to_loops: IntCollections.set_t VariableCollections.table_t) - (bound_to_loops: IntCollections.set_t VariableCollections.table_t) - (proc_info: JCHProcInfo.jproc_info_t) = - object (self:_) - inherit code_walker_t as super - val jvar_infos = proc_info#get_jvar_infos +class collect_taint_var_graph_t + (_var_to_loops: IntCollections.set_t VariableCollections.table_t) + (bound_to_loops: IntCollections.set_t VariableCollections.table_t) + (proc_info: JCHProcInfo.jproc_info_t) = + object (self:_) + inherit code_walker_t as super + + val jvar_infos = proc_info#get_jvar_infos val proc_name = proc_info#get_name - val proc = proc_info#get_procedure + val proc = proc_info#get_procedure val current_state = ref state_name_sym - (* read var -> write var *) + (* read var -> write var *) val rwedges = new TaintNodeCollections.table_t - (* same edges, in reverse order *) + (* same edges, in reverse order *) val wredges = new TaintNodeCollections.table_t - (* set of all fields referenced *) + (* set of all fields referenced *) val fields = new TaintNodeCollections.set_t - (* set of all variables in invocations *) + (* set of all variables in invocations *) val call_nodes = new TaintNodeCollections.set_t - (* set of all call nodes *) - val calls = new TaintNodeCollections.set_t + (* set of all call nodes *) + val calls = new TaintNodeCollections.set_t - (* set of all variable nodes *) + (* set of all variable nodes *) val var_nodes = new TaintNodeCollections.set_t - (* vars in an eq node -> eq node *) + (* vars in an eq node -> eq node *) val var_to_eq_nodes = new VariableCollections.table_t - + (* var1 -> var2 -> states where var1 = var2 *) val var_to_var_to_eqs = proc_info#get_var_to_var_to_eqs - (* var1 -> var2 -> states where var1 < var2 or var1 <= var2 *) + (* var1 -> var2 -> states where var1 < var2 or var1 <= var2 *) val var_to_var_to_ineqs = proc_info#get_var_to_var_to_ineqs - (* var -> state -> nodes that depend on var in state *) - val var_to_state_to_nodes = new VariableCollections.table_t + (* var -> state -> nodes that depend on var in state *) + val var_to_state_to_nodes = new VariableCollections.table_t method get_edges = rwedges method get_rev_edges = wredges - method get_fields = fields + method get_fields = fields method get_call_nodes = call_nodes method get_calls = calls method get_var_nodes = var_nodes method private mk_vnode v = let node = mk_var_node proc_name v in - var_nodes#add node ; + var_nodes#add node; node (* Adds a node from rn to wn *) - method private add_edge_to_tables wn rn = - let add_to_table table n1 n2 = - match table#get n1 with + method private add_edge_to_tables wn rn = + let add_to_table table n1 n2 = + match table#get n1 with | Some set -> set#add n2 | _ -> table#set n1 (TaintNodeCollections.set_of_list [n2]) in - add_to_table rwedges rn wn ; + add_to_table rwedges rn wn; add_to_table wredges wn rn - method private addE wnode rnode = - self#add_edge_to_tables wnode rnode ; - let add_eq_nodes enode = - match enode#get_node_type with + method private addE wnode rnode = + self#add_edge_to_tables wnode rnode; + let add_eq_nodes enode = + match enode#get_node_type with | TN_VAR_EQ (_, _, _, statelist) -> let states = new SymbolCollections.set_t in let _ = states#addList statelist in if states#has !current_state then - self#add_edge_to_tables wnode enode + self#add_edge_to_tables wnode enode else - () + () | _ -> () in - match rnode#get_node_type with - | TN_VAR (_, v, _) -> + match rnode#get_node_type with + | TN_VAR (_, v, _) -> begin - let table = - match var_to_state_to_nodes#get v with + let table = + match var_to_state_to_nodes#get v with | Some table -> table - | _ -> + | _ -> let t = new SymbolCollections.table_t in - var_to_state_to_nodes#set v t ; + var_to_state_to_nodes#set v t; t in - (match table#get !current_state with - | Some set -> set#add wnode + (match table#get !current_state with + | Some set -> set#add wnode | _ -> - table#set !current_state (TaintNodeCollections.set_of_list [wnode])) ; - (match var_to_eq_nodes#get v with + table#set + !current_state (TaintNodeCollections.set_of_list [wnode])); + (match var_to_eq_nodes#get v with | Some set -> set#iter add_eq_nodes - | None -> ()) ; + | None -> ()); end | _ -> () - method private is_unreachable n = - match n#get_node_type with + method private is_unreachable n = + match n#get_node_type with | TN_VAR (cmsix, v, _) -> let proc_name = make_procname cmsix in JCHNumericAnalysis.is_unreachable proc_name v - | _ -> false + | _ -> false - method private add_edge wn rn = + method private add_edge wn rn = if self#is_unreachable wn || self#is_unreachable rn then begin if !dbg then - pr__debug[STR "no edge added because it is unreachable "; NL] ; + pr__debug[STR "no edge added because it is unreachable "; NL]; end else if rn#is_const_var then () else - self#addE wn rn + self#addE wn rn - method private add_cedge no_back_edge wn rn = + method private add_cedge no_back_edge wn rn = if self#is_unreachable wn || self#is_unreachable rn then () else if no_back_edge then - self#add_edge wn rn - else + self#add_edge wn rn + else begin - self#add_edge wn rn ; - self#add_edge rn wn + self#add_edge wn rn; + self#add_edge rn wn end - method private add_var_edge w r = + method private add_var_edge w r = self#add_edge (self#mk_vnode w) (self#mk_vnode r) - method private add_var_edges ws rs = + method private add_var_edges ws rs = List.iter (fun w -> List.iter (self#add_var_edge w) rs) ws - method private add_eq_nodes = - let add_var_eq var enode = - match var_to_eq_nodes#get var with - | Some set -> set#add enode + method private add_eq_nodes = + let add_var_eq var enode = + match var_to_eq_nodes#get var with + | Some set -> set#add enode | None -> - var_to_eq_nodes#set var (TaintNodeCollections.set_of_list [enode]) in - let add_eq var1 var2 (states:SymbolCollections.set_t) = + var_to_eq_nodes#set var (TaintNodeCollections.set_of_list [enode]) in + let add_eq var1 var2 (states:SymbolCollections.set_t) = if var1#getIndex > var2#getIndex then () (* add an equation only once *) - else - let enode = mk_eq_node proc_name var1 var2 states in - self#add_edge enode (self#mk_vnode var1) ; - self#add_edge enode (self#mk_vnode var2) ; - add_var_eq var1 enode ; - add_var_eq var2 enode ; - match var_to_state_to_nodes#get var1 with - | Some table -> + else + let enode = mk_eq_node proc_name var1 var2 states in + self#add_edge enode (self#mk_vnode var1); + self#add_edge enode (self#mk_vnode var2); + add_var_eq var1 enode; + add_var_eq var2 enode; + match var_to_state_to_nodes#get var1 with + | Some table -> let add_state_to_nodes state nodes = - if states#has state then + if states#has state then nodes#iter (fun nd -> self#add_edge_to_tables nd enode) in - table#iter add_state_to_nodes + table#iter add_state_to_nodes | _ -> () in - let add_eqs var table = + let add_eqs var table = table#iter (add_eq var) in - var_to_var_to_eqs#iter add_eqs + var_to_var_to_eqs#iter add_eqs (* is_meta_meth is an argument needed for the stonesoup unit tests to work *) - method private add_call_edges pc msig (iInfo:instruction_info_int) args = + method private add_call_edges pc msig (iInfo:instruction_info_int) args = let meth_name = msig#name in let cinfo = app#get_method proc_info#get_method#get_class_method_signature in - let (return_opt, throw, call_args) = get_call_args args in - let mk_return_edge call_node = - match return_opt with - | Some v -> + let (return_opt, _throw, call_args) = get_call_args args in + let mk_return_edge call_node = + match return_opt with + | Some v -> let v_node = self#mk_vnode v in self#add_cedge (self#is_immutable v) v_node call_node - | _ -> + | _ -> () in - let mk_edge call_node v = + let mk_edge call_node v = let v_node = self#mk_vnode v in - call_nodes#add v_node ; + call_nodes#add v_node; if meth_name = "" then self#add_cedge false call_node v_node else self#add_cedge (self#is_immutable v) call_node v_node in - let add_invoc_edges tinfo = - if JCHSystem.jsystem#not_analyzed_bad tinfo#get_procname#getSeqNumber then + let add_invoc_edges tinfo = + if JCHSystem.jsystem#not_analyzed_bad tinfo#get_procname#getSeqNumber then begin - let add_origin v = + let add_origin v = let origs = mk_taint_origin_set [mk_call_origin tinfo "not_analyzed" proc_name pc] in @@ -254,28 +254,28 @@ class collect_taint_var_graph_t () in List.iter add_origin call_args end - else + else begin - let index = - incr call_index ; + let index = + incr call_index; !call_index in let call_node = - mk_call_node index pc cinfo tinfo return_opt call_args in - calls#add call_node ; - mk_return_edge call_node ; + mk_call_node index pc cinfo tinfo return_opt call_args in + calls#add call_node; + mk_return_edge call_node; List.iter (mk_edge call_node) call_args end in let target = iInfo#get_method_target () in - if target#is_top then + if target#is_top then begin - let index = - incr call_index ; + let index = + incr call_index; !call_index in let unknown_call_node = - mk_unknown_call_node index pc cinfo return_opt call_args in + mk_unknown_call_node index pc cinfo return_opt call_args in mk_return_edge unknown_call_node; - List.iter (mk_edge unknown_call_node) call_args ; + List.iter (mk_edge unknown_call_node) call_args; let add_origin v = if not (self#is_immutable v) then begin @@ -285,27 +285,27 @@ class collect_taint_var_graph_t let _ = (self#mk_vnode v)#add_untrusted_origins origs in () end in - List.iter add_origin call_args ; - match return_opt with - | Some return -> + List.iter add_origin call_args; + match return_opt with + | Some return -> let origs = mk_taint_origin_set [mk_top_target_origin target proc_name pc] in let _ = (self#mk_vnode return)#add_untrusted_origins origs in - () - | _ -> () + () + | _ -> () end; - List.iter add_invoc_edges target#get_valid_targets + List.iter add_invoc_edges target#get_valid_targets - method private is_immutable v = + method private is_immutable v = let vtypes = (proc_info#get_jvar_info v)#get_types in let res = JCHTypeUtils.is_immutable_type vtypes in res method private taint_field - fnode (fInfo:field_info_int) (pc:int) = - let is_not_analyzed cms = + fnode (fInfo:field_info_int) (pc:int) = + let is_not_analyzed cms = JCHSystem.jsystem#not_analyzed_bad cms#index in - if List.exists is_not_analyzed (fInfo#get_writing_methods) then + if List.exists is_not_analyzed (fInfo#get_writing_methods) then begin let origs = mk_taint_origin_set @@ -313,7 +313,7 @@ class collect_taint_var_graph_t fInfo "writing method not analyzed" proc_name pc] in fnode#set_untrusted_origins origs end - else if fInfo#is_accessible_to_stubbed_methods then + else if fInfo#is_accessible_to_stubbed_methods then begin let origs = mk_taint_origin_set @@ -321,12 +321,12 @@ class collect_taint_var_graph_t fInfo "accessible to stubbed methods" proc_name pc] in fnode#set_untrusted_origins origs end - else + else begin let cn = fInfo#get_class_name in let fs = fInfo#get_class_signature#field_signature in - match fs#descriptor with - | TObject TClass cn1 -> + match fs#descriptor with + | TObject TClass cn1 -> if fs#name = "in" && cn1#name = "java.io.InputStream" && cn#name = "java.lang.System" then @@ -337,29 +337,29 @@ class collect_taint_var_graph_t fInfo "untrusted field" proc_name pc] in fnode#set_untrusted_origins origs end - | _ -> () + | _ -> () end - method walkOperation {op_name = opname; op_args = args} = + method walkOperation {op_name = opname; op_args = args} = match opname#getBaseName with | "i" - | "ii" -> + | "ii" -> begin let pc = opname#getSeqNumber in let cms = retrieve_cms proc_name#getSeqNumber in let bcloc = get_bytecode_location cms#index pc in let iInfo = app#get_instruction bcloc in match iInfo#get_opcode with - | OpIfNull _ - | OpIfCmpAEq _ + | OpIfNull _ + | OpIfCmpAEq _ | OpIfCmpANe _ -> () - | OpCheckCast _ -> + | OpCheckCast _ -> let ref = JCHSystemUtils.get_arg_var "src1" args in let ref_new_type = JCHSystemUtils.get_arg_var "dst1" args in let rnode = self#mk_vnode ref in let rntnode = self#mk_vnode ref_new_type in begin - self#add_edge rntnode rnode ; + self#add_edge rntnode rnode; self#add_edge rnode rntnode end | OpNewArray _ -> @@ -389,14 +389,14 @@ class collect_taint_var_graph_t let lnode = self#mk_vnode length in let size_node = mk_size_node proc_name array pc in begin - self#add_edge size_node anode ; + self#add_edge size_node anode; self#add_edge lnode size_node end - | OpNew _ - | OpStringConst _ - | OpClassConst _ + | OpNew _ + | OpStringConst _ + | OpClassConst _ | OpAConstNull -> () - | OpFloatConst _ + | OpFloatConst _ | OpDoubleConst _ -> () | OpArrayStore _ -> let array = JCHSystemUtils.get_arg_var "array" args in @@ -404,10 +404,10 @@ class collect_taint_var_graph_t let anode = self#mk_vnode array in let enode = self#mk_vnode element in begin - self#add_edge anode enode ; + self#add_edge anode enode; if self#is_immutable element then () - else + else self#add_edge enode anode end | OpArrayLoad _ -> @@ -418,86 +418,91 @@ class collect_taint_var_graph_t let enode = self#mk_vnode element in let inode = self#mk_vnode index in begin - self#add_edge enode anode ; - self#add_edge enode inode ; + self#add_edge enode anode; + self#add_edge enode inode; if self#is_immutable element then () else self#add_edge anode enode end - | OpPutStatic (cn, fs) -> - let fInfo = iInfo#get_field_target in - if JCHFields.int_field_manager#is_const_field fInfo && - not (JCHFields.int_field_manager#is_dt_field cn fs) + | OpPutStatic (cn, fs) -> + let fInfo = iInfo#get_field_target in + if JCHFields.int_field_manager#is_const_field fInfo && + not (JCHFields.int_field_manager#is_dt_field cn fs) then - () - else + () + else let fnode = mk_field_node fInfo in - self#taint_field fnode fInfo pc; + self#taint_field fnode fInfo pc; let var = JCHSystemUtils.get_arg_var "val" args in let vnode = self#mk_vnode var in begin - fields#add fnode ; - self#add_edge fnode vnode ; + fields#add fnode; + self#add_edge fnode vnode; if self#is_immutable var then () else - self#add_edge vnode fnode ; + self#add_edge vnode fnode; end - | OpPutField (cn, fsig) -> + | OpPutField (_cn, fsig) -> let var = JCHSystemUtils.get_arg_var "val" args in let ref = JCHSystemUtils.get_arg_var "ref" args in let vnode = self#mk_vnode var in let ref_node = self#mk_vnode ref in let fnode = mk_obj_field_node proc_name ref fsig#index pc in - self#add_edge ref_node fnode ; - self#add_edge fnode vnode ; + self#add_edge ref_node fnode; + self#add_edge fnode vnode; if not (self#is_immutable var) then begin - self#add_edge vnode fnode ; - self#add_edge fnode ref_node ; + self#add_edge vnode fnode; + self#add_edge fnode ref_node; end | OpGetStatic (cn, fs) -> - let fInfo = iInfo#get_field_target in + let fInfo = iInfo#get_field_target in let var = JCHSystemUtils.get_arg_var "val" args in let vnode = self#mk_vnode var in if JCHFields.int_field_manager#is_const_field fInfo - && not (JCHFields.int_field_manager#is_dt_field cn fs) + && not (JCHFields.int_field_manager#is_dt_field cn fs) then () - else + else let fnode = mk_field_node fInfo in begin self#taint_field fnode fInfo pc; - fields#add fnode ; - self#add_edge vnode fnode ; + fields#add fnode; + self#add_edge vnode fnode; if self#is_immutable var then () else - self#add_edge fnode vnode ; + self#add_edge fnode vnode; end - | OpGetField (cn, fs) -> + | OpGetField (_cn, fs) -> let var = JCHSystemUtils.get_arg_var "val" args in let ref = JCHSystemUtils.get_arg_var "ref" args in - - pr__debug [STR "OpGetField "; proc_name#toPretty; STR " "; ref#toPretty; NL] ; - + + pr__debug [ + STR "OpGetField "; + proc_name#toPretty; + STR " "; + ref#toPretty; + NL]; + let vnode = self#mk_vnode var in let ref_node = self#mk_vnode ref in let fnode = mk_obj_field_node proc_name ref fs#index pc in - self#add_edge vnode fnode ; - self#add_edge fnode ref_node ; + self#add_edge vnode fnode; + self#add_edge fnode ref_node; if not (self#is_immutable var) then begin - self#add_edge ref_node fnode ; - self#add_edge fnode vnode ; + self#add_edge ref_node fnode; + self#add_edge fnode vnode; end - | OpInvokeStatic (_, ms) - | OpInvokeVirtual (_, ms) + | OpInvokeStatic (_, ms) + | OpInvokeVirtual (_, ms) | OpInvokeSpecial (_, ms) - | OpInvokeInterface (_, ms) -> + | OpInvokeInterface (_, ms) -> self#add_call_edges pc ms iInfo args - | OpInvokeDynamic (_, ms) -> + | OpInvokeDynamic (_, _ms) -> begin let (return_opt, _, call_args) = get_call_args args in match return_opt with @@ -505,15 +510,15 @@ class collect_taint_var_graph_t begin let return_node = self#mk_vnode return in let arg_nodes = List.map self#mk_vnode call_args in - List.iter (fun n -> self#addE return_node n) arg_nodes + List.iter (fun n -> self#addE return_node n) arg_nodes end | _ -> () end - | OpCmpL + | OpCmpL | OpCmpFL | OpCmpFG | OpCmpDL - | OpCmpDG -> + | OpCmpDG -> let src1 = JCHSystemUtils.get_arg_var "src1" args in let src2 = JCHSystemUtils.get_arg_var "src2" args in let dst = JCHSystemUtils.get_arg_var "dst1" args in @@ -533,250 +538,252 @@ class collect_taint_var_graph_t let rvars = JCHSystemUtils.get_read_vars args in let rnodes = List.map self#mk_vnode rvars in let cond_node = mk_cond_node proc_name pc in - List.iter (self#add_edge cond_node) rnodes - | _ -> - let wvars = + List.iter (self#add_edge cond_node) rnodes + | _ -> + let wvars = List.filter JCHSystemUtils.is_not_exception (JCHSystemUtils.get_write_vars args) in let rvars = JCHSystemUtils.get_read_vars args in - self#add_var_edges wvars rvars + self#add_var_edges wvars rvars end - | _ -> + | _ -> () - method walkCmd cmd = - match cmd with - | CFG (_, cfg) -> + method !walkCmd cmd = + match cmd with + | CFG (_, cfg) -> let states = cfg#getStates in - let walkState state_name = - current_state := state_name ; + let walkState state_name = + current_state := state_name; let state = cfg#getState state_name in self#walkCode state#getCode in - List.iter walkState states - | ASSIGN_NUM (x, NUM _) - | ASSIGN_SYM (x, SYM _) -> () - | ASSIGN_NUM (x, NUM_VAR y) -> - self#add_var_edge x y ; (* phi assignments *) - | ASSIGN_NUM (x, PLUS (y, z)) - | ASSIGN_NUM (x, MINUS (y, z)) - | ASSIGN_NUM (x, MULT (y, z)) - | ASSIGN_NUM (x, DIV (y, z)) -> - self#add_var_edge x y ; - self#add_var_edge x z ; - | ASSIGN_ARRAY (x, y) - | ASSIGN_STRUCT (x, y) + List.iter walkState states + | ASSIGN_NUM (_x, NUM _) + | ASSIGN_SYM (_x, SYM _) -> () + | ASSIGN_NUM (x, NUM_VAR y) -> + self#add_var_edge x y; (* phi assignments *) + | ASSIGN_NUM (x, PLUS (y, z)) + | ASSIGN_NUM (x, MINUS (y, z)) + | ASSIGN_NUM (x, MULT (y, z)) + | ASSIGN_NUM (x, DIV (y, z)) -> + self#add_var_edge x y; + self#add_var_edge x z; + | ASSIGN_ARRAY (x, y) + | ASSIGN_STRUCT (x, y) | ASSIGN_SYM (x, SYM_VAR y) -> (* phi assignment ? *) - self#add_var_edge x y ; + self#add_var_edge x y; if x#getName#getBaseName = y#getName#getBaseName then - () + () else if (self#is_immutable x || self#is_immutable y) then - () + () else - self#add_var_edge y x - | ASSIGN_NUM_ELT (a, i, v) -> - self#add_var_edge a v - | READ_NUM_ELT (v, a, i) -> - self#add_var_edge v a + self#add_var_edge y x + | ASSIGN_NUM_ELT (a, _i, v) -> + self#add_var_edge a v + | READ_NUM_ELT (v, a, _i) -> + self#add_var_edge v a | SHIFT_ARRAY (tgt, src, _) -> (* only for int arrays *) - self#add_var_edge tgt src - | BLIT_ARRAYS (tgt, tgt_o, src, src_o, n) -> (* only for int arrays *) - self#add_var_edge tgt src - | SET_ARRAY_ELTS (a, s, n, v) -> (* only for int arrays *) - self#add_var_edge a v - | OPERATION op -> + self#add_var_edge tgt src + | BLIT_ARRAYS (tgt, _tgt_o, src, _src_o, _n) -> (* only for int arrays *) + self#add_var_edge tgt src + | SET_ARRAY_ELTS (a, _s, _n, v) -> (* only for int arrays *) + self#add_var_edge a v + | OPERATION op -> self#walkOperation op - | _ -> super#walkCmd cmd + | _ -> super#walkCmd cmd - (* tainted loop does not transfer taint to the variables + (* tainted loop does not transfer taint to the variables * changes inside the loop *) - method add_loop_edges = + method add_loop_edges = let index_to_loopn = new IntCollections.table_t in let var_to_node:taint_node_int VariableCollections.table_t = new VariableCollections.table_t in - let get_loopn index = + let get_loopn index = match index_to_loopn#get index with - | Some loopn -> + | Some loopn -> loopn - | None -> + | None -> let loop_var_name = new symbol_t ~seqnr:index "lc" in let loop_var = new variable_t loop_var_name NUM_VAR_TYPE in let loopn = self#mk_vnode loop_var in - var_to_node#set loop_var loopn ; - index_to_loopn#set index loopn ; + var_to_node#set loop_var loopn; + index_to_loopn#set index loopn; loopn in - let add_bedge bn index = + let add_bedge bn index = let loopn = get_loopn index in self#add_edge loopn bn in - let add_bedges b set = + let add_bedges b set = let bn = self#mk_vnode b in set#iter (add_bedge bn) in - bound_to_loops#iter add_bedges - - method private add_init_this = + bound_to_loops#iter add_bedges + + method private add_init_this = let minfo = proc_info#get_method_info in - if minfo#is_constructor && not minfo#is_static then + if minfo#is_constructor && not minfo#is_static then () - method private remove_cmp_var_edges = - let remove_from_table table node1 node2 = - match table#get node1 with + method private remove_cmp_var_edges = + let remove_from_table table node1 node2 = + match table#get node1 with | Some set -> set#remove node2 | _ -> () in - let remove_edge rnode wnode = - remove_from_table rwedges rnode wnode ; + let remove_edge rnode wnode = + remove_from_table rwedges rnode wnode; remove_from_table wredges wnode rnode in - let remove node (wnodes: TaintNodeCollections.set_t) = - match node#get_node_type with - | TN_VAR_EQ (_, v1, v2, _) -> + let remove node (wnodes: TaintNodeCollections.set_t) = + match node#get_node_type with + | TN_VAR_EQ (_, v1, v2, _) -> let vnode1 = mk_var_node proc_name v1 in let vnode2 = mk_var_node proc_name v2 in - wnodes#iter (fun wn -> remove_edge vnode1 wn ; remove_edge vnode2 wn) + wnodes#iter (fun wn -> remove_edge vnode1 wn; remove_edge vnode2 wn) | _ -> () in - rwedges#iter remove + rwedges#iter remove method walkProcedure (proc: procedure_int) = - self#add_init_this ; - self#add_eq_nodes ; - super#walkCode proc#getBody ; - self#add_loop_edges + self#add_init_this; + self#add_eq_nodes; + super#walkCode proc#getBody; + self#add_loop_edges end -class taint_graph_t +class taint_graph_t ~(proc_name:symbol_t) ~(sig_nodes:taint_node_int list) ~(fields:TaintNodeCollections.set_t) ~(call_nodes:TaintNodeCollections.set_t) ~(calls:TaintNodeCollections.set_t) ~(var_nodes:TaintNodeCollections.set_t) - ~(edges:TaintNodeCollections.set_t TaintNodeCollections.table_t) - ~(rev_edges:TaintNodeCollections.set_t TaintNodeCollections.table_t) + ~(edges:TaintNodeCollections.set_t TaintNodeCollections.table_t) + ~(rev_edges:TaintNodeCollections.set_t TaintNodeCollections.table_t) ~(sources:TaintNodeCollections.set_t) = object (self: 'a) - val return_node_opt = - let is_return tnode = - match tnode#get_node_type with - | TN_VAR (_, v, _) -> + val return_node_opt = + let is_return tnode = + match tnode#get_node_type with + | TN_VAR (_, v, _) -> let index = v#getIndex in - index = num_return_var_index || index = sym_return_var_index + index = num_return_var_index || index = sym_return_var_index | _ -> false in - match List.filter is_return sig_nodes with - | n :: ns -> Some n + match List.filter is_return sig_nodes with + | n :: _ns -> Some n | _ -> None - val exception_node_opt = - let is_exc tnode = - match tnode#get_node_type with + val exception_node_opt = + let is_exc tnode = + match tnode#get_node_type with | TN_VAR (_, v, _) -> JCHSystemUtils.is_exception v | _ -> false in - match List.filter is_exc sig_nodes with - | n :: ns -> Some n + match List.filter is_exc sig_nodes with + | n :: _ns -> Some n | _ -> None - val arg_nodes = - let is_arg tnode = - match tnode#get_node_type with - | TN_VAR (_, v, _) -> + val arg_nodes = + let is_arg tnode = + match tnode#get_node_type with + | TN_VAR (_, v, _) -> not (JCHSystemUtils.is_return v || JCHSystemUtils.is_exception v) | _ -> false in - List.filter is_arg sig_nodes - + List.filter is_arg sig_nodes + method get_proc_name = proc_name - method get_sig_nodes = - match (return_node_opt, exception_node_opt) with - | (Some return, Some exc) -> + method get_sig_nodes = + match (return_node_opt, exception_node_opt) with + | (Some return, Some exc) -> exc :: return :: arg_nodes - | (None, Some exc) -> - exc :: arg_nodes - | (Some return, None) -> + | (None, Some exc) -> + exc :: arg_nodes + | (Some return, None) -> return :: arg_nodes - | _ -> - arg_nodes + | _ -> + arg_nodes - method get_ret_and_arg_nodes = - match return_node_opt with - | Some return -> + method get_ret_and_arg_nodes = + match return_node_opt with + | Some return -> return :: arg_nodes - | _ -> - arg_nodes - + | _ -> + arg_nodes + method get_return_node = return_node_opt - + method get_arg_nodes = arg_nodes - + method get_fields = fields - + method get_call_nodes = call_nodes - + method get_calls = calls - + method get_var_nodes = var_nodes - + method get_edges = edges - + method get_rev_edges = rev_edges - - method get_sources = sources - method private add_table_edge table n1 n2 = + method get_sources = sources + + method private add_table_edge table n1 n2 = match table#get n1 with - | Some set -> + | Some set -> set#add n2 - | None -> + | None -> let set = TaintNodeCollections.set_of_list [n2] in table#set n1 set - - method add_edge rn wn = - self#add_table_edge edges rn wn ; - self#add_table_edge rev_edges wn rn ; + + method add_edge rn wn = + self#add_table_edge edges rn wn; + self#add_table_edge rev_edges wn rn; let _ = wn#add_untrusted_origins (rn#get_untrusted_origins) in () - method leq (a: 'a) = - let aedges = a#get_edges in + method leq (a: 'a) = + let aedges = a#get_edges in if edges#size > aedges#size then false - else + else begin - let leq_set k = + let leq_set k = let set1 = Option.get (edges#get k) in - match aedges#get k with - | Some set2 -> set1#subset set2 + match aedges#get k with + | Some set2 -> set1#subset set2 | _ -> false in List.for_all leq_set edges#listOfKeys end - method equal (a: 'a) = - let aedges = a#get_edges in + method equal (a: 'a) = + let aedges = a#get_edges in if edges#size <> aedges#size then false - else + else begin - let eq_set k = + let eq_set k = let set1 = Option.get (edges#get k) in - match aedges#get k with - | Some set2 -> set1#equal set2 + match aedges#get k with + | Some set2 -> set1#equal set2 | _ -> false in List.for_all eq_set edges#listOfKeys end - method toPretty = - let pp_edges = + method toPretty = + let pp_edges = let pp = ref [] in - let pp_edge n (set: TaintNodeCollections.set_t) = + let pp_edge n (set: TaintNodeCollections.set_t) = pp := - (LBLOCK [n#toPretty; NL; + (LBLOCK [n#toPretty; NL; INDENT - (5, LBLOCK (List.map (fun m -> - LBLOCK [m#toPretty; NL]) set#toList))]) :: !pp in - edges#iter pp_edge ; + (5, + LBLOCK (List.map (fun m -> + LBLOCK [m#toPretty; NL]) set#toList))]) + :: !pp in + edges#iter pp_edge; !pp in - LBLOCK [proc_name#toPretty; NL; + LBLOCK [proc_name#toPretty; NL; STR "signature: "; pp_list sig_nodes; NL; STR "edges: "; NL; INDENT (5, LBLOCK pp_edges); NL; - STR "variable_nodes: "; NL; + STR "variable_nodes: "; NL; INDENT (5, LBLOCK(List.map (fun n -> LBLOCK [n#toPretty; NL]) var_nodes#toList)); NL; @@ -787,15 +794,15 @@ class taint_graph_t (* for investigation *) let make_tgraph proc_info = - let proc = proc_info#get_procedure in + let proc = proc_info#get_procedure in let proc_name = proc_info#get_name in - let (var_to_loops, bound_to_loops) = + let (var_to_loops, bound_to_loops) = JCHTaintLoopUtils.get_taint_loop_info proc_info in let collector = new collect_taint_var_graph_t var_to_loops bound_to_loops proc_info in let _ = collector#walkProcedure proc in - let sig_nodes = - List.map + let sig_nodes = + List.map (mk_var_node proc_name) (JCHSystemUtils.get_signature_vars proc) in let fields = collector#get_fields in @@ -806,10 +813,10 @@ let make_tgraph proc_info = let edges = collector#get_edges in let rev_edges = collector#get_rev_edges in let sources = new TaintNodeCollections.set_t in - let tgraph = + let tgraph = new taint_graph_t ~proc_name - ~sig_nodes + ~sig_nodes ~fields ~call_nodes ~calls @@ -819,321 +826,324 @@ let make_tgraph proc_info = ~sources in tgraph -let mk_empty_tgraph proc_name = +let mk_empty_tgraph proc_name = new taint_graph_t ~proc_name - ~sig_nodes:[] + ~sig_nodes:[] ~fields:(new TaintNodeCollections.set_t) ~call_nodes:(new TaintNodeCollections.set_t) ~calls:(new TaintNodeCollections.set_t) ~var_nodes:(new TaintNodeCollections.set_t) ~edges:(new TaintNodeCollections.table_t) ~rev_edges:(new TaintNodeCollections.table_t) - ~sources:(new TaintNodeCollections.set_t) + ~sources:(new TaintNodeCollections.set_t) -(* Graph with edges between scc's with nodes given by one representative +(* Graph with edges between scc's with nodes given by one representative * of an scc * It includes the transitive edges *) -class scc_taint_graph_t = - object (self: 'a) - val node_to_rep = new TaintNodeCollections.table_t - val rep_to_nodes = new TaintNodeCollections.table_t +class scc_taint_graph_t = + object (self: 'a) + val node_to_rep = new TaintNodeCollections.table_t + val rep_to_nodes = new TaintNodeCollections.table_t val node_edges = new TaintNodeCollections.table_t - val node_rev_edges = new TaintNodeCollections.table_t + val node_rev_edges = new TaintNodeCollections.table_t val rep_edges = new TaintNodeCollections.table_t - val rep_rev_edges = new TaintNodeCollections.table_t + val rep_rev_edges = new TaintNodeCollections.table_t val tainted_nodes = new TaintNodeCollections.set_t val dt_tainted_nodes = new TaintNodeCollections.set_t - method private get_rep node = + method private get_rep node = let path_nodes = new TaintNodeCollections.set_t in - let rec go_up n = - path_nodes#add n ; + let rec go_up n = + path_nodes#add n; let up_n = Option.get (node_to_rep#get n) in if up_n#get_index = n#get_index then n else go_up up_n in let rep = go_up node in - if node#get_index = rep#get_index then - path_nodes#iter (fun n -> node_to_rep#set n rep) ; + if node#get_index = rep#get_index then + path_nodes#iter (fun n -> node_to_rep#set n rep); rep - method add_node_edge n1 n2 = - node_to_rep#set n1 n1 ; - node_to_rep#set n2 n2 ; - if n1#get_index = n2#get_index then () - else + method add_node_edge n1 n2 = + node_to_rep#set n1 n1; + node_to_rep#set n2 n2; + if n1#get_index = n2#get_index then () + else begin - (match node_edges#get n1 with - | Some set -> set#add n2 - | _ -> node_edges#set n1 (TaintNodeCollections.set_of_list [n2])) ; - (match node_rev_edges#get n2 with + (match node_edges#get n1 with + | Some set -> set#add n2 + | _ -> node_edges#set n1 (TaintNodeCollections.set_of_list [n2])); + (match node_rev_edges#get n2 with | Some set -> set#add n1 | _ -> node_rev_edges#set n2 (TaintNodeCollections.set_of_list [n1])) end - method add_node_edges (n: taint_node_int) (set: TaintNodeCollections.set_t) = + method add_node_edges (n: taint_node_int) (set: TaintNodeCollections.set_t) = set#iter (self#add_node_edge n) - method private find_node_sccs visited start_node = + method private find_node_sccs visited start_node = let on_path = new TaintNodeCollections.set_t in let path = Stack.create () in - Stack.push (start_node, None) path ; + Stack.push (start_node, None) path; while not (Stack.is_empty path) do - match Stack.pop path with + match Stack.pop path with | (node, None) -> begin let rep = self#get_rep node in if on_path#has rep then begin let all_nexts = new TaintNodeCollections.set_t in - let rec unroll () = + let rec unroll () = let (n, next_opts) = Stack.top path in let nexts = Option.get next_opts in - on_path#remove n ; + on_path#remove n; if n#get_index <> rep#get_index then begin let _ = Stack.pop path in - all_nexts#addSet nexts ; - node_to_rep#set node rep ; + all_nexts#addSet nexts; + node_to_rep#set node rep; unroll () end - else + else begin nexts#addSet all_nexts end in - unroll () + unroll () end - else if not (visited#has node) then + else if not (visited#has node) then begin - visited#add node ; - match node_edges#get node with + visited#add node; + match node_edges#get node with | Some nexts -> Stack.push (node, Some nexts#clone) path | _ -> Stack.push (node, Some (new TaintNodeCollections.set_t)) path end end - | (node, Some nexts) -> - if nexts#isEmpty then + | (node, Some nexts) -> + if nexts#isEmpty then begin - on_path#remove node ; - if Stack.is_empty path then () + on_path#remove node; + if Stack.is_empty path then () else let (parent, _) = Stack.top path in on_path#remove parent end else begin let node' = Option.get nexts#choose in - nexts#remove node' ; - Stack.push (node, Some nexts) path ; - on_path#add node ; + nexts#remove node'; + Stack.push (node, Some nexts) path; + on_path#add node; Stack.push (node', None) path end done - method find_sccs = + method find_sccs = let visited = new TaintNodeCollections.set_t in - let find_from_node node next_nodes = + let find_from_node node _next_nodes = if visited#has node then self#find_node_sccs visited node in - node_edges#iter find_from_node + node_edges#iter find_from_node - method private make_rep_to_nodes = - let process node rep = - match rep_to_nodes#get rep with - | Some set -> set#add node + method private make_rep_to_nodes = + let process node rep = + match rep_to_nodes#get rep with + | Some set -> set#add node | _ -> rep_to_nodes#set rep (TaintNodeCollections.set_of_list [node]) in - node_to_rep#iter process + node_to_rep#iter process - method get_nodes rep = - match rep_to_nodes#get rep with + method get_nodes rep = + match rep_to_nodes#get rep with | Some set -> set | _ -> TaintNodeCollections.set_of_list [rep] - method private make_rep_graph_ = - let add_edge node next_nodes = + method private make_rep_graph_ = + let add_edge node next_nodes = let rep = Option.get (node_to_rep#get node) in - let next_reps = - match rep_edges#get rep with - | Some set -> set - | _ -> + let next_reps = + match rep_edges#get rep with + | Some set -> set + | _ -> let set = new TaintNodeCollections.set_t in - rep_edges#set rep set ; + rep_edges#set rep set; set in - let add n = + let add n = let r = Option.get (node_to_rep#get n) in if r#get_index <> rep#get_index then begin - next_reps#add r ; - match rep_rev_edges#get r with - | Some set -> set#add rep + next_reps#add r; + match rep_rev_edges#get r with + | Some set -> set#add rep | _ -> - rep_rev_edges#set r (TaintNodeCollections.set_of_list [rep]) + rep_rev_edges#set r (TaintNodeCollections.set_of_list [rep]) end in next_nodes#iter add in node_edges#iter add_edge - method get_terminals = + method get_terminals = let terminals = new TaintNodeCollections.set_t in - let add rep prevs = - match rep_edges#get rep with + let add rep _prevs = + match rep_edges#get rep with | Some set -> if set#isEmpty then terminals#add rep | _ -> terminals#add rep in - rep_rev_edges#iter add ; + rep_rev_edges#iter add; terminals - method add_transitive_edges = + method add_transitive_edges = let work_list = self#get_terminals in let consumable_edges = new TaintNodeCollections.table_t in - let add_edges rep nexts = + let add_edges rep nexts = consumable_edges#set rep nexts#clone in - rep_edges#iter add_edges ; + rep_edges#iter add_edges; while not work_list#isEmpty do let rep = Option.get work_list#choose in - work_list#remove rep ; - match rep_rev_edges#get rep with - | Some prevs -> - let add_to_work_list r = + work_list#remove rep; + match rep_rev_edges#get rep with + | Some prevs -> + let add_to_work_list r = let nexts = Option.get (consumable_edges#get r) in - nexts#remove rep ; + nexts#remove rep; if nexts#isEmpty then work_list#add r in prevs#iter add_to_work_list | _ -> () done - - method make_rep_graph = - self#make_rep_to_nodes ; - self#make_rep_graph_ ; - self#add_transitive_edges - method private is_untrusted_field (fInfo:field_info_int) = + method make_rep_graph = + self#make_rep_to_nodes; + self#make_rep_graph_; + self#add_transitive_edges + + method private is_untrusted_field (fInfo:field_info_int) = let cn = fInfo#get_class_name in let fs = fInfo#get_class_signature#field_signature in - match fs#descriptor with - | TObject TClass cn1 -> + match fs#descriptor with + | TObject TClass cn1 -> fs#name = "in" && cn1#name = "java.io.InputStream" && cn#name = "java.lang.System" - | _ -> false + | _ -> false - method private is_untrusted node = - match node#get_taint with - | Some t -> t = 1 - | _ -> false + method private is_untrusted node = + match node#get_taint with + | Some t -> t = 1 + | _ -> false - method private taint_scc rep = + method private taint_scc rep = let nodes = Option.get (rep_to_nodes#get rep) in let untrusted_origs = ref (mk_taint_origin_set []) in - let add_taint n = + let add_taint n = untrusted_origs := join_taint_origin_sets !untrusted_origs n#get_untrusted_origins in - (match rep_rev_edges#get rep with - | Some reps -> reps#iter add_taint - | _ -> ()) ; + (match rep_rev_edges#get rep with + | Some reps -> reps#iter add_taint + | _ -> ()); nodes#iter add_taint; - let set_taint (n : taint_node_int) = + let set_taint (n : taint_node_int) = let _ = n#add_untrusted_origins !untrusted_origs in () in - nodes#iter set_taint + nodes#iter set_taint - method taint = + method taint = let reps = rep_to_nodes#listOfKeys in let reps_with_edges = rep_rev_edges#listOfKeys in let leaf_reps = List.filter (fun r -> not (List.mem r reps_with_edges)) reps in - + let processed = new TaintNodeCollections.set_t in - let rec work (reps : taint_node_int list) = - match reps with - | rep :: rest_reps-> - let has_all_prevs_processed rep = - match rep_rev_edges#get rep with + let rec work (reps : taint_node_int list) = + match reps with + | rep :: rest_reps-> + let has_all_prevs_processed rep = + match rep_rev_edges#get rep with | Some prev_reps -> List.for_all processed#has prev_reps#toList | _ -> true in - processed#add rep ; + processed#add rep; self#taint_scc rep; - let next_reps = - match rep_edges#get rep with + let next_reps = + match rep_edges#get rep with | Some set -> List.filter has_all_prevs_processed set#toList | _ -> [] in - work (rest_reps @ next_reps) + work (rest_reps @ next_reps) | _ -> () in - work leaf_reps - - method restrict_to_proc (proc_name: symbol_t) = - let is_from_proc node = - match node#get_node_type with + work leaf_reps + + method restrict_to_proc (proc_name: symbol_t) = + let is_from_proc node = + match node#get_node_type with | TN_VAR (cmsix, _, _) -> cmsix = proc_name#getIndex | TN_FIELD _ -> true | _ -> false in let rep_to_proc_nodes = new TaintNodeCollections.table_t in let proc_reps = new TaintNodeCollections.set_t in - let add rep nodes = + let add rep nodes = let proc_nodes = nodes#filter is_from_proc in - if proc_nodes#isEmpty then + if proc_nodes#isEmpty then begin - rep_to_proc_nodes#set rep proc_nodes ; + rep_to_proc_nodes#set rep proc_nodes; proc_reps#add rep end in - rep_to_nodes#iter add ; + rep_to_nodes#iter add; let new_rep_edges = new TaintNodeCollections.table_t in - let add rep set = - if proc_reps#has rep then + let add rep set = + if proc_reps#has rep then begin let proc_set = set#filter proc_reps#has in - if not proc_set#isEmpty then + if not proc_set#isEmpty then new_rep_edges#set rep proc_set end in - rep_edges#iter add ; + rep_edges#iter add; let proc_edges = new TaintNodeCollections.table_t in - let add_proc_edge n1 n2 = - match proc_edges#get n1 with + let add_proc_edge n1 n2 = + match proc_edges#get n1 with | Some set -> set#add n2 | _ -> proc_edges#set n1 (TaintNodeCollections.set_of_list [n2]) in let add_proc_edges n1 set = set#iter (add_proc_edge n1) in - new_rep_edges#iter add_proc_edges ; + new_rep_edges#iter add_proc_edges; proc_edges - - method toPretty = - LBLOCK [STR "scc_taint_graph: "; NL; - INDENT (5, LBLOCK [STR "node_to_rep: "; NL; node_to_rep#toPretty; NL; - STR "rep_to_nodes: "; NL; rep_to_nodes#toPretty; NL; - STR "rep_edges: "; NL; rep_edges#toPretty; NL])] - - end - -let big_graph = new scc_taint_graph_t - -let add_edges_to_big_graph edges = - List.iter (fun (n1, n2) -> big_graph#add_node_edge n1 n2) edges - -let connect_to_big_graph (g: taint_graph_t) = - let add_edge (n1: taint_node_int) (n2:taint_node_int) = - match (n1#get_node_type, n2#get_node_type) with - | (TN_VAR (_, v, _), n) -> - big_graph#add_node_edge n1 n2 - | (_, TN_VAR (_, v, _)) -> + + method toPretty = + LBLOCK [ + STR "scc_taint_graph: "; NL; + INDENT + (5, + LBLOCK [ + STR "node_to_rep: "; NL; node_to_rep#toPretty; NL; + STR "rep_to_nodes: "; NL; rep_to_nodes#toPretty; NL; + STR "rep_edges: "; NL; rep_edges#toPretty; NL])] + + end + + +let big_graph = new scc_taint_graph_t + +let add_edges_to_big_graph edges = + List.iter (fun (n1, n2) -> big_graph#add_node_edge n1 n2) edges + +let connect_to_big_graph (g: taint_graph_t) = + let add_edge (n1: taint_node_int) (n2:taint_node_int) = + match (n1#get_node_type, n2#get_node_type) with + | (TN_VAR (_, _v, _), _n) -> + big_graph#add_node_edge n1 n2 + | (_, TN_VAR (_, v, _)) -> if JCHSystemUtils.is_exception v then () else big_graph#add_node_edge n1 n2 | _ -> big_graph#add_node_edge n1 n2 in - - let add_edges (n: taint_node_int) (nexts: TaintNodeCollections.set_t) = + + let add_edges (n: taint_node_int) (nexts: TaintNodeCollections.set_t) = nexts#iter (add_edge n) in - g#get_edges#iter add_edges - -let taint_big_graph untrusted_nodes unknown_nodes = - big_graph#make_rep_graph ; - big_graph#taint - -(* Returns true if the edges in graph g1 are included in graph g2 - * considering equivalent any two nodes that have the same + g#get_edges#iter add_edges + +let taint_big_graph _untrusted_nodes _unknown_nodes = + big_graph#make_rep_graph; + big_graph#taint + +(* Returns true if the edges in graph g1 are included in graph g2 + * considering equivalent any two nodes that have the same * representative in big_graph *) -let restrict_big_graph_to_proc proc_name = +let restrict_big_graph_to_proc proc_name = big_graph#restrict_to_proc proc_name - - diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraph.mli b/CodeHawk/CHJ/jchpoly/jCHTGraph.mli index ef0b63e2..fd49996f 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraph.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTGraph.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -40,12 +40,14 @@ class taint_graph_t : -> call_nodes:JCHTNode.TaintNodeCollections.set_t -> calls:JCHTNode.TaintNodeCollections.set_t -> var_nodes:JCHTNode.TaintNodeCollections.set_t - -> edges:JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t - -> rev_edges:JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t + -> edges: + JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t + -> rev_edges: + JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t -> sources:JCHTNode.TaintNodeCollections.set_t -> object ('a) method add_edge:taint_node_int -> taint_node_int -> unit - method equal : 'a -> bool + method equal : 'a -> bool method get_arg_nodes:taint_node_int list method get_call_nodes : JCHTNode.TaintNodeCollections.set_t method get_calls : JCHTNode.TaintNodeCollections.set_t @@ -60,20 +62,20 @@ class taint_graph_t : method get_rev_edges : JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t method get_sig_nodes:taint_node_int list - method leq : 'a -> bool + method leq : 'a -> bool method toPretty:pretty_t end -val make_tgraph : JCHProcInfo.jproc_info_t -> taint_graph_t +val make_tgraph : JCHProcInfo.jproc_info_t -> taint_graph_t val mk_empty_tgraph:symbol_t -> taint_graph_t val add_edges_to_big_graph:(taint_node_int * taint_node_int) list -> unit -val connect_to_big_graph : taint_graph_t -> unit +val connect_to_big_graph : taint_graph_t -> unit val taint_big_graph:taint_node_int list -> taint_node_int list -> unit -val restrict_big_graph_to_proc : - symbol_t +val restrict_big_graph_to_proc : + symbol_t -> JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t -val dbg : bool ref +val dbg : bool ref diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.ml b/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.ml index 1ded334a..962b0a6e 100755 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.mli b/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.mli index 7156817f..3c98cb38 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphAnalysis.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.ml b/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.ml index d7788668..8971f250 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.ml @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -27,19 +27,17 @@ ============================================================================= *) (* chlib *) -open CHLanguage +open CHLanguage open CHUtils open CHPretty (* chutil *) open CHLogger -open CHPrettyUtil (* jchlib *) open JCHBasicTypes open JCHBasicTypesAPI open JCHDictionary -open JCHFunctionSummary open JCHFunctionSummaryLibrary open JCHJTerm @@ -53,7 +51,7 @@ open JCHTGraph open JCHPrintUtils let lib_stub_table = new SymbolCollections.table_t -let dbg = ref false +let dbg = ref false let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = @@ -64,24 +62,24 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = let return_node_opt = ref None in - let types = + let types = if fsum#is_static then - msd#arguments + msd#arguments else TBasic Object :: msd#arguments in - let get_var_type t = - match t with - | TObject _ + let get_var_type t = + match t with + | TObject _ | TBasic Object -> SYM_VAR_TYPE | _ -> NUM_VAR_TYPE in let arg_offset = ref 1 in - let get_nodes () = + let get_nodes () = let nodes = ref [mk_var_node_pc 0 stub_name exception_var] in - (match msd#return_value with - | Some t -> - incr arg_offset ; + (match msd#return_value with + | Some t -> + incr arg_offset; let node = mk_var_node_pc 0 @@ -91,48 +89,48 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = return_node_opt := Some node; nodes := node :: !nodes end - | _ -> ()) ; + | _ -> ()); let number = ref 0 in - let rec add_arg arg_types = - match arg_types with - | t :: rest_arg_types -> + let rec add_arg arg_types = + match arg_types with + | t :: rest_arg_types -> let name = "arg"^(string_of_int !number) in let node = mk_var_node_pc 0 stub_name (make_variable name (get_var_type t)) in begin - nodes := node :: !nodes ; - incr number ; + nodes := node :: !nodes; + incr number; add_arg rest_arg_types end | [] -> () in - add_arg types ; + add_arg types; List.rev !nodes in - - let nodes = get_nodes () in + + let nodes = get_nodes () in let sources = new TaintNodeCollections.set_t in - let add_edges fsum = + let add_edges fsum = let fedges = new TaintNodeCollections.table_t in let bedges = new TaintNodeCollections.table_t in let return_has_taint = ref false in - let get_node t = + let get_node t = match t with | JLocalVar (-1) -> begin - return_has_taint := true ; + return_has_taint := true; Option.get !return_node_opt end - | JLocalVar i -> + | JLocalVar i -> (try - List.nth nodes (i + !arg_offset) + List.nth nodes (i + !arg_offset) with | _ -> let msg = - LBLOCK [ STR "mkLibStub "; stub_name#toPretty; STR " "; - cms#toPretty; STR " List.nth failed for "; INT i; STR ": " ; - fsum#toPretty ] in + LBLOCK [STR "mkLibStub "; stub_name#toPretty; STR " "; + cms#toPretty; STR " List.nth failed for "; INT i; STR ": "; + fsum#toPretty] in begin - ch_error_log#add "GraphStubs:add_edges" msg ; + ch_error_log#add "GraphStubs:add_edges" msg; raise (JCH_failure msg) end) | JObjectFieldValue (cmsix,varindex,cnix,fieldname) -> @@ -145,10 +143,10 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = begin ch_error_log#add "class missing from summary" - (LBLOCK [ cms#toPretty ; STR ": " ; cn#toPretty ]) ; + (LBLOCK [cms#toPretty; STR ": "; cn#toPretty]); raise (JCH_failure - (LBLOCK [ STR "mk_lib_stubs:add_edges: " ; p ])) + (LBLOCK [STR "mk_lib_stubs:add_edges: "; p])) end in let fs = try @@ -156,24 +154,33 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = with | JCH_failure p -> let cms = retrieve_cms cmsix in - raise (JCH_failure - (LBLOCK [ STR "TGraphStubs:mk_lib_stub:add_edges:JObjectFieldValue: " ; - cms#toPretty ; STR ": " ; p ])) in + raise + (JCH_failure + (LBLOCK [ + STR "TGraphStubs:mk_lib_stub:add_edges:JObjectFieldValue: "; + cms#toPretty; + STR ": "; + p])) in let cfs = make_cfs cn fs in - let _ = pr__debug [ STR "Library field taint: " ; cfs#toPretty ; - STR " (using variable only now)" ; NL ] in + let _ = + pr__debug [ + STR "Library field taint: "; + cfs#toPretty; + STR " (using variable only now)"; + NL] in (try List.nth nodes (varindex + !arg_offset) with | _ -> let msg = - LBLOCK [ STR "mkLibStub "; stub_name#toPretty; STR " "; - cms#toPretty; STR " List.nth failed for "; - INT varindex; NL; - fsum#toPretty; STR " (field value " ; STR fieldname ; - STR ")" ] in + LBLOCK [ + STR "mkLibStub "; stub_name#toPretty; STR " "; + cms#toPretty; STR " List.nth failed for "; + INT varindex; NL; + fsum#toPretty; STR " (field value "; STR fieldname; + STR ")"] in begin - ch_error_log#add "GraphStubs:add_edges" msg ; + ch_error_log#add "GraphStubs:add_edges" msg; raise (JCH_failure msg) end) | JStaticFieldValue (cnix,fieldname) -> @@ -186,75 +193,82 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = begin ch_error_log#add "class missing from summary" - (LBLOCK [ cms#toPretty ; STR ": " ; cn#toPretty ]) ; - raise (JCH_failure (LBLOCK [ STR "mk_lib_stubs:add_edges: " ; p ])) - end in + (LBLOCK [cms#toPretty; STR ": "; cn#toPretty]); + raise (JCH_failure (LBLOCK [STR "mk_lib_stubs:add_edges: "; p])) + end in let fs = try cInfo#get_field_signature fieldname with | JCH_failure p -> - raise (JCH_failure - (LBLOCK [ STR "TGraphStubs:mk_lib_stub:add_edges:JStaticFieldValue: " ; - p ])) in + raise + (JCH_failure + (LBLOCK [ + STR "TGraphStubs:mk_lib_stub:add_edges:JStaticFieldValue: "; + p])) in let cfs = make_cfs cn fs in let _ = - pr__debug [ STR "mkLibStub: "; stub_name#toPretty ; STR " " ; - cms#toPretty ; STR ": Static field not yet handled: " ; - cfs#toPretty ; NL ] in - raise (JCH_failure (LBLOCK [ STR "mk_lib_stub: static field not yet handled" ])) + pr__debug [ + STR "mkLibStub: "; stub_name#toPretty; STR " "; + cms#toPretty; STR ": Static field not yet handled: "; + cfs#toPretty; NL] in + raise + (JCH_failure + (LBLOCK [STR "mk_lib_stub: static field not yet handled"])) | JSize t -> let _ = - pr__debug [ STR "mkLibStub: " ; stub_name#toPretty ; STR " " ; - cms#toPretty ; STR ": Size term not yet handled: " ; - jterm_to_pretty t ; NL ] in + pr__debug [ + STR "mkLibStub: "; stub_name#toPretty; STR " "; + cms#toPretty; STR ": Size term not yet handled: "; + jterm_to_pretty t; NL] in raise (JCH_failure - (LBLOCK [ STR "mk_lib_stub: size term not yet handled" ])) - | _ -> - pr__debug [STR "mkLibStub "; stub_name#toPretty; STR " "; cms#toPretty; - STR " jterm not found "; NL; fsum#toPretty; NL] ; - raise (JCH_failure (STR "node not found")) in - let add_edge taint_el = - match taint_el with - | TTransfer (t1, t2) -> + (LBLOCK [STR "mk_lib_stub: size term not yet handled"])) + | _ -> + pr__debug [ + STR "mkLibStub "; stub_name#toPretty; STR " "; cms#toPretty; + STR " jterm not found "; NL; fsum#toPretty; NL]; + raise (JCH_failure (STR "node not found")) in + let add_edge taint_el = + match taint_el with + | TTransfer (t1, t2) -> let nd1 = get_node t1 in let nd2 = get_node t2 in - let addE table n1 n2 = - match table#get n1 with - | Some set -> set#add n2 - | None -> + let addE table n1 n2 = + match table#get n1 with + | Some set -> set#add n2 + | None -> let set = TaintNodeCollections.set_of_list [n2] in table#set n1 set in begin - addE fedges nd1 nd2 ; + addE fedges nd1 nd2; addE bedges nd2 nd1 end | TRefEqual (t1,t2) -> - let _ = pr__debug [ STR "Temporary code for TRefEqual " ; NL ] in + let _ = pr__debug [STR "Temporary code for TRefEqual "; NL] in let nd1 = get_node t1 in let nd2 = get_node t2 in - let addE table n1 n2 = - match table#get n1 with - | Some set -> set#add n2 - | None -> + let addE table n1 n2 = + match table#get n1 with + | Some set -> set#add n2 + | None -> let set = TaintNodeCollections.set_of_list [n2] in table#set n1 set in let refeqnode = mk_ref_equal_node () in begin - addE fedges nd1 refeqnode ; - addE fedges nd2 refeqnode ; - addE bedges refeqnode nd1 ; + addE fedges nd1 refeqnode; + addE fedges nd2 refeqnode; + addE bedges refeqnode nd1; addE bedges refeqnode nd2 end - | TDefPut t -> + | TDefPut t -> let nd = get_node t in sources#add nd; let name = new symbol_t ~seqnr:cms#index (cms#name ^ (string_of_int cms#index)) in nd#set_stub_untrusted name; - | TRemove t -> () in - List.iter add_edge fsum#get_taint_elements ; + | TRemove _ -> () in + List.iter add_edge fsum#get_taint_elements; (fedges, bedges) in let (fedges, bedges) = add_edges fsum in let empty_taint_set = new TaintNodeCollections.set_t in @@ -271,17 +285,18 @@ let mk_lib_stub stub_name cms:JCHTGraph.taint_graph_t = ~sources -let get_lib_stub stub_name cmsig = - match lib_stub_table#get stub_name with +let get_lib_stub stub_name cmsig = + match lib_stub_table#get stub_name with | Some stub -> stub - | None -> + | None -> let stub = mk_lib_stub stub_name cmsig in - + (if !dbg then - pr__debug [STR "mk_lib_stub "; stub_name#toPretty; STR " "; - cmsig#toPretty; NL; stub#toPretty ; NL]); - - lib_stub_table#set stub_name stub ; + pr__debug [ + STR "mk_lib_stub "; stub_name#toPretty; STR " "; + cmsig#toPretty; NL; stub#toPretty; NL]); + + lib_stub_table#set stub_name stub; stub let tgraph_to_taint_elements @@ -291,64 +306,64 @@ let tgraph_to_taint_elements let pname = make_procname cmsix in if pname#getIndex <> proc_name#getIndex then None - else + else let jproc_info = JCHSystem.jsystem#get_jproc_info proc_name in let info = jproc_info#get_jvar_info v in - if JCHSystemUtils.is_return v then Some (JLocalVar (-1)) - else - match info#get_param_index with + if JCHSystemUtils.is_return v then Some (JLocalVar (-1)) + else + match info#get_param_index with | Some i -> Some (JLocalVar i) | _ -> None in let not_translated = ref false in - let add_taint_element (node1: taint_node_int) ls (node2: taint_node_int) = - match (node2#get_node_type, node1#get_node_type) with - | (TN_VAR v2, TN_VAR v1) -> + let add_taint_element (node1: taint_node_int) ls (node2: taint_node_int) = + match (node2#get_node_type, node1#get_node_type) with + | (TN_VAR v2, TN_VAR v1) -> begin - try - match (mk_jterm v1, mk_jterm v2) with + try + match (mk_jterm v1, mk_jterm v2) with | (Some t1, Some t2) -> (TTransfer (t1, t2)) :: ls - | _ -> not_translated := true ; ls + | _ -> not_translated := true; ls with _ -> ls (* In case the variable is exception_var *) end - | (TN_VAR v2, TN_FIELD _) -> + | (TN_VAR v2, TN_FIELD _) -> begin - try - not_translated := true ; - match mk_jterm v2 with + try + not_translated := true; + match mk_jterm v2 with | Some t2 -> (TDefPut t2) :: ls | _ -> ls with _ -> ls end - | (_, _) -> - not_translated := true ; + | (_, _) -> + not_translated := true; ls in - let add_taint_elements ls node1 = + let add_taint_elements ls node1 = let set = Option.get (edges#get node1) in List.fold_left (add_taint_element node1) ls set#toList in - let add_other_taint ls (node : taint_node_int) = - match node#get_node_type with - | TN_VAR v -> + let add_other_taint ls (node : taint_node_int) = + match node#get_node_type with + | TN_VAR v -> begin - try - match mk_jterm v with - | Some t -> + try + match mk_jterm v with + | Some t -> let nd = if node#get_untrusted_origins#get_origins = [] then TRemove t else - TDefPut t in + TDefPut t in nd :: ls - | _ -> not_translated := true ; ls - with _ -> ls - end + | _ -> not_translated := true; ls + with _ -> ls + end | _ -> ls in - if !not_translated then + if !not_translated then pr__debug [STR "tgraph_to_taint_elements could lose precision for "; - proc_name_pp proc_name; NL] ; + proc_name_pp proc_name; NL]; let nodes = edges#listOfKeys in let taint_els = List.fold_left add_taint_elements [] nodes in let taint_els = List.fold_left add_other_taint taint_els nodes in - JCHFunctionSummary.make_taint taint_els + JCHFunctionSummary.make_taint taint_els let get_all_stubs () = lib_stub_table#listOfValues diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.mli b/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.mli index 62a5f217..c5f07c4f 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphStubs.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -35,9 +35,9 @@ open JCHBasicTypesAPI (* jchpre *) open JCHPreAPI -val get_lib_stub : +val get_lib_stub : symbol_t -> class_method_signature_int -> JCHTGraph.taint_graph_t - + val tgraph_to_taint_elements : symbol_t -> JCHTGraph.taint_graph_t -> taint_int diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.ml b/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.ml index be5059f8..b3c742d7 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -26,9 +27,9 @@ ============================================================================= *) (* chlib *) -open CHLanguage +open CHLanguage open CHUtils -open CHPretty +open CHPretty (* chutil *) open CHLogger @@ -44,7 +45,7 @@ open JCHMethod open JCHPreAPI open JCHTaintOrigin -open JCHGlobals + open JCHTNode open JCHTGraph open JCHPrintUtils @@ -52,7 +53,7 @@ open JCHPrintUtils module H = Hashtbl let dbg = ref false -let set_dbg () = dbg := false; + class tgraph_transformer_t (tgraph: taint_graph_t) = object (self: 'a) @@ -61,12 +62,12 @@ class tgraph_transformer_t (tgraph: taint_graph_t) = val arg_nodes = tgraph#get_arg_nodes val return_node_opt = tgraph#get_return_node val ret_and_arg_nodes = tgraph#get_ret_and_arg_nodes - val fields = tgraph#get_fields + val fields = tgraph#get_fields val call_nodes = tgraph#get_call_nodes val calls = tgraph#get_calls val var_nodes = tgraph#get_var_nodes val edges = tgraph#get_edges - val rev_edges = tgraph#get_rev_edges + val rev_edges = tgraph#get_rev_edges val new_sig_nodes = ref [] val new_fields = ref (new TaintNodeCollections.set_t) @@ -76,33 +77,33 @@ class tgraph_transformer_t (tgraph: taint_graph_t) = val new_edges = ref (new TaintNodeCollections.table_t) val new_rev_edges = ref (new TaintNodeCollections.table_t) - method private add_table_edge table n1 n2 = + method private add_table_edge table n1 n2 = match table#get n1 with | Some set -> set#add n2 - | None -> + | None -> let set = TaintNodeCollections.set_of_list [n2] in table#set n1 set - + method add_edge rn wn = begin - self#add_table_edge !new_edges rn wn ; - self#add_table_edge !new_rev_edges wn rn + self#add_table_edge !new_edges rn wn; + self#add_table_edge !new_rev_edges wn rn end - - method transform = + + method transform = new_sig_nodes := sig_nodes - method make_tgraph = - self#transform ; - + method make_tgraph = + self#transform; + (if !dbg then pr__debug [STR "make_tgraph new_edges: "; NL; !new_edges#toPretty; NL; STR "make_tgraph new_rev_edges: "; NL; !new_rev_edges#toPretty; NL]); - + new taint_graph_t - ~proc_name + ~proc_name ~sig_nodes:!new_sig_nodes ~fields:!new_fields ~call_nodes:!new_call_nodes @@ -116,124 +117,125 @@ class tgraph_transformer_t (tgraph: taint_graph_t) = (* Removes nodes that are not tainted and are not sig_nodes or fields * Removes nodes that have no edges - * Removes unk_fields - the taint was already propagated and the fields + * Removes unk_fields - the taint was already propagated and the fields * cannot get any more taint *) -class stub_transformer_t (tgraph:taint_graph_t) = +class stub_transformer_t (tgraph:taint_graph_t) = object (self: 'a) inherit tgraph_transformer_t tgraph as super val not_unk_fields = new TaintNodeCollections.set_t - val field_edges = ref [] - method get_field_edges = !field_edges + val field_edges = ref [] + method get_field_edges = !field_edges - method private add_tedges = - let remove n = + method private add_tedges = + let remove n = let r = not (List.mem n sig_nodes || n#is_field) in - + (if !dbg then - pr__debug [STR "remove "; n#toPretty; STR " res: "; pp_bool r ; NL]) ; - + pr__debug [STR "remove "; n#toPretty; STR " res: "; pp_bool r; NL]); + r in let add_te (n1: taint_node_int) (n2: taint_node_int) = - + (if !dbg then - pr__debug [STR "add_te "; n1#toPretty; STR " "; n2#toPretty; NL]) ; - - match (remove n1, remove n2) with + pr__debug [STR "add_te "; n1#toPretty; STR " "; n2#toPretty; NL]); + + match (remove n1, remove n2) with | (false, false) -> - + (if !dbg then - pr__debug [STR "add_te do not remove"; NL]) ; - + pr__debug [STR "add_te do not remove"; NL]); + if n1#is_field && n2#is_field then - field_edges := (n1, n2) :: !field_edges + field_edges := (n1, n2) :: !field_edges else - super#add_edge n1 n2 + super#add_edge n1 n2 | _ -> () in let add_tes n set = set#iter (add_te n) in edges#iter add_tes - method transform = + method !transform = begin - self#add_tedges ; - new_sig_nodes := sig_nodes ; - new_fields := not_unk_fields ; - new_call_nodes := call_nodes ; - new_calls := calls + self#add_tedges; + new_sig_nodes := sig_nodes; + new_fields := not_unk_fields; + new_call_nodes := call_nodes; + new_calls := calls end - + end (* Uses the library stubs to remove the call nodes * for which there is a stub or remove all library calls * If unknown calls are removed than variables are connected to T * It also adds edegs to the call tgraph *) -class call_remover_t - (tgraph: taint_graph_t) +class call_remover_t + (tgraph: taint_graph_t) (tgraphs: (int, JCHTGraph.taint_graph_t) H.t) (calls_tgraphs: (int, JCHTGraph.taint_graph_t) H.t) (stub_tgraphs: (int, JCHTGraph.taint_graph_t) H.t) (procs_with_calls: SymbolCollections.set_t) = object (self: 'a) - inherit tgraph_transformer_t tgraph as super + inherit tgraph_transformer_t tgraph val removed = new TaintNodeCollections.set_t - val has_calls = ref false - val changed_calls = new SymbolCollections.set_t + val has_calls = ref false + val changed_calls = new SymbolCollections.set_t method has_calls = !has_calls method private remove_unknown_call tinfo snodes_opt str caller pc = - + (if !dbg then - pr__debug [STR "remove_unknown_call "; NL]) ; - + pr__debug [STR "remove_unknown_call "; NL]); + match snodes_opt with | Some snodes -> begin - + (if !dbg then - pr__debug [STR "snodes = "; snodes#toPretty; NL]) ; - - let add_unknown n = + pr__debug [STR "snodes = "; snodes#toPretty; NL]); + + let add_unknown n = match n#get_node_type with - | TN_VAR (_,v, _) -> - if not (v = JCHGlobals.exception_var) then + | TN_VAR (_,v, _) -> + if not (v = JCHGlobals.exception_var) then let origs = mk_taint_origin_set - [ mk_call_origin tinfo str caller pc ] in + [mk_call_origin tinfo str caller pc] in let _ = n#add_untrusted_origins origs in () | _ -> () in - snodes#iter add_unknown ; + snodes#iter add_unknown; end | None -> () method private record_call cproc_name iproc_name args = - + (if !dbg then pr__debug [STR "record_call "; cproc_name#toPretty; NL; - iproc_name#toPretty; STR " "; pp_list args; NL]) ; - - let calls_tgraph = + iproc_name#toPretty; STR " "; pp_list args; NL]); + + let calls_tgraph = try H.find calls_tgraphs iproc_name#getSeqNumber with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "calls taint graph for " ; iproc_name#toPretty ; - STR " not found in JCHTGraphTransformer.record_call" ])) in - + (LBLOCK [ + STR "calls taint graph for "; iproc_name#toPretty; + STR " not found in JCHTGraphTransformer.record_call"])) in + (if !dbg then pr__debug [STR "calls_tgraph#get_arg_nodes = "; - pp_list (calls_tgraph#get_arg_nodes); NL]) ; - + pp_list (calls_tgraph#get_arg_nodes); NL]); + let pairs = List.combine args calls_tgraph#get_arg_nodes in - let add_arg_edge (arg, iarg_node) = + let add_arg_edge (arg, iarg_node) = let arg_node = mk_var_node cproc_name arg in calls_tgraph#add_edge arg_node iarg_node in - List.iter add_arg_edge pairs + List.iter add_arg_edge pairs method private remove_known_call tnode @@ -243,202 +245,204 @@ class call_remover_t (call_vars: variable_t list) (igraph: taint_graph_t) pc = - + (if !dbg then - pr__debug [STR "remove_known_call "; cname#toPretty; STR " " ; - STR iname ; STR " "; pp_list call_vars ; NL; - igraph#toPretty; NL]) ; - + pr__debug [STR "remove_known_call "; cname#toPretty; STR " "; + STR iname; STR " "; pp_list call_vars; NL; + igraph#toPretty; NL]); + let mk_node v = mk_var_node cname v in let call_nodes = List.map mk_node call_vars in - + (if !dbg then - pr__debug [STR "call_nodes = "; pp_list call_nodes; NL]) ; - + pr__debug [STR "call_nodes = "; pp_list call_nodes; NL]); + let inodes = igraph#get_ret_and_arg_nodes in - + (if !dbg then - pr__debug [STR "inodes = "; pp_list inodes; NL]) ; - + pr__debug [STR "inodes = "; pp_list inodes; NL]); + let iedges = igraph#get_edges in - let pairs = - try - List.combine inodes call_nodes - with _ -> + let pairs = + try + List.combine inodes call_nodes + with _ -> begin pr_debug [STR "Call does not match signature. "; NL; STR "remove_known_call has lists of different sizes "; cname#toPretty; STR " "; pp_list call_vars; NL; - igraph#toPretty; NL; + igraph#toPretty; NL; STR "inodes "; pp_list inodes; NL; STR " call_nodes "; - pp_list call_nodes; NL ] ; - ch_error_log#add "invocation argument mismatch" cname#toPretty ; - raise (JCH_failure (STR "Call does not match signature.")) - end in - let getCNode inode = - let is_return = - match inode#get_node_type with + pp_list call_nodes; NL]; + ch_error_log#add "invocation argument mismatch" cname#toPretty; + raise (JCH_failure (STR "Call does not match signature.")) + end in + let getCNode inode = + let is_return = + match inode#get_node_type with | TN_VAR (_, v, _) -> v#getName#getBaseName = "return" | _ -> false in - if List.mem_assoc inode pairs then + if List.mem_assoc inode pairs then (is_return, List.assq inode pairs) else (is_return, inode) in - let add_edge in1 set = + let add_edge in1 set = let (_, cn1) = getCNode in1 in let add_e in2 = - + (if !dbg then - pr__debug [STR "add_edge "; in1#toPretty; STR " "; in2#toPretty; NL]) ; - + pr__debug [STR "add_edge "; in1#toPretty; STR " "; in2#toPretty; NL]); + let (is_ret, cn2) = getCNode in2 in - if not is_ret && cn2#is_immutable && iname <> "" then + if not is_ret && cn2#is_immutable && iname <> "" then begin if !dbg then pr__debug [STR "cn2 = "; cn2#toPretty; - STR " is_arg and is immutable and is not init"; NL] + STR " is_arg and is immutable and is not init"; NL] end else self#add_edge cn1 cn2 in set#iter add_e in - iedges#iter add_edge ; - - let add_taint_origins (inode, call_node) = + iedges#iter add_edge; + + let add_taint_origins (inode, call_node) = let _ = call_node#add_untrusted_origins (inode#get_untrusted_origins) in - if is_stub then + if is_stub then match JCHTNode.set_stub_origins cname pc tnode inode call_node with | Some stub_node -> self#add_edge stub_node call_node | _ -> () in List.iter add_taint_origins pairs - - + method private record_unknown_call_edges (cproc_name: symbol_t) (call_vars: variable_t list) (iproc_name: symbol_t) = - + (if !dbg then pr__debug [STR "record_unknown_call_edges "; - cproc_name#toPretty; STR " "; iproc_name#toPretty; NL]) ; - + cproc_name#toPretty; STR " "; iproc_name#toPretty; NL]); + (if !dbg then - pr__debug [STR "call_vars: "; pp_list call_vars; NL]) ; - - has_calls := true ; + pr__debug [STR "call_vars: "; pp_list call_vars; NL]); + + has_calls := true; let jproc_info = JCHSystem.jsystem#get_jproc_info cproc_name in let mk_node v = mk_var_node cproc_name v in let call_nodes = List.map mk_node call_vars in - let igraph = + let igraph = try H.find tgraphs iproc_name#getSeqNumber with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "graph not found for " ; iproc_name#toPretty ; - STR " in JCHTGraphTransformer.record_unknown_call_edges" ])) in - + (LBLOCK [ + STR "graph not found for "; iproc_name#toPretty; + STR " in JCHTGraphTransformer.record_unknown_call_edges"])) in + (if !dbg then - pr__debug [STR "igraph: = "; NL; igraph#toPretty; NL]) ; - + pr__debug [STR "igraph: = "; NL; igraph#toPretty; NL]); + let inodes = igraph#get_ret_and_arg_nodes in let pairs = List.combine inodes call_nodes in - let get_var inode = - match inode#get_node_type with + let get_var inode = + match inode#get_node_type with | TN_VAR (_, v, _) -> v | _ -> raise (JCH_failure (STR "record_unknown_call_edges expected variable node ")) in - let is_return inode = + let is_return inode = let iv = get_var inode in iv#getName#getBaseName = "return"in let add_edge (inode, call_node) = - + (if !dbg then pr__debug [STR "add_edge "; inode#toPretty; STR " "; - call_node#toPretty; NL]) ; - - if is_return inode then self#add_edge inode call_node - else + call_node#toPretty; NL]); + + if is_return inode then self#add_edge inode call_node + else begin - self#add_edge call_node inode ; - + self#add_edge call_node inode; + (if !dbg then pr__debug [STR "after self#add_edge "; NL]); - + let is_immutable = - + (if !dbg then pr__debug [STR "before get_var "; NL]); - + let cv = get_var call_node in - + (if !dbg then pr__debug [STR "after get_var "; cv#toPretty; NL]); - + let vtypes = (jproc_info#get_jvar_info cv)#get_types in - + (if !dbg then pr__debug [STR "after vtypes "; NL]); - + JCHTypeUtils.is_immutable_type vtypes in if not is_immutable then - self#add_edge inode call_node + self#add_edge inode call_node end in - List.iter add_edge pairs + List.iter add_edge pairs method private remove_proc_call tnode cinfo iinfo args pc = - + (if !dbg then pr__debug [NL; STR "remove_proc_call "; tnode#toPretty; NL; cinfo#toPretty; NL; iinfo#toPretty; NL; - pp_list args; NL]) ; - - let cproc_name = cinfo#get_procname in - let iproc_name = iinfo#get_procname in + pp_list args; NL]); + + let cproc_name = cinfo#get_procname in + let iproc_name = iinfo#get_procname in if JCHSystem.jsystem#not_analyzed iproc_name#getSeqNumber then - + (if !dbg then - pr__debug [STR "iinfo failed in analysis || does not need to be analyzed "; - NL]) - + pr__debug [ + STR "iinfo failed in analysis || does not need to be analyzed "; + NL]) + else - self#record_call cproc_name iproc_name args ; - try + self#record_call cproc_name iproc_name args; + try begin - let igraph = + let igraph = try H.find stub_tgraphs iproc_name#getSeqNumber with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "graph for " ; iproc_name#toPretty ; - STR " not found in JCHTGraphTransformer.remove_proc_call" ])) in - if procs_with_calls#has iproc_name then + (LBLOCK [ + STR "graph for "; iproc_name#toPretty; + STR " not found in JCHTGraphTransformer.remove_proc_call"])) in + if procs_with_calls#has iproc_name then begin (if !dbg then pr__debug [STR "the called graph has calls cproc_name: "; cproc_name#toPretty; STR " iproc_name: "; iproc_name#toPretty; NL; - igraph#toPretty; NL]) ; - + igraph#toPretty; NL]); + self#record_unknown_call_edges - cproc_name tnode#get_call_vars iproc_name + cproc_name tnode#get_call_vars iproc_name end else begin - + (if !dbg then pr__debug [STR "called method has stub: "; - igraph#toPretty; NL]) ; - !new_fields#addSet igraph#get_fields ; + igraph#toPretty; NL]); + !new_fields#addSet igraph#get_fields; let iname = (iinfo#get_class_method_signature)#name in - try + try self#remove_known_call - tnode false cproc_name iname tnode#get_call_vars igraph pc ; - removed#add tnode - with _ -> + tnode false cproc_name iname tnode#get_call_vars igraph pc; + removed#add tnode + with _ -> self#remove_unknown_call iinfo (edges#get tnode) "method not analyzed" @@ -446,156 +450,155 @@ class call_remover_t pc (* in case that method was not analyzed *) end end - with _ -> + with _ -> begin - + (if !dbg then - pr__debug [STR "no stub for the called method"; NL]) ; - - if JCHSystem.jsystem#not_analyzed iproc_name#getSeqNumber then - begin + pr__debug [STR "no stub for the called method"; NL]); + + if JCHSystem.jsystem#not_analyzed iproc_name#getSeqNumber then + begin self#remove_unknown_call iinfo (edges#get tnode) "missing stub" cproc_name pc - end - else + end + else self#record_unknown_call_edges - cproc_name tnode#get_call_vars iproc_name + cproc_name tnode#get_call_vars iproc_name end method private remove_stub_call tnode cinfo iinfo args pc = - + (if !dbg then - pr__debug [STR "remove_stub_call "; tnode#toPretty; NL; + pr__debug [STR "remove_stub_call "; tnode#toPretty; NL; STR " "; pp_list args; NL; - STR "cinfo = "; cinfo#toPretty; NL; - STR "iinfo = "; iinfo#toPretty; NL]) ; - + STR "cinfo = "; cinfo#toPretty; NL; + STR "iinfo = "; iinfo#toPretty; NL]); + let cproc_name = cinfo#get_procname in let iproc_name = iinfo#get_procname in let icmsig = iinfo#get_class_method_signature in let iname = icmsig#name in - + (if !dbg then - pr__debug [STR "before get_lib_stub "; NL]) ; - + pr__debug [STR "before get_lib_stub "; NL]); + let lgraph = JCHTGraphStubs.get_lib_stub iproc_name icmsig in - + (if !dbg then - pr__debug [STR "lgraph = "; NL; lgraph#toPretty; NL]) ; - - try + pr__debug [STR "lgraph = "; NL; lgraph#toPretty; NL]); + + try self#remove_known_call - tnode true cproc_name iname tnode#get_call_vars lgraph pc ; - removed#add tnode ; + tnode true cproc_name iname tnode#get_call_vars lgraph pc; + removed#add tnode; with _ -> self#remove_unknown_call iinfo (edges#get tnode) "remove known call failed" cproc_name pc - method private remove_call tnode = - match tnode#get_node_type with + method private remove_call tnode = + match tnode#get_node_type with | TN_CALL (_,pc, callerix, tgtix, _, args) -> let tinfo = app#get_method (retrieve_cms tgtix) in let cinfo = app#get_method (retrieve_cms callerix) in begin match tinfo#get_implementation with | ConcreteMethod m -> - + (if !dbg then - pr__debug [implementation_to_pretty m#get_implementation]) ; - + pr__debug [implementation_to_pretty m#get_implementation]); + self#remove_proc_call tnode cinfo tinfo args pc; - + (if !dbg then pr__debug [STR "finished remove_proc_call"; NL; !new_edges#toPretty; NL]) - - | JCHPreAPI.Stub _ -> + + | JCHPreAPI.Stub _ -> self#remove_stub_call tnode cinfo tinfo args pc; - + (if !dbg then pr__debug [STR "finished remove_stub_call"; NL; !new_edges#toPretty; NL]) - + | _ -> raise (JCH_failure (STR "encountered method neither concrete nor stub ")) end - - | TN_UNKNOWN_CALL (_, pc, cinfo, _, args) -> + + | TN_UNKNOWN_CALL (_, _pc, _cinfo, _, _args) -> begin - match (edges#get tnode, rev_edges#get tnode) with - | (Some succs, Some preds) -> + match (edges#get tnode, rev_edges#get tnode) with + | (Some succs, Some preds) -> List.iter2 self#add_edge preds#toList succs#toList - | _ -> () + | _ -> () end - | _ -> + | _ -> () method add_some_edges n set = - + (if !dbg then - pr__debug [STR "add_some_edges "; n#toPretty; STR " "; set#toPretty; NL]) ; - + pr__debug [STR "add_some_edges "; n#toPretty; STR " "; set#toPretty; NL]); + if removed#has n then () - else + else let not_removed m = not (removed#has m) in let nodes = List.filter not_removed set#toList in - List.iter (self#add_edge n) nodes - - - method transform = - new_sig_nodes := sig_nodes ; - !new_fields#addSet fields ; - calls#iter self#remove_call ; - + List.iter (self#add_edge n) nodes + + method !transform = + new_sig_nodes := sig_nodes; + !new_fields#addSet fields; + calls#iter self#remove_call; + (if !dbg then - pr__debug [STR "after remove_call"; NL; !new_edges#toPretty; NL]) ; - - edges#iter self#add_some_edges ; - + pr__debug [STR "after remove_call"; NL; !new_edges#toPretty; NL]); + + edges#iter self#add_some_edges; + (if !dbg then - pr__debug [STR "after add_some_edges"; NL; !new_edges#toPretty; NL]) ; - end + pr__debug [STR "after add_some_edges"; NL; !new_edges#toPretty; NL]); + end -class prune_var_transformer_t (tgraph: taint_graph_t) = +class prune_var_transformer_t (tgraph: taint_graph_t) = object (self: 'a) - inherit tgraph_transformer_t tgraph as super + inherit tgraph_transformer_t tgraph -(* collects reachable nodes but stops at call vars and fields +(* collects reachable nodes but stops at call vars and fields * it is not clear what type of dependency it is until * the summary of the call is available *) method private get_reachables - forward (node: taint_node_int) : TaintNodeCollections.set_t = + forward (node: taint_node_int) : TaintNodeCollections.set_t = let reachable = new TaintNodeCollections.set_t in - let rec work start ns = - match ns with + let rec work start ns = + match ns with | n :: rest_ns -> - + (if !dbg then pr__debug [STR "prune_var_transformer get_reachable work "; - n#toPretty; NL]) ; - - if reachable#has n then + n#toPretty; NL]); + + if reachable#has n then work false rest_ns - else + else begin - reachable#add n ; - if not start && (call_nodes#has n) then + reachable#add n; + if not start && (call_nodes#has n) then work false rest_ns - else - let table = if forward then edges else rev_edges in - match table#get n with - | Some set -> + else + let table = if forward then edges else rev_edges in + match table#get n with + | Some set -> work false (List.rev_append (rest_ns) (set#toList)) - | None -> + | None -> work false rest_ns end - | [] -> + | [] -> () in begin - work true [node] ; - reachable#remove node ; + work true [node]; + reachable#remove node; reachable end @@ -603,71 +606,73 @@ object (self: 'a) * and vars that are intermediary * Does not prune vars in a call, fields, calls and vars from other methods * Prunes vars that are not reachable from any of the above *) - method transform = - + method !transform = + (if !dbg then - pr__debug [STR "prune_vars "; NL]) ; - - let add_es forward n = - let reach = self#get_reachables forward n in - let keep m = - match m#get_node_type with + pr__debug [STR "prune_vars "; NL]); + + let add_es forward n = + let reach = self#get_reachables forward n in + let keep m = + match m#get_node_type with | TN_FIELD _ | TN_CALL _ -> true - | TN_VAR (cmsix, v, _) -> - cmsix = proc_name#getIndex || (List.mem m sig_nodes) || call_nodes#has m + | TN_VAR (cmsix, _v, _) -> + cmsix = proc_name#getIndex || (List.mem m sig_nodes) || call_nodes#has m | _ -> false in let kreach = List.filter keep reach#toList in let add n m = if forward then self#add_edge n m else self#add_edge m n in List.iter (add n) kreach in - List.iter (add_es true) (sig_nodes @ fields#toList) ; + List.iter (add_es true) (sig_nodes @ fields#toList); begin - match return_node_opt with + match return_node_opt with | Some return -> add_es false return - | None -> () - end ; - new_sig_nodes := sig_nodes ; - fields#iter (add_es true) ; - call_nodes#iter (add_es true) ; - calls#iter (add_es true) ; - new_fields := fields ; - new_call_nodes := call_nodes ; - new_calls := calls - + | None -> () + end; + new_sig_nodes := sig_nodes; + fields#iter (add_es true); + call_nodes#iter (add_es true); + calls#iter (add_es true); + new_fields := fields; + new_call_nodes := call_nodes; + new_calls := calls + end + class graph_env_maker_t tgraph env_graph = object (self: 'a) inherit tgraph_transformer_t tgraph as super - val name = tgraph#get_proc_name + val name = tgraph#get_proc_name - method private add_rev_env_edge (wn: taint_node_int) (env_n: taint_node_int) = - super#add_edge env_n wn ; + method private add_rev_env_edge (wn: taint_node_int) (env_n: taint_node_int) = + super#add_edge env_n wn; let _ = wn#add_untrusted_origins (env_n#get_untrusted_origins) in () - - method private add_env_edges n = - match env_graph#get_rev_edges#get n with - | Some set -> + + method private add_env_edges n = + match env_graph#get_rev_edges#get n with + | Some set -> set#iter (self#add_rev_env_edge n) - | None -> + | None -> () - method transform = - let add_edges n set = + method !transform = + let add_edges n set = set#iter (super#add_edge n) in begin - new_sig_nodes := sig_nodes ; - !new_fields#addSet tgraph#get_fields ; - !new_call_nodes#addSet tgraph#get_call_nodes ; - !new_calls#addSet tgraph#get_calls ; - edges#iter add_edges ; - List.iter self#add_env_edges arg_nodes ; + new_sig_nodes := sig_nodes; + !new_fields#addSet tgraph#get_fields; + !new_call_nodes#addSet tgraph#get_call_nodes; + !new_calls#addSet tgraph#get_calls; + edges#iter add_edges; + List.iter self#add_env_edges arg_nodes; end end + (* Propagates taint on the given local tgraph *) -class taint_propagator_t (tgraph: taint_graph_t) = +class taint_propagator_t (tgraph: taint_graph_t) = object (self: 'a) val edges = tgraph#get_edges @@ -675,44 +680,45 @@ class taint_propagator_t (tgraph: taint_graph_t) = (* propagates the taint of one node *) method private propagate_taint (node : taint_node_int) = - + let _ = if !dbg then - pr__debug [STR "propagate_taint "; STR " " ; node#toPretty; NL] in - + pr__debug [STR "propagate_taint "; STR " "; node#toPretty; NL] in + let get_next_nodes n = if n#is_loop_counter_var || n#is_conditional then [] else begin match edges#get n with - | Some set -> + | Some set -> let ns = ref [] in let add_node n' = if n#propagate_taint n' then ns := n' :: !ns in begin - set#iter add_node ; + set#iter add_node; !ns end | _ -> [] end in - let rec work ns = - match ns with - | n :: rest_ns -> + let rec work ns = + match ns with + | n :: rest_ns -> (if !dbg then - pr__debug [STR "taint_propagator get_reachable work "; n#toPretty; NL]) ; - + pr__debug [ + STR "taint_propagator get_reachable work "; n#toPretty; NL]); + let new_nodes = get_next_nodes n in work (List.rev_append (rest_ns) new_nodes) | [] -> () in - work [node] - - method transform = + work [node] + + method transform = let nodes = edges#listOfKeys in - List.iter self#propagate_taint nodes ; - (* values are tainted first so we can taint the bounds of the + List.iter self#propagate_taint nodes; + (* values are tainted first so we can taint the bounds of the * loop counter before the taint on bounds is propagated *) end @@ -722,18 +728,18 @@ class taint_propagator_t (tgraph: taint_graph_t) = * In case the method could be invoked by library methods, * the inputs might be tainted in these calls, so tainted nodes are * added as inputs here *) -let init_calls_graph tgraph = +let init_calls_graph tgraph = let new_tgraph = (new tgraph_transformer_t tgraph)#make_tgraph in new_tgraph -let make_stub tgraph = +let make_stub tgraph = let transformer = (new stub_transformer_t tgraph) in let tgraph = transformer#make_tgraph in let field_edges = transformer#get_field_edges in (tgraph, field_edges) let remove_calls - tgraph tgraphs calls_tgraphs stub_tgraphs procs_with_calls = + tgraph tgraphs calls_tgraphs stub_tgraphs procs_with_calls = let transformer = new call_remover_t tgraph tgraphs calls_tgraphs stub_tgraphs procs_with_calls in @@ -741,16 +747,16 @@ let remove_calls let has_calls = transformer#has_calls in (tgraph, has_calls) -let prune_vars tgraph = - let p = +let prune_vars tgraph = + let p = (new prune_var_transformer_t tgraph)#make_tgraph in - + (if !dbg then - pr__debug [STR "p = "; NL; p#toPretty; NL]) ; + pr__debug [STR "p = "; NL; p#toPretty; NL]); p -let make_env tgraph env_graph = +let make_env tgraph env_graph = (new graph_env_maker_t tgraph env_graph)#make_tgraph -let propagate_taint tgraph = +let propagate_taint tgraph = (new taint_propagator_t tgraph)#transform diff --git a/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.mli b/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.mli index 8bd787cd..accc4dc6 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTGraphTransformers.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -28,25 +29,25 @@ (* jchpre *) open JCHPreAPI -val init_calls_graph : JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t +val init_calls_graph : JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t val make_stub : JCHTGraph.taint_graph_t -> (JCHTGraph.taint_graph_t * (taint_node_int * taint_node_int) list) -val remove_calls : - JCHTGraph.taint_graph_t +val remove_calls : + JCHTGraph.taint_graph_t -> (int, JCHTGraph.taint_graph_t) Hashtbl.t -> (int, JCHTGraph.taint_graph_t) Hashtbl.t -> (int, JCHTGraph.taint_graph_t) Hashtbl.t - -> CHUtils.SymbolCollections.set_t + -> CHUtils.SymbolCollections.set_t -> JCHTGraph.taint_graph_t * bool - + val prune_vars: JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t - + val make_env: - JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t + JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t -> JCHTGraph.taint_graph_t val propagate_taint : JCHTGraph.taint_graph_t -> unit diff --git a/CodeHawk/CHJ/jchpoly/jCHTNode.ml b/CodeHawk/CHJ/jchpoly/jCHTNode.ml index d4d0da02..f0d29937 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTNode.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTNode.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHTNode.mli b/CodeHawk/CHJ/jchpoly/jCHTNode.mli index 88d9e127..1011f6bd 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTNode.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTNode.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.ml b/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.ml index 64c57595..1309baa5 100755 --- a/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -27,9 +28,6 @@ (* chlib *) open CHPretty -open CHPrettyUtil -open CHLanguage -open CHUtils (* jchlib *) open JCHBasicTypes @@ -42,181 +40,189 @@ open JCHPreAPI (* jchsys *) open JCHGlobals open JCHPrintUtils -open JCHSystemUtils module H = Hashtbl -let dbg = ref false let tgraphs = ref (Hashtbl.create 0) let taint_origin_ind = ref (-1) -let unknown_rev_edges = ref (new JCHTNode.TaintNodeCollections.table_t) +let _unknown_rev_edges = ref (new JCHTNode.TaintNodeCollections.table_t) let untrusted_rev_edges = ref (new JCHTNode.TaintNodeCollections.table_t) (* populates untrusted_origin_to_rev_edges *) let make_taint_origin_graphs taint_origin_index = - tgraphs := JCHTGraphAnalysis.get_tgraphs () ; - taint_origin_ind := taint_origin_index ; + tgraphs := JCHTGraphAnalysis.get_tgraphs (); + taint_origin_ind := taint_origin_index; untrusted_rev_edges := new JCHTNode.TaintNodeCollections.table_t; let add_edge node1 node2 = if node1#compare node2 != 0 then begin - pr__debug [STR "add_edge "; node1#toPretty; STR " "; node2#toPretty; NL]; + pr__debug [STR "add_edge "; node1#toPretty; STR " "; node2#toPretty; NL]; let (rev_edges, set1, set2) = let untrusted1 = node1#get_untrusted_origins in - let untrusted2 = node2#get_untrusted_origins in + let untrusted2 = node2#get_untrusted_origins in (!untrusted_rev_edges, untrusted1, untrusted2) in let has_taint set = set#has_origin_index taint_origin_index in if has_taint set1 && has_taint set2 then match rev_edges#get node2 with | Some set -> set#add node1 - | _ -> rev_edges#set node2 (JCHTNode.TaintNodeCollections.set_of_list [node1]) + | _ -> + rev_edges#set node2 (JCHTNode.TaintNodeCollections.set_of_list [node1]) end in let add_graph tgraph = - + pr__debug [NL; NL; STR "mk_taint_origin_graphs add_graph "; - tgraph#get_proc_name#toPretty; NL; tgraph#toPretty; NL] ; - + tgraph#get_proc_name#toPretty; NL; tgraph#toPretty; NL]; + let graph_edges: JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t = tgraph#get_edges in let add_graph_edge node1 node2 = - - pr__debug [STR "add_graph_edge "; node1#toPretty; STR " "; node2#toPretty; NL] ; - + + pr__debug [ + STR "add_graph_edge "; node1#toPretty; STR " "; node2#toPretty; NL]; + begin - match (node1#get_node_type, node2#get_node_type) with + match (node1#get_node_type, node2#get_node_type) with | (TN_VAR (cmsix , v, _), TN_CALL (_, _, _, tgtix, ret_opt, args)) -> let pn = make_procname cmsix in let tinfo = JCHApplication.app#get_method (retrieve_cms tgtix) in let tproc_name = tinfo#get_procname in - if tinfo#is_stubbed then + if tinfo#is_stubbed then begin let tgraph = - JCHTGraphStubs.get_lib_stub tproc_name tinfo#get_class_method_signature in + JCHTGraphStubs.get_lib_stub + tproc_name tinfo#get_class_method_signature in let arg_nodes = tgraph#get_arg_nodes in try (* For the case v is a return node *) let arg_node = List.assoc v (List.combine args arg_nodes) in - let succ_stub_nodes = - match tgraph#get_edges#get arg_node with + let succ_stub_nodes = + match tgraph#get_edges#get arg_node with | Some set -> set#toList | _ -> [] in - let get_arg_node stub_node : taint_node_int = + let get_arg_node stub_node : taint_node_int = match stub_node#get_node_type with - | TN_VAR (_, v, _) -> - let var = + | TN_VAR (_, v, _) -> + let var = if JCHSystemUtils.is_return v then Option.get ret_opt else List.assoc stub_node (List.combine arg_nodes args) in - JCHTNode.mk_var_node pn var + JCHTNode.mk_var_node pn var | _ -> stub_node in let succ_nodes = List.map get_arg_node succ_stub_nodes in - List.iter (add_edge node1) succ_nodes + List.iter (add_edge node1) succ_nodes with _ -> () end - else + else begin - let tgraph = + let tgraph = try H.find !tgraphs tproc_name#getSeqNumber with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "taint graph for " ; tproc_name#toPretty ; - STR " not found in JCHTGraphAnalysis.mk_taint_origin_graph" ])) in + (LBLOCK [ + STR "taint graph for "; tproc_name#toPretty; + STR " not found in JCHTGraphAnalysis.mk_taint_origin_graph"])) in let arg_nodes = tgraph#get_arg_nodes in let pairs = List.combine args arg_nodes in begin try (* This is a return node *) let arg_node = List.assoc v pairs in - add_edge node1 arg_node + add_edge node1 arg_node with _ -> () end end - | (TN_CALL (_, _, callerix, tgtix, ret_opt, args), TN_VAR(_, v, _)) -> + | (TN_CALL (_, _, _callerix, tgtix, _ret_opt, args), TN_VAR (_, v, _)) -> let tinfo = app#get_method (retrieve_cms tgtix) in let tproc_name = tinfo#get_procname in - if tinfo#is_stubbed then + if tinfo#is_stubbed then begin - let tgraph = JCHTGraphStubs.get_lib_stub tproc_name tinfo#get_class_method_signature in - let add_source source = - let _ = node1#add_untrusted_origins source#get_untrusted_origins in + let tgraph = + JCHTGraphStubs.get_lib_stub + tproc_name tinfo#get_class_method_signature in + let add_source source = + let _ = + node1#add_untrusted_origins source#get_untrusted_origins in () in - tgraph#get_sources#iter add_source ; - - add_edge node1 node2 ; - end + tgraph#get_sources#iter add_source; + + add_edge node1 node2; + end else begin let tgraph = H.find !tgraphs tproc_name#getSeqNumber in - try (* This is an argument node which could get tainted in the calling - * method but we do not cover that yet *) + try (* This is an argument node which could get tainted in the + * calling method but we do not cover that yet *) let ret_node = Option.get tgraph#get_return_node in let ref_eq_node = JCHTNode.mk_ref_equal_node () in - add_edge ret_node ref_eq_node ; - add_edge ref_eq_node node2 - with _ -> + add_edge ret_node ref_eq_node; + add_edge ref_eq_node node2 + with _ -> let arg_nodes = tgraph#get_arg_nodes in let pairs = List.combine args arg_nodes in let arg_node = List.assoc v pairs in let ref_eq_node = JCHTNode.mk_ref_equal_node () in - add_edge arg_node ref_eq_node ; - add_edge ref_eq_node node2 - end - | _ -> add_edge node1 node2 + add_edge arg_node ref_eq_node; + add_edge ref_eq_node node2 + end + | _ -> add_edge node1 node2 end in graph_edges#iter (fun n s -> s#iter (add_graph_edge n)) in let (procs, _) = JCHSystem.jsystem#get_call_graph_manager#get_bottom_up_list in - - List.iter (fun proc_name -> add_graph (H.find !tgraphs proc_name#getSeqNumber)) procs ; - - pr__debug [NL; STR "after make_taint_origin_graphs, untrusted_origin_to_rev_edges = "; - !untrusted_rev_edges#toPretty; NL] + + List.iter (fun proc_name -> + add_graph (H.find !tgraphs proc_name#getSeqNumber)) procs; + + pr__debug [ + NL; STR "after make_taint_origin_graphs, untrusted_origin_to_rev_edges = "; + !untrusted_rev_edges#toPretty; NL] - -let remove_stack_vars edges rev_edges = - let get_assoc table node = - match table#get node with +let remove_stack_vars edges rev_edges = + let get_assoc table node = + match table#get node with | Some set -> set#toList | _ -> [] in - let remove_from_table table node keys = - let remove_key key = - match table#get key with + let remove_from_table table node keys = + let remove_key key = + match table#get key with | Some set -> set#remove node | _ -> () in List.iter remove_key keys; table#remove node in - let add_edge_t table node1 node2 = - match table#get node1 with - | Some set -> set#add node2 + let add_edge_t table node1 node2 = + match table#get node1 with + | Some set -> set#add node2 | _ -> table#set node1 (JCHTNode.TaintNodeCollections.set_of_list [node2]) in - let add_edge table rev_table node1 node2 = - add_edge_t table node1 node2 ; + let add_edge table rev_table node1 node2 = + add_edge_t table node1 node2; add_edge_t rev_table node2 node1 in - let remove node = - let prevs = List.filter (fun n -> (node#compare n) <> 0) (get_assoc rev_edges node) in - let succs = List.filter (fun n -> (node#compare n) <> 0) (get_assoc edges node) in - remove_from_table edges node prevs ; - remove_from_table rev_edges node succs ; - + let remove node = + let prevs = + List.filter (fun n -> (node#compare n) <> 0) (get_assoc rev_edges node) in + let succs = + List.filter (fun n -> (node#compare n) <> 0) (get_assoc edges node) in + remove_from_table edges node prevs; + remove_from_table rev_edges node succs; + List.iter (fun n1 -> List.iter (add_edge edges rev_edges n1) succs) prevs in let nodes = new JCHTNode.TaintNodeCollections.set_t in - nodes#addList edges#listOfKeys ; - nodes#addList rev_edges#listOfKeys ; + nodes#addList edges#listOfKeys; + nodes#addList rev_edges#listOfKeys; - let not_needed node = + let not_needed node = match node#get_node_type with | TN_VAR (cmsix, v, _) -> let pn = make_procname cmsix in @@ -233,18 +239,18 @@ let remove_stack_vars edges rev_edges = let nodes_to_remove = List.filter not_needed nodes#toList in - List.iter remove nodes_to_remove ; + List.iter remove nodes_to_remove; let new_edges = new JCHTNode.TaintNodeCollections.table_t in let new_rev_edges = new JCHTNode.TaintNodeCollections.table_t in - let remove_version_var var = + let remove_version_var var = if JCHSystemUtils.is_loop_counter var then var else make_variable var#getName#getBaseName var#getType in - let remove_version_node node = + let remove_version_node node = match node#get_node_type with | TN_VAR (cmsix, v, pc) -> let pn = make_procname cmsix in - let orig_node = - try + let orig_node = + try let index = v#getIndex in let var_map = (Option.get @@ -258,75 +264,81 @@ let remove_stack_vars edges rev_edges = let _ = node#add_all_untrusted_origins orig_node in orig_node | _ -> node in - let remove_version_edges node1 set = + let remove_version_edges node1 set = let new_node1 = remove_version_node node1 in - let remove_version_edge node2 = + let remove_version_edge node2 = add_edge new_edges new_rev_edges new_node1 (remove_version_node node2) in set#iter remove_version_edge in - edges#iter remove_version_edges ; + edges#iter remove_version_edges; (new_edges, new_rev_edges) -let make_graph () = - let reverse_edges rev_edges = +let make_graph () = + let reverse_edges rev_edges = let edges = new JCHTNode.TaintNodeCollections.table_t in let add_edges node prev_nodes = - let add_edge prev_node = + let add_edge prev_node = match edges#get prev_node with | Some set -> set#add node | _ -> let set = JCHTNode.TaintNodeCollections.set_of_list [node] in edges#set prev_node set in prev_nodes#iter add_edge in - rev_edges#iter add_edges ; + rev_edges#iter add_edges; edges in - let (rev_edges, edges) = (untrusted_rev_edges, ref (reverse_edges !untrusted_rev_edges)) in + let (rev_edges, edges) = + (untrusted_rev_edges, ref (reverse_edges !untrusted_rev_edges)) in let (_, res) = (remove_stack_vars !edges !rev_edges) in - rev_edges := res ; - edges := reverse_edges !rev_edges ; - let remove_empty table node set = + rev_edges := res; + edges := reverse_edges !rev_edges; + let remove_empty table node set = if set#isEmpty then table#remove node in !rev_edges#iter (remove_empty !rev_edges); - !edges#iter (remove_empty !edges) ; - + !edges#iter (remove_empty !edges); + let taint_origin = JCHTaintOrigin.get_taint_origin !taint_origin_ind in - let found node = - match (taint_origin#get_origin, node#get_node_type) with + let found node = + match (taint_origin#get_origin, node#get_node_type) with | (T_ORIG_FIELD (cfsix1, _, _, _), TN_FIELD cfsix2) -> cfsix1 = cfsix2 - | (T_ORIG_VAR (cmsix1, v1), TN_VAR (cmsix2, v2, _)) -> cmsix1 = cmsix2 && v1#equal v2 - | (T_ORIG_CALL (cmsix, _, _, _), TN_CALL (_, _, _, tgtix , _, _)) -> cmsix = tgtix - | (T_ORIG_STUB (cmsix, _, _), TN_CALL (_, _, _, tgtix, _, _)) -> cmsix = tgtix + | (T_ORIG_VAR (cmsix1, v1), TN_VAR (cmsix2, v2, _)) -> + cmsix1 = cmsix2 && v1#equal v2 + | (T_ORIG_CALL (cmsix, _, _, _), TN_CALL (_, _, _, tgtix , _, _)) -> + cmsix = tgtix + | (T_ORIG_STUB (cmsix, _, _), TN_CALL (_, _, _, tgtix, _, _)) -> + cmsix = tgtix | _ -> false in let new_edges = new JCHTNode.TaintNodeCollections.table_t in let added = ref [] in let rec work ns = match ns with - | n :: rest_ns -> + | n :: rest_ns -> if not (List.mem n !added) then begin - added := n :: !added ; + added := n :: !added; match !edges#get n with | Some succs -> - new_edges#set n succs ; + new_edges#set n succs; work (succs#toList @ rest_ns) | _ -> work rest_ns end else work rest_ns | _ -> () in - work (List.filter found !edges#listOfKeys) ; - rev_edges := reverse_edges new_edges ; + work (List.filter found !edges#listOfKeys); + rev_edges := reverse_edges new_edges; - pr__debug [NL; STR "after prune_graph, rev_edges = "; NL; !rev_edges#toPretty; NL]; + pr__debug [ + NL; STR "after prune_graph, rev_edges = "; NL; !rev_edges#toPretty; NL]; !rev_edges - (* produces the graph from to a given taint origin to all the nodes touched by this taint *) + (* produces the graph from to a given taint origin to all the nodes touched + by this taint *) let get_taint_origin_graph local_vars_only taint_origin_ind: JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t = - - pr__debug [NL; STR "get_taint_origin_graph "; INT taint_origin_ind; NL] ; - - make_taint_origin_graphs taint_origin_ind ; + + pr__debug [NL; STR "get_taint_origin_graph "; INT taint_origin_ind; NL]; + + make_taint_origin_graphs taint_origin_ind; let res = if local_vars_only then make_graph () diff --git a/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.mli b/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.mli index ff73ba0e..e14f772c 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTOriginGraphs.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -25,10 +26,9 @@ SOFTWARE. ============================================================================= *) -val make_taint_origin_graphs : int -> unit +val make_taint_origin_graphs : int -> unit val get_taint_origin_graph : bool -> int -> JCHTNode.TaintNodeCollections.set_t JCHTNode.TaintNodeCollections.table_t - diff --git a/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.ml b/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.ml index f21aa03b..78ae1017 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.ml +++ b/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.mli b/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.mli index cc84ba6a..5fbcb99b 100644 --- a/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.mli +++ b/CodeHawk/CHJ/jchpoly/jCHTaintLoopUtils.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchpre/dune b/CodeHawk/CHJ/jchpre/dune index 8ebbcc08..36c86195 100644 --- a/CodeHawk/CHJ/jchpre/dune +++ b/CodeHawk/CHJ/jchpre/dune @@ -3,7 +3,3 @@ (libraries chlib chutil extlib jchlib zip) (public_name codehawk.jchpre) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchstac/dune b/CodeHawk/CHJ/jchstac/dune index a366f74d..496d7b76 100644 --- a/CodeHawk/CHJ/jchstac/dune +++ b/CodeHawk/CHJ/jchstac/dune @@ -25,7 +25,3 @@ (modules jCHXTemplate) (package exes) (public_name chj_usertemplate)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchstac/jCHVersion.ml b/CodeHawk/CHJ/jchstac/jCHVersion.ml index 8b41028d..fd8f310f 100644 --- a/CodeHawk/CHJ/jchstac/jCHVersion.ml +++ b/CodeHawk/CHJ/jchstac/jCHVersion.ml @@ -5,6 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -41,10 +42,11 @@ object (self) method get_date = date method toPretty = - LBLOCK [ STR (string_repeat "=" 80) ; NL ; - STR "* CodeHawk Java Analyzer (STAC). Version " ; STR self#get_version ; NL ; - STR "* Date: " ; STR self#get_date ; NL ; - STR (string_repeat "=" 80) ; NL ] + LBLOCK [ + STR (string_repeat "=" 80) ; NL ; + STR "* CodeHawk Java Analyzer (STAC). Version " ; STR self#get_version ; NL ; + STR "* Date: " ; STR self#get_date ; NL ; + STR (string_repeat "=" 80) ; NL ] end let version = new version_info_t diff --git a/CodeHawk/CHJ/jchstac/jCHXClassInvariants.ml b/CodeHawk/CHJ/jchstac/jCHXClassInvariants.ml index 7912ca1b..d0f893df 100644 --- a/CodeHawk/CHJ/jchstac/jCHXClassInvariants.ml +++ b/CodeHawk/CHJ/jchstac/jCHXClassInvariants.ml @@ -3,9 +3,9 @@ Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -37,7 +37,6 @@ open CHUtil (* jchlib *) open JCHBasicTypes -open JCHBasicTypesAPI open JCHDictionary open JCHFile open JCHJTerm @@ -47,12 +46,8 @@ open JCHRawClass open JCHApplication open JCHClassLoader open JCHIFSystem -open JCHFunctionSummary -open JCHPreFileIO open JCHSystemSettings -(* jchsys *) -open JCHLoopUtils module H = Hashtbl @@ -71,7 +66,7 @@ let is_file f = with Unix.Unix_error (Unix.ENOENT, _,_) -> false -let usage_msg = +let usage_msg = "-----------------------------------------------------------------------\n" ^ "CodeHawk Java Analyzer: Invariant generator for individual classes\n\n" ^ "Invoke with: \n" ^ @@ -82,7 +77,7 @@ let usage_msg = " chj_class_invariants -summaries jdk.jar MyClass.class\n" ^ " chj_class_invariants -summaries jdk.jar -classpath myjar.jar org.mydomain.MyClass\n" ^ "-----------------------------------------------------------------------\n" - + let read_args () = Arg.parse speclist (fun s -> classname := s) usage_msg let has_invariants invs = @@ -99,14 +94,14 @@ let report_invariants cInfo = if !methodname = "" || ms#name = !methodname then let msig = sanitize ms#to_signature_string in let msname = sanitize ms#name in - let fname = + let fname = if H.mem mnames msname then - cname ^ "_" ^ msname ^ "_" ^ msig + cname ^ "_" ^ msname ^ "_" ^ msig else begin H.add mnames msname true ; cname ^ "_" ^ msname end in let fInvs = fname ^ "_invs.txt" in let fBc = fname ^ "_bc.txt" in - + let cms = make_cms cInfo#get_class_name ms in let mInfo = app#get_method cms in (* let jproc = JCHSystem.jsystem#get_jproc_info_seq_no mInfo#get_index in *) @@ -118,22 +113,22 @@ let report_invariants cInfo = List.iter (fun (pc,invs) -> match invs with | [] -> () - | _ -> + | _ -> let pinvs = List.map relational_expr_to_pretty invs in - ppInvs := - LBLOCK ([ fixed_length_pretty ~alignment:StrRight (INT pc) 5 ; STR " " ; - pretty_print_list pinvs (fun p -> LBLOCK [ INDENT (3,p) ; NL ]) + ppInvs := + LBLOCK ([ fixed_length_pretty ~alignment:StrRight (INT pc) 5 ; STR " " ; + pretty_print_list pinvs (fun p -> LBLOCK [ INDENT (3,p) ; NL ]) "" " " "" ; NL ]) :: !ppInvs) invs else ppInvs := LBLOCK ([ STR " --- No invariants generated --- " ; NL ]) :: !ppInvs) ; - pr_debug [ STR "Saving invariants and bytecode for " ; cms#toPretty ; + pr_debug [ STR "Saving invariants and bytecode for " ; cms#toPretty ; STR " in " ; STR fInvs ; STR " and " ; STR fBc ; NL ] ; file_output#saveFile fInvs (LBLOCK (List.rev !ppInvs)) ; - file_output#saveFile fBc mInfo#bytecode_to_pretty + file_output#saveFile fBc mInfo#bytecode_to_pretty end) cInfo#get_methods_defined - + let load () = if Filename.check_suffix !classname "class" then if is_file !classname then diff --git a/CodeHawk/CHJ/jchstac/jCHXInitializeAnalysis.ml b/CodeHawk/CHJ/jchstac/jCHXInitializeAnalysis.ml index 23910a4e..80f0ad0d 100644 --- a/CodeHawk/CHJ/jchstac/jCHXInitializeAnalysis.ml +++ b/CodeHawk/CHJ/jchstac/jCHXInitializeAnalysis.ml @@ -3,8 +3,9 @@ Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -25,7 +26,7 @@ SOFTWARE. ============================================================================= *) -(** ----------------------------------------------------------------------------- +(** ----------------------------------------------------------------------------- Reads in all application jars, creates a dictionary of class names, field, and method signatures and saves this dictionary to an xml file, named /_dictionary.xml . @@ -33,8 +34,6 @@ (* chlib *) open CHCommon -open CHIntervals -open CHNumerical open CHPretty (* chutil *) @@ -44,19 +43,15 @@ open CHXmlDocument (* jchlib *) open JCHBasicTypes -open JCHBasicTypesAPI open JCHDictionary (* jchpre *) open JCHApplication open JCHCallgraphBase -open JCHClassUserTemplate open JCHCHAUtil open JCHClassLoader open JCHIFSystem -open JCHLoops open JCHMethodImplementations -open JCHPreAPI open JCHPreFileIO open JCHAnalysisResults open JCHSystemSettings @@ -70,17 +65,17 @@ open JCHCostBoundsModel let versioninfo = "1.0 (March 3, 2020)" -(* -------- alternative analysis options ---------- *) +(* -------- alternative analysis options ---------- *) let create_model = ref false let scan_only = ref false let translate_only = ref false let analyze_taint = ref false let analyze_taint_origins = ref false (* --------------------------------------------------- *) - -let save_summaries = ref true -let analyze_loops = ref true -let save_loops = ref true + +let _save_summaries = ref true +let _analyze_loops = ref true +let _save_loops = ref true let print_version = ref false let intervals_only = ref false let joins = ref 2 (* number of joins before widening *) @@ -90,58 +85,59 @@ let constraint_analysis_time_limit = ref 20 let numeric_analysis_time_limit = ref 200 let taint_origin_ind = ref (-1) let use_symbolic_defaults = ref true -let dbg = ref false let _ = chlog#set_max_entry_size 10000 let _ = ch_error_log#set_max_entry_size 1000 let speclist = [ - ("-scan_only", Arg.Set scan_only, "determine number of methods") ; - ("-translate_only", Arg.Set translate_only, "only translate to chif") ; + ("-scan_only", Arg.Set scan_only, "determine number of methods"); + ("-translate_only", Arg.Set translate_only, "only translate to chif"); ("-trace_utf8_signatures", Arg.Unit (fun () -> JCHParseUTF8Signature.activate_tracing ()), - "collect signature strings parsed") ; + "collect signature strings parsed"); ("-taint", Arg.Set analyze_taint, "perform taint analysis (to be performed after numerical analysis)"); ("-taintorigin", Arg.Int (fun i -> taint_origin_ind := i; analyze_taint_origins := true), "perform taint-origin analysis (to be performed after taint analysis). "); - ("-costmodel", Arg.Set create_model, "create a cost model") ; + ("-costmodel", Arg.Set create_model, "create a cost model"); ("-summaries", Arg.String system_settings#add_summary_classpath_unit, - "summary jar file") ; - ("-classpath", Arg.String system_settings#add_classpath_unit, "sets java classpath") ; - ("-jars", Arg.Rest app#add_application_jar, "jar files that make up the project") ; + "summary jar file"); + ("-classpath", Arg.String system_settings#add_classpath_unit, "sets java classpath"); + ("-jars", Arg.Rest app#add_application_jar, "jar files that make up the project"); ("-intervals_only", Arg.Set intervals_only, "non-relational analysis only"); ("-joins", Arg.Int (fun i -> joins := i), "number of joins before widening"); ("-maxcoeff", Arg.Int (fun i -> maxcoeff := i), - "maximum coefficient in constraint (default 100)") ; + "maximum coefficient in constraint (default 100)"); ("-maxconstraints", Arg.Int (fun i -> maxconstraints := i), - "maximum number of constraints in polyhedron (default 10)") ; + "maximum number of constraints in polyhedron (default 10)"); ("-constraint_time_limit", Arg.Int (fun i -> constraint_analysis_time_limit := i), - "constraint analysis time limit (default 20)") ; + "constraint analysis time limit (default 20)"); ("-numeric_time_limit", Arg.Int (fun i -> pr_debug [STR "set_numeric_analysis_time_limit"; NL]; numeric_analysis_time_limit := i), - "numeric analysis time limit (default 200)") ; + "numeric analysis time limit (default 200)"); ("-distinguish_taint_top_targets", Arg.Unit (fun () -> JCHTaintOrigin.set_use_one_top_target false), "represent unknown method calls as separate taint top targets"); ("-use_symbolic_defaults", Arg.Set use_symbolic_defaults, - "use default symbolic constants rather than constants for method calls"); - ("-cost_time_limit", Arg.Float (fun m -> JCHCostUtils.set_max_cost_analysis_time m), + "use default symbolic constants rather than constants for method calls"); + ("-cost_time_limit", + Arg.Float (fun m -> JCHCostUtils.set_max_cost_analysis_time m), "cost analysis time limit for every method (float)"); ("-version", Arg.Set print_version, "print version information and return"); ("-dbg", Arg.Unit (fun () -> JCHPrintUtils.set_dbg_on ()), "print debugging info"); ("-exclude_pkg_prefix", Arg.String system_settings#add_pkg_exclude, - "skip classes with given package prefix") ; - ("-verbose", Arg.Unit (fun () -> system_settings#set_verbose),"show intermediate results") + "skip classes with given package prefix"); + ("-verbose", + Arg.Unit (fun () -> system_settings#set_verbose),"show intermediate results") ] -let usage_message = +let usage_message = "\nCodeHawk Java Analyzer for Complexity Analysis " ^ versioninfo ^ "\n" ^ (string_repeat "-~" 40) ^ "\n\nInvoke with" @@ -160,20 +156,21 @@ let usage_message = ^ "\n -numeric_time_limit: time limit for the numeric analysis (default 200 seconds)" ^ "\n" -let read_args () = Arg.parse speclist (fun s -> ()) usage_message +let read_args () = Arg.parse speclist (fun _ -> ()) usage_message -let trail_to_graph v trail = +let _trail_to_graph _v trail = let result = ref [] in let l = trail#listOfPairs in let _ = List.iter (fun (torigin,ttable) -> - let _ = pr_debug [ torigin#toPretty ; NL ] in + let _ = pr_debug [torigin#toPretty; NL] in let ll = ttable#listOfPairs in List.iter (fun (tnode, tnodeset) -> if tnode#is_var then - tnodeset#iter (fun ttnode -> - if ttnode#is_var then result := (tnode#get_var, ttnode#get_var) :: !result)) ll) l in + tnodeset#iter (fun ttnode -> + if ttnode#is_var then + result := (tnode#get_var, ttnode#get_var) :: !result)) ll) l in !result - + let save_numeric_analysis_results cInfo = let cInfoResults = init_class_analysis_results cInfo in begin @@ -183,20 +180,23 @@ let save_numeric_analysis_results cInfo = if mInfo#has_bytecode then try let jproc = JCHSystem.jsystem#get_jproc_info_seq_no cms#index in - let pcresults = jproc#get_analysis_results#get_pc_analysis_results#listOfPairs in - let invs = List.map (fun (pc,pca) -> (pc,pca#get_invariants)) pcresults in - let loops = List.map (fun wto -> wto#get_loop_info ()) jproc#get_wto_infos in + let pcresults = + jproc#get_analysis_results#get_pc_analysis_results#listOfPairs in + let invs = + List.map (fun (pc,pca) -> (pc,pca#get_invariants)) pcresults in + let loops = + List.map (fun wto -> wto#get_loop_info ()) jproc#get_wto_infos in begin - cInfoResults#set_method_invariants cms#index invs ; - cInfoResults#set_method_loops cms#index loops + cInfoResults#set_method_invariants cms#index invs; + cInfoResults#set_method_loops cms#index loops end with - JCH_failure p -> - pr_debug [ STR "Error in retrieving analysis results for " ; cms#toPretty ; - STR ": " ; p ; NL ]) - cInfo#get_methods_defined ; - cInfoResults#save_xml_class ; - save_xml_class_cost_support cInfo ; + JCH_failure p -> + pr_debug [STR "Error in retrieving analysis results for "; cms#toPretty; + STR ": "; p; NL]) + cInfo#get_methods_defined; + cInfoResults#save_xml_class; + save_xml_class_cost_support cInfo; end let save_taint_analysis_results cInfo = @@ -207,30 +207,32 @@ let save_taint_analysis_results cInfo = if mInfo#has_bytecode then try let jproc = JCHSystem.jsystem#get_jproc_info_seq_no cms#index in - let pcresults = jproc#get_analysis_results#get_pc_analysis_results#listOfPairs in - let taints = List.map (fun (pc,pca) -> (pc,pca#get_taint_origins)) pcresults in + let pcresults = + jproc#get_analysis_results#get_pc_analysis_results#listOfPairs in + let taints = + List.map (fun (pc,pca) -> (pc,pca#get_taint_origins)) pcresults in let returnorigins = jproc#get_analysis_results#get_return_origins in begin - cInfoResults#set_method_taint_origins cms#index taints ; - cInfoResults#set_method_return_origins cms#index returnorigins ; + cInfoResults#set_method_taint_origins cms#index taints; + cInfoResults#set_method_return_origins cms#index returnorigins; end with - JCH_failure p -> - pr_debug [ STR "Error in retrieving analysis results for " ; cms#toPretty ; - STR ": " ; p ; NL ] in - List.iter save_m_results cInfo#get_methods_defined + JCH_failure p -> + pr_debug [STR "Error in retrieving analysis results for "; cms#toPretty; + STR ": "; p; NL] in + List.iter save_m_results cInfo#get_methods_defined -let collect_utf8_parsed_strings () = +let _collect_utf8_parsed_strings () = let results = JCHParseUTF8Signature.get_utf8_parsed_strings () in List.iter (fun (ty,l) -> begin - pr_debug [ NL ; STR ty ; NL ] ; + pr_debug [NL; STR ty; NL]; List.iter - (fun (s,p) -> pr_debug [ INDENT(3, LBLOCK [ STR s ; STR ": " ; p ; NL ]) ]) l + (fun (s,p) -> pr_debug [INDENT(3, LBLOCK [STR s; STR ": "; p; NL])]) l end) results - - + + let main () = try let start = Unix.gettimeofday() in @@ -241,7 +243,7 @@ let main () = * -------------------------------------------------------------------- *) if !print_version then begin - pr_debug [ JCHVersion.version#toPretty ; NL ] ; + pr_debug [JCHVersion.version#toPretty; NL]; exit 0 end @@ -250,14 +252,14 @@ let main () = * -------------------------------------------------------------------- *) else if !scan_only then match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with the " ; - STR "-jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with the "; + STR "-jars command-line option"; NL] | l -> try let xcludes = system_settings#get_pkg_excludes in let _ = set_permissive true in - let classnames = + let classnames = List.fold_left (fun acc jar -> (load_classes_in_jar ~xcludes jar) @ acc) [] l in let _ = process_classes () in @@ -269,112 +271,113 @@ let main () = begin List.iteri (fun i m -> begin - pr_debug [ STR " " ; INT i ; STR ": " ; m#toPretty ; NL ] ; + pr_debug [STR " "; INT i; STR ": "; m#toPretty; NL]; (match m#get_lambda_function with | Some (ot,ms) -> - pr_debug [ STR " ---> Lambda function: " ; - object_type_to_pretty ot ; STR ": " ; - ms#toPretty ; NL ] + pr_debug [STR " ---> Lambda function: "; + object_type_to_pretty ot; STR ": "; + ms#toPretty; NL] | _ -> ()) end) l end) app#get_classes in let bcmethods = List.filter (fun m -> m#has_bytecode) app#get_methods in let _ = if system_settings#is_verbose then - pr_debug (List.map (fun cn -> LBLOCK [ cn#toPretty ; NL ]) classnames) in + pr_debug (List.map (fun cn -> LBLOCK [cn#toPretty; NL]) classnames) in begin - pr_debug [ STR "Methods with bytecode: " ; - INT (List.length bcmethods) ; NL ]; - pr_debug [ STR "Classes loaded : " ; - INT (List.length classnames) ; NL ] ; - set_main_method () ; - method_signature_implementations#initialize ; - set_method_targets () ; - callgraph_base#build_graph ; - save_classnames classnames ; - save_signature_file () ; - save_callgraph_file () ; - save_dictionary () ; - save_missing_items () ; - save_log_files "scanlog" + pr_debug [STR "Methods with bytecode: "; + INT (List.length bcmethods); NL]; + pr_debug [STR "Classes loaded : "; + INT (List.length classnames); NL]; + set_main_method (); + method_signature_implementations#initialize; + set_method_targets (); + callgraph_base#build_graph; + save_classnames classnames; + save_signature_file (); + save_callgraph_file (); + save_dictionary (); + save_missing_items (); + save_log_files "scanlog" end with | JCHParseUTF8Signature.UTF8ParseError p -> - pr_debug [ STR "UTF8 Parse error: " ; p ; NL ] + pr_debug [STR "UTF8 Parse error: "; p; NL] (* -------------------------------------------------------------------- * * translation to CHIF only * * -------------------------------------------------------------------- *) else if !translate_only then match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with the " ; - STR "-jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with the "; + STR "-jars command-line option"; NL] | l -> let _ = JCHBasicTypes.set_permissive true in - let classnames = + let classnames = List.fold_left (fun acc jar -> (load_classes_in_jar jar) @ acc) [] l in let _ = process_classes () in let bcmethods = List.filter (fun m -> m#has_bytecode) app#get_methods in try begin - pr_debug [ STR "Methods with bytecode: " ; INT (List.length bcmethods) ; NL ]; - set_main_method () ; - set_method_targets () ; - method_signature_implementations#initialize ; - callgraph_base#build_graph ; - save_classnames classnames ; - save_dictionary () ; - save_signature_file () ; - save_callgraph_file () ; - save_missing_items () ; - save_log_files "translatelog" ; + pr_debug [STR "Methods with bytecode: "; INT (List.length bcmethods); NL]; + set_main_method (); + set_method_targets (); + method_signature_implementations#initialize; + callgraph_base#build_graph; + save_classnames classnames; + save_dictionary (); + save_signature_file (); + save_callgraph_file (); + save_missing_items (); + save_log_files "translatelog" ; ignore (translate_base_system ()) end with | JCHParseUTF8Signature.UTF8ParseError p -> - pr_debug [ STR "UTF8 Parse error: " ; p ; NL ] + pr_debug [STR "UTF8 Parse error: "; p; NL] (* -------------------------------------------------------------------- * * create cost model * * -------------------------------------------------------------------- *) else if !create_model then match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with the " ; - STR "-jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with the "; + STR "-jars command-line option"; NL] | l -> if not (has_stac_analysis_dir ()) then - pr_debug [ STR "=== Error: Numerical analysis results not found. ===" ; NL ; - STR "Please run the numerical analysis first before " ; - STR "creating the cost model" ; NL ] + pr_debug [STR "=== Error: Numerical analysis results not found. ==="; NL; + STR "Please run the numerical analysis first before "; + STR "creating the cost model"; NL] else let _ = JCHBasicTypes.set_permissive true in let xcludes = system_settings#get_pkg_excludes in begin JCHAnalysisUtils.numeric_params#set_create_model true; - read_dictionary () ; - read_jt_dictionary () ; - read_taint_origins () ; - List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l ; - pr_debug [ STR "Start processing classes ..." ; NL ] ; - process_classes () ; - pr_debug [ STR "Start loading default cost data files ..." ; NL ] ; - load_defaultcostdata_file () ; - pr_debug [ STR "Creating cost models ..." ; NL ] ; - pr_debug [ STR "Start initializing method signature implementation ..." ; NL ] ; - method_signature_implementations#initialize ; - load_user_class_files () ; - read_callgraph_file () ; - set_main_method () ; - set_method_targets () ; - pr_debug [ STR "User-provided data: " ; NL ; userdata#toPretty ; NL ] ; + read_dictionary (); + read_jt_dictionary (); + read_taint_origins (); + List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l; + pr_debug [STR "Start processing classes ..."; NL]; + process_classes (); + pr_debug [STR "Start loading default cost data files ..."; NL]; + load_defaultcostdata_file (); + pr_debug [STR "Creating cost models ..."; NL]; + pr_debug [ + STR "Start initializing method signature implementation ..."; NL]; + method_signature_implementations#initialize; + load_user_class_files (); + read_callgraph_file (); + set_main_method (); + set_method_targets (); + pr_debug [STR "User-provided data: "; NL; userdata#toPretty; NL]; JCHNumericAnalysis.load_xml_class_cost_support (); - pr_debug [ STR "Creating cost models ..." ; NL ] ; - JCHCostBoundsAnalysis.create_bounds_cost_model !use_symbolic_defaults ; - save_log_files "costlog" ; - save_jt_dictionary () ; - save_timecost_diagnostics () ; + pr_debug [STR "Creating cost models ..."; NL]; + JCHCostBoundsAnalysis.create_bounds_cost_model !use_symbolic_defaults; + save_log_files "costlog"; + save_jt_dictionary (); + save_timecost_diagnostics (); end (* -------------------------------------------------------------------- * @@ -382,43 +385,43 @@ let main () = * -------------------------------------------------------------------- *) else if !analyze_taint then match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with the " ; - STR "-jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with the "; + STR "-jars command-line option"; NL] | l -> if not (has_stac_analysis_dir ()) then - pr_debug [ STR "=== Error: Numerical analysis results not found. ===" ; NL ; - STR "Please run the numerical analysis first before " ; - STR "doing taint analysis" ; NL ] + pr_debug [STR "=== Error: Numerical analysis results not found. ==="; NL; + STR "Please run the numerical analysis first before "; + STR "doing taint analysis"; NL] else let _ = JCHBasicTypes.set_permissive true in let xcludes = system_settings#get_pkg_excludes in begin JCHAnalysisUtils.numeric_params#set_create_model true; - read_dictionary () ; - read_jt_dictionary () ; - read_taint_origins () ; - List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l ; - pr_debug [ STR "Start processing classes ..." ; NL ] ; - process_classes () ; - method_signature_implementations#initialize ; - load_user_class_files () ; - read_callgraph_file () ; - set_main_method () ; - set_method_targets () ; + read_dictionary (); + read_jt_dictionary (); + read_taint_origins (); + List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l; + pr_debug [STR "Start processing classes ..."; NL]; + process_classes (); + method_signature_implementations#initialize; + load_user_class_files (); + read_callgraph_file (); + set_main_method (); + set_method_targets (); JCHSystemUtils.start_timing(); - ignore (translate_base_system ()) ; + ignore (translate_base_system ()); JCHSystemUtils.add_timing "translate base system"; - pr_debug [ STR "Start taint analysis ... " ; NL ] ; - JCHNumericAnalysis.load_xml_class_cost_support () ; + pr_debug [STR "Start taint analysis ... "; NL]; + JCHNumericAnalysis.load_xml_class_cost_support (); JCHAnalysis.analyze_taint (); - List.iter (fun cInfo -> - if cInfo#is_stubbed || cInfo#is_missing then () + List.iter (fun cInfo -> + if cInfo#is_stubbed || cInfo#is_missing then () else save_taint_analysis_results cInfo) - app#get_classes ; - JCHSystemUtils.add_timing "save analysis results" ; - save_taint_origins () ; - JCHSystemUtils.add_timing "save taint origins" ; + app#get_classes; + JCHSystemUtils.add_timing "save analysis results"; + save_taint_origins (); + JCHSystemUtils.add_timing "save taint origins"; save_log_files "taint" end @@ -427,38 +430,39 @@ let main () = * -------------------------------------------------------------------- *) else if !analyze_taint_origins then match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with the " ; - STR "-jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with the "; + STR "-jars command-line option"; NL] | l -> if not (has_stac_analysis_dir ()) then - pr_debug [ STR "=== Error: Numerical analysis results not found. ===" ; NL ; - STR "Please run the numerical analysis and taint analysis " ; - STR "before doing taint origin analysis" ; NL ] + pr_debug [STR "=== Error: Numerical analysis results not found. ==="; NL; + STR "Please run the numerical analysis and taint analysis "; + STR "before doing taint origin analysis"; NL] else let _ = JCHBasicTypes.set_permissive true in let xcludes = system_settings#get_pkg_excludes in begin JCHAnalysisUtils.numeric_params#set_create_model true; - read_dictionary () ; - read_jt_dictionary () ; - read_taint_origins () ; - List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l ; - pr_debug [ STR "Start processing classes ..." ; NL ] ; - process_classes () ; - method_signature_implementations#initialize ; - load_user_class_files () ; - read_callgraph_file () ; - set_main_method () ; - set_method_targets () ; + read_dictionary (); + read_jt_dictionary (); + read_taint_origins (); + List.iter (fun jar -> ignore(load_classes_in_jar ~xcludes jar)) l; + pr_debug [STR "Start processing classes ..."; NL]; + process_classes (); + method_signature_implementations#initialize; + load_user_class_files (); + read_callgraph_file (); + set_main_method (); + set_method_targets (); JCHSystemUtils.start_timing(); - ignore (translate_base_system ()) ; + ignore (translate_base_system ()); JCHSystemUtils.add_timing "translate base system"; - pr_debug [ STR "Start taint analysis ... " ; NL ] ; - JCHNumericAnalysis.load_xml_class_cost_support () ; + pr_debug [STR "Start taint analysis ... "; NL]; + JCHNumericAnalysis.load_xml_class_cost_support (); let local_vars_only = true in - JCHAnalysis.analyze_taint_origins !taint_origin_ind local_vars_only (*None None*) ; - save_taint_origins () ; + JCHAnalysis.analyze_taint_origins + !taint_origin_ind local_vars_only (*None None*); + save_taint_origins (); save_log_files "taint" end else @@ -467,96 +471,95 @@ let main () = * numeric analysis * * -------------------------------------------------------------------- *) match app#get_application_jars with - |[] -> pr_debug [ STR "=== Error: No jars were specified. === " ; NL ; - STR "Please indicate the jars to be loaded with " ; - STR "the -jars command-line option" ; NL ] + |[] -> pr_debug [STR "=== Error: No jars were specified. === "; NL; + STR "Please indicate the jars to be loaded with "; + STR "the -jars command-line option"; NL] | l -> let _ = JCHBasicTypes.set_permissive true in let xcludes = system_settings#get_pkg_excludes in - let classnames = + let classnames = List.fold_left (fun acc jar -> (load_classes_in_jar ~xcludes jar) @ acc) [] l in begin JCHAnalysisUtils.numeric_params#set_create_model false; - process_classes () ; - set_main_method () ; - method_signature_implementations#initialize ; - load_user_class_files () ; - set_method_targets () ; - callgraph_base#build_graph ; - save_classnames classnames ; - save_dictionary () ; - save_signature_file () ; - save_callgraph_file () ; - save_missing_items () ; - save_log_files "loading" ; (* save log files before analysis *) + process_classes (); + set_main_method (); + method_signature_implementations#initialize; + load_user_class_files (); + set_method_targets (); + callgraph_base#build_graph; + save_classnames classnames; + save_dictionary (); + save_signature_file (); + save_callgraph_file (); + save_missing_items (); + save_log_files "loading"; (* save log files before analysis *) JCHSystemUtils.start_timing(); - ignore (translate_base_system ()) ; + ignore (translate_base_system ()); JCHSystemUtils.add_timing "translate base system"; - JCHAnalysis.analyze_system + JCHAnalysis.analyze_system ~analysis_level:0 - ~use_intervals:!intervals_only - ~number_joins:!joins - ~max_poly_coeff:!maxcoeff - ~max_nb_constraints:!maxconstraints - ~use_time_limits:true - ~poly_analysis_time_limit:!constraint_analysis_time_limit + ~use_intervals:!intervals_only + ~number_joins:!joins + ~max_poly_coeff:!maxcoeff + ~max_nb_constraints:!maxconstraints + ~use_time_limits:true + ~poly_analysis_time_limit:!constraint_analysis_time_limit ~num_analysis_time_limit:!numeric_analysis_time_limit - ~use_overflow:true ; - List.iter (fun cInfo -> + ~use_overflow:true; + List.iter (fun cInfo -> if cInfo#is_stubbed || cInfo#is_missing then - () + () else save_numeric_analysis_results cInfo - ) app#get_classes ; - JCHSystemUtils.add_timing "save analysis results" ; - save_jt_dictionary () ; - save_callgraph_file () ; - save_dictionary () ; - save_log_files "numerical" ; (* save log files after analysis *) - JCHSystemUtils.add_timing "save log files" ; - pr_debug [ STR "Time: " ; - STR (Printf.sprintf "%.4f" ((Unix.gettimeofday()) -. start)) ; NL ] + ) app#get_classes; + JCHSystemUtils.add_timing "save analysis results"; + save_jt_dictionary (); + save_callgraph_file (); + save_dictionary (); + save_log_files "numerical"; (* save log files after analysis *) + JCHSystemUtils.add_timing "save log files"; + pr_debug [ + STR "Time: "; + STR (Printf.sprintf "%.4f" ((Unix.gettimeofday()) -. start)); NL] end with | JCH_failure p -> begin - pr_debug [ STR "JCH_failure: " ; p ; NL ] ; - save_log_files "failurelog" ; + pr_debug [STR "JCH_failure: "; p; NL]; + save_log_files "failurelog"; exit(1) end | JCH_class_structure_error p -> begin - pr_debug [ STR "Error in class structure: " ; p ; NL ] ; - save_log_files "failurelog" ; + pr_debug [STR "Error in class structure: "; p; NL]; + save_log_files "failurelog"; exit (1) end | CHFailure p -> begin - pr_debug [ STR "CHFailure: " ; p ; NL ] ; - save_log_files "failurelog" ; + pr_debug [STR "CHFailure: "; p; NL]; + save_log_files "failurelog"; exit(1) end | Failure s -> begin - pr_debug [ STR "Failure: " ; STR s ; NL ] ; - save_log_files "failurelog" ; + pr_debug [STR "Failure: "; STR s; NL]; + save_log_files "failurelog"; exit(1) end | XmlDocumentError (line,col,p) | CHXmlReader.XmlParseError (line,col,p) -> begin - pr_debug [ STR "Xml error at (" ; INT line ; STR "," ; INT col ; - STR "): " ; p ; NL ] ; - save_log_files "failurelog" ; + pr_debug [STR "Xml error at ("; INT line; STR ","; INT col; + STR "): "; p; NL]; + save_log_files "failurelog"; exit(1) end | Exit -> begin - save_log_files "costfailurelog" ; + save_log_files "costfailurelog"; exit(1) end - + let _ = Printexc.print main () - - diff --git a/CodeHawk/CHJ/jchstac/jCHXTemplate.ml b/CodeHawk/CHJ/jchstac/jCHXTemplate.ml index 20ac3ce5..3679fb78 100644 --- a/CodeHawk/CHJ/jchstac/jCHXTemplate.ml +++ b/CodeHawk/CHJ/jchstac/jCHXTemplate.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchstac/jCHXTranslateClass.ml b/CodeHawk/CHJ/jchstac/jCHXTranslateClass.ml index 1c0f0ee2..e153f1a9 100644 --- a/CodeHawk/CHJ/jchstac/jCHXTranslateClass.ml +++ b/CodeHawk/CHJ/jchstac/jCHXTranslateClass.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/dune b/CodeHawk/CHJ/jchsys/dune index 0ef526e7..ebe8f5f4 100644 --- a/CodeHawk/CHJ/jchsys/dune +++ b/CodeHawk/CHJ/jchsys/dune @@ -3,7 +3,3 @@ (libraries chlib chutil jchlib jchpre zarith) (public_name codehawk.jchsys) (wrapped false)) - -(env - (dev - (flags (:standard -warn-error -A)))) diff --git a/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.ml b/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.ml index 00384004..66f3f2c3 100755 --- a/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.ml +++ b/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.mli b/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.mli index 3919a0ea..134e503d 100644 --- a/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.mli +++ b/CodeHawk/CHJ/jchsys/jCHAnalysisSetUp.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHCallGraph.ml b/CodeHawk/CHJ/jchsys/jCHCallGraph.ml index f8cb82f8..3e866f13 100755 --- a/CodeHawk/CHJ/jchsys/jCHCallGraph.ml +++ b/CodeHawk/CHJ/jchsys/jCHCallGraph.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -56,7 +56,8 @@ object (self: _) val proc_to_index = H.create (List.length all_procs) (* array of index -> proc_name *) - val procs = ref (Array.make 0 (Array.make 0 (Array.make 0 (new symbol_t "no_proc")))) + val procs = + ref (Array.make 0 (Array.make 0 (Array.make 0 (new symbol_t "no_proc")))) (* proc index -> scc representative index *) val node_to_rep = ref (Array.make 0 (Array.make 0 (Array.make 0 (-1)))) @@ -96,18 +97,18 @@ object (self: _) (* Releases all the structures that are not needed after initialization *) method clean_up = - in_loop := new SymbolCollections.set_t ; + in_loop := new SymbolCollections.set_t; node_edges := - (Array.make 0 (Array.make 0 (Array.make 0 (new IntCollections.set_t)))) ; + (Array.make 0 (Array.make 0 (Array.make 0 (new IntCollections.set_t)))); node_rev_edges := (Array.make 0 (Array.make 0 (Array.make 0 (new IntCollections.set_t)))) (* Makes proc_to_index *) method private set_proc_to_index = let size = List.length all_procs in - last_index := pred size ; - self#set_dimensions size ; - procs := self#make_arrays_sym ; + last_index := pred size; + self#set_dimensions size; + procs := self#make_arrays_sym; let count = ref (-1) in let index1 = ref 0 in let index2 = ref 0 in @@ -115,20 +116,20 @@ object (self: _) let set_index (proc_name:symbol_t) = if not (not_analyzed#has proc_name#getSeqNumber) then begin - incr count ; - incr index3 ; + incr count; + incr index3; if !index3 = array_size then begin - index3 := 0 ; - incr index2 ; + index3 := 0; + incr index2; if !index2 = array_size then begin - index2 := 0 ; + index2 := 0; incr index1 end - end ; - !procs.(!index1).(!index2).(!index3) <- proc_name ; - H.add proc_to_index proc_name#getSeqNumber !count ; + end; + !procs.(!index1).(!index2).(!index3) <- proc_name; + H.add proc_to_index proc_name#getSeqNumber !count; end in List.iter set_index all_procs @@ -145,12 +146,12 @@ object (self: _) else raise (JCH_failure - (LBLOCK [ STR "procname index for " ; proc_name#toPretty ; + (LBLOCK [ STR "procname index for "; proc_name#toPretty; STR " not found int JCHCallGraph.get_index" ])) else raise (JCH_failure - (LBLOCK [ STR "procname index for " ; proc_name#toPretty ; + (LBLOCK [ STR "procname index for "; proc_name#toPretty; STR " not found int JCHCallGraph.get_index" ])) @@ -173,8 +174,8 @@ object (self: _) (succ index1, index2, array_size) else (succ index1, succ index2, index3) in - dim1 := d1 ; - dim2 := d2 ; + dim1 := d1; + dim2 := d2; dim3 := d3 method private make_arrays_int = @@ -234,21 +235,21 @@ object (self: _) for i = 0 to !dim1 - 2 do for j = 0 to pred array_size do for k = 0 to pred array_size do - incr node ; + incr node; f i j k !node done done - done ; + done; let pred_dim1 = pred !dim1 in for j = 0 to !dim2 - 2 do for k = 0 to pred array_size do - incr node ; + incr node; f pred_dim1 j k !node done - done ; + done; let pred_dim2 = pred !dim2 in for k = 0 to !dim3 - 1 do - incr node ; + incr node; f pred_dim1 pred_dim2 k !node done @@ -271,7 +272,7 @@ object (self: _) method private get_rep (node_index:int) = let path_nodes = new IntCollections.set_t in let rec go_up (n:int) = - path_nodes#add n ; + path_nodes#add n; let up_n = self#get_rep_ n in if up_n = n then n else go_up up_n in @@ -286,14 +287,14 @@ object (self: _) method private add_node_edge source_index target_index = let set = self#get_value !node_edges source_index in - set#add target_index ; + set#add target_index; let set = self#get_value !node_rev_edges target_index in set#add source_index method private find_node_sccs visited (start_node: int) = let on_path = new IntCollections.set_t in let path = Stack.create () in - Stack.push (start_node, None) path ; + Stack.push (start_node, None) path; while not (Stack.is_empty path) do match Stack.pop path with | (node, None) -> @@ -307,11 +308,11 @@ object (self: _) let rec unroll () = let (n, nexts_opt) = Stack.top path in let nexts = Option.get nexts_opt in - on_path#remove n ; + on_path#remove n; if not (n = rep) then begin let _ = Stack.pop path in - all_nexts#addSet nexts ; + all_nexts#addSet nexts; self#change_rep rep n; unroll () end @@ -323,7 +324,7 @@ object (self: _) end else if was_not_visited then begin - visited.(index1).(index2).(index3) <- 1 ; + visited.(index1).(index2).(index3) <- 1; let nexts = self#get_value !node_edges node in Stack.push (node, Some nexts#clone) path end @@ -331,7 +332,7 @@ object (self: _) | (node, Some nexts) -> if nexts#isEmpty then begin - on_path#remove node ; + on_path#remove node; if Stack.is_empty path then () else @@ -340,9 +341,9 @@ object (self: _) else begin let node' = Option.get nexts#choose in - nexts#remove node' ; - Stack.push (node, Some nexts) path ; - on_path#add node ; + nexts#remove node'; + Stack.push (node, Some nexts) path; + on_path#add node; Stack.push (node', None) path end done @@ -370,7 +371,7 @@ object (self: _) let r = self#get_rep_ n in if r <> rep then begin - next_reps#add r ; + next_reps#add r; let prevs = self#get_value !rep_rev_edges r in prevs#add rep end in @@ -388,7 +389,7 @@ object (self: _) else rev_edges.(i).(j).(k) <- !rep_rev_edges.(i).(j).(k)#clone end in - self#iter_on_array find ; + self#iter_on_array find; (starts, rev_edges) method private mk_bottom_up_list = @@ -398,34 +399,34 @@ object (self: _) let add_to_sorted_procs rep = let node_indices = self#get_value !rep_to_nodes rep in let procs = List.map self#get_proc node_indices#toList in - if List.length procs > 1 then !in_loop#addList procs ; + if List.length procs > 1 then !in_loop#addList procs; sorted_procs := List.rev_append procs !sorted_procs in let rec work () = match !starts with | t :: rest_starts -> - starts := rest_starts ; - add_to_sorted_procs t ; + starts := rest_starts; + add_to_sorted_procs t; let nexts = self#get_value !rep_edges t in let remove_from_prev n = let set = self#get_value rev_edges n in - set#remove t ; + set#remove t; if set#isEmpty then starts := n :: !starts in - nexts#iter remove_from_prev ; + nexts#iter remove_from_prev; work () | _ -> () in - work () ; + work (); (!sorted_procs, !in_loop) method initialize = - self#set_proc_to_index ; - node_to_rep := self#make_arrays_int ; - rep_to_nodes := self#make_arrays_set ; - node_edges := self#make_arrays_set ; - node_rev_edges := self#make_arrays_set ; - rep_edges := self#make_arrays_set ; - rep_rev_edges := self#make_arrays_set ; + self#set_proc_to_index; + node_to_rep := self#make_arrays_int; + rep_to_nodes := self#make_arrays_set; + node_edges := self#make_arrays_set; + node_rev_edges := self#make_arrays_set; + rep_edges := self#make_arrays_set; + rep_rev_edges := self#make_arrays_set; (* Copy the call graph in node_edges in node_rev_edges *) let add_edge (source, target) = @@ -436,14 +437,14 @@ object (self: _) let source_index = self#get_index source in let target_index = self#get_index target in self#add_node_edge source_index target_index in - List.iter add_edge edges ; + List.iter add_edge edges; (* Make the graph between the sccs / nodes that are not part of a loop *) (* Initially each node is its own representatives *) - self#iter_on_array (fun i j k node -> !node_to_rep.(i).(j).(k) <- node) ; - self#find_sccs ; - self#make_rep_to_nodes ; - self#make_rep_graph ; + self#iter_on_array (fun i j k node -> !node_to_rep.(i).(j).(k) <- node); + self#find_sccs; + self#make_rep_to_nodes; + self#make_rep_graph; self#mk_bottom_up_list @@ -464,9 +465,9 @@ object (self: _) let index = self#get_index proc_name in reps_that_access#add (self#get_rep index) with _ -> () in (* in case the method does not need to be analyzed *) - List.iter add_rep proc_names ; + List.iter add_rep proc_names; end in - List.iter add_field_info field_infos ; + List.iter add_field_info field_infos; let rec work reps = match reps with | rep_index :: rest_reps -> @@ -474,7 +475,7 @@ object (self: _) work rest_reps else begin - reps_that_access_static_fields#add rep_index ; + reps_that_access_static_fields#add rep_index; let prev_reps = self#get_value !rep_rev_edges rep_index in let prev_reps = prev_reps#toList in let new_reps = @@ -483,7 +484,7 @@ object (self: _) work (new_reps @ rest_reps) end | _ -> () in - work reps_that_access#toList ; + work reps_that_access#toList; method accesses_static_field (proc_name:symbol_t) = let index = self#get_index proc_name in @@ -504,15 +505,15 @@ object (self: _) let next_reps = self#get_value !rep_edges rep in let nexts = List.filter (fun r -> not (on_the_list#has r)) next_reps#toList in - on_the_list#addList nexts ; - on_the_list_now#remove rep ; - on_the_list_now#addList nexts ; + on_the_list#addList nexts; + on_the_list_now#remove rep; + on_the_list_now#addList nexts; let nodes = (self#get_value !rep_to_nodes rep)#toList in descendants := - List.rev_append (List.map self#get_proc nodes) !descendants ; + List.rev_append (List.map self#get_proc nodes) !descendants; add_desc (List.rev_append nexts rest_reps) | _ -> () in - add_desc reps#toList ; + add_desc reps#toList; !descendants method get_unsynchronized_descendants (proc_names:symbol_t list) = @@ -536,15 +537,15 @@ object (self: _) List.filter (fun r -> not (on_the_list#has r)) next_reps#toList in let not_synch_nexts = List.filter is_not_synch nexts in - on_the_list#addList nexts ; + on_the_list#addList nexts; let nodes = (self#get_value !rep_to_nodes rep)#toList in let not_synch_nodes = List.filter is_not_synch_proc nodes in descendants := List.rev_append - (List.map self#get_proc not_synch_nodes) !descendants ; + (List.map self#get_proc not_synch_nodes) !descendants; add_desc (List.rev_append not_synch_nexts rest_reps) | _ -> () in - add_desc reps#toList ; + add_desc reps#toList; !descendants method get_ancestors (proc_name:symbol_t) = @@ -561,81 +562,81 @@ object (self: _) let prevs = List.filter (fun r -> not (on_the_list#has r)) prev_reps#toList in - on_the_list#addList prevs ; - on_the_list_now#remove rep ; - on_the_list_now#addList prevs ; + on_the_list#addList prevs; + on_the_list_now#remove rep; + on_the_list_now#addList prevs; let nodes = (self#get_value !rep_to_nodes rep)#toList in ancestors := - List.rev_append (List.map self#get_proc nodes) !ancestors ; + List.rev_append (List.map self#get_proc nodes) !ancestors; add_ancestors (List.rev_append prevs rest_reps) | _ -> () in - add_ancestors reps#toList ; + add_ancestors reps#toList; !ancestors method is_recursive proc_name = recursive_methods#has proc_name method private pr__debug_array3_int a = - pr__debug [STR "[|"; NL] ; + pr__debug [STR "[|"; NL]; let count = ref (-1) in (try for i = 0 to !last_index do for j = 0 to pred array_size do for k = 0 to pred array_size do - incr count ; - pr__debug [INT !count ; STR " -> "; INT a.(i).(j).(k); NL] ; + incr count; + pr__debug [INT !count; STR " -> "; INT a.(i).(j).(k); NL]; if !count = !last_index then raise Exit done done - done ; - with _ -> () ) ; + done; + with _ -> () ); pr__debug [STR "|]"; NL] method private pr__debug_array3_set a = - pr__debug [STR "[|"; NL] ; + pr__debug [STR "[|"; NL]; let count = ref (-1) in (try for i = 0 to !last_index do for j = 0 to pred array_size do for k = 0 to pred array_size do - incr count ; + incr count; let set = a.(i).(j).(k) in if not set#isEmpty then - pr__debug [INT !count ; STR " -> "; set#toPretty; NL] ; + pr__debug [INT !count; STR " -> "; set#toPretty; NL]; if !count = !last_index then raise Exit done done done - with _ -> () ) ; + with _ -> () ); pr__debug [STR "|]"; NL] method private pr__debug_array3 a = - pr__debug [STR "[|"; NL] ; + pr__debug [STR "[|"; NL]; let count = ref (-1) in (try for i = 0 to !last_index do for j = 0 to pred array_size do for k = 0 to pred array_size do - incr count ; - pr__debug [INT !count ; STR " -> "; a.(i).(j).(k)#toPretty; NL] ; + incr count; + pr__debug [INT !count; STR " -> "; a.(i).(j).(k)#toPretty; NL]; if !count = !last_index then raise Exit done done done - with _ -> () ) ; + with _ -> () ); pr__debug [STR "|]"; NL] method pr__debug : unit = - pr__debug [STR "call graph: "; NL; STR "index_to_proc: "; NL] ; - self#pr__debug_array3 !procs ; - pr__debug [STR "node_to_rep: "; NL] ; - self#pr__debug_array3_int !node_to_rep ; - pr__debug [STR "rep_to_nodes: "; NL] ; - self#pr__debug_array3_set !rep_to_nodes ; - pr__debug [STR "rep_edges: "; NL] ; - self#pr__debug_array3_set !rep_edges ; + pr__debug [STR "call graph: "; NL; STR "index_to_proc: "; NL]; + self#pr__debug_array3 !procs; + pr__debug [STR "node_to_rep: "; NL]; + self#pr__debug_array3_int !node_to_rep; + pr__debug [STR "rep_to_nodes: "; NL]; + self#pr__debug_array3_set !rep_to_nodes; + pr__debug [STR "rep_edges: "; NL]; + self#pr__debug_array3_set !rep_edges; pr__debug [STR "in_loop: "; NL; !in_loop#toPretty; NL]; - pr__debug [STR "recursive_methods: "; NL; recursive_methods#toPretty; NL] ; + pr__debug [STR "recursive_methods: "; NL; recursive_methods#toPretty; NL]; method toPretty = LBLOCK [STR "call graph: "; NL; @@ -671,26 +672,26 @@ class call_graph_manager_t all_procs not_analyzed edges = if !no_temp_files then begin - bottom_up_list := list ; - top_down_list := List.rev list ; + bottom_up_list := list; + top_down_list := List.rev list; in_loop_list := in_loop end else begin let bottom_up_channel = open_out bottom_up_file in - Marshal.to_channel bottom_up_channel list [Marshal.Closures] ; - close_out bottom_up_channel ; + Marshal.to_channel bottom_up_channel list [Marshal.Closures]; + close_out bottom_up_channel; let top_down_channel = open_out top_down_file in - Marshal.to_channel top_down_channel (List.rev list) [Marshal.Closures] ; - close_out top_down_channel ; + Marshal.to_channel top_down_channel (List.rev list) [Marshal.Closures]; + close_out top_down_channel; let in_loop_channel = open_out in_loop_file in - Marshal.to_channel in_loop_channel in_loop [Marshal.Closures] ; - close_out in_loop_channel ; - end ; + Marshal.to_channel in_loop_channel in_loop [Marshal.Closures]; + close_out in_loop_channel; + end; - call_graph#find_methods_that_access_static_fields ; + call_graph#find_methods_that_access_static_fields; call_graph#clean_up method get_top_down_list = @@ -700,11 +701,11 @@ class call_graph_manager_t all_procs not_analyzed edges = let top_down_channel = open_in top_down_file in let top_down_list:symbol_t list = Marshal.from_channel top_down_channel in - close_in top_down_channel ; + close_in top_down_channel; let in_loop_channel = open_in in_loop_file in let in_loop:SymbolCollections.set_t = Marshal.from_channel in_loop_channel in - close_in in_loop_channel ; + close_in in_loop_channel; (top_down_list, in_loop) end @@ -715,11 +716,11 @@ class call_graph_manager_t all_procs not_analyzed edges = let bottom_up_channel = open_in bottom_up_file in let bottom_up_list:symbol_t list = Marshal.from_channel bottom_up_channel in - close_in bottom_up_channel ; + close_in bottom_up_channel; let in_loop_channel = open_in in_loop_file in let in_loop:SymbolCollections.set_t = Marshal.from_channel in_loop_channel in - close_in in_loop_channel ; + close_in in_loop_channel; (bottom_up_list, in_loop) end diff --git a/CodeHawk/CHJ/jchsys/jCHCallGraph.mli b/CodeHawk/CHJ/jchsys/jCHCallGraph.mli index e652aa9a..7b5ae48a 100644 --- a/CodeHawk/CHJ/jchsys/jCHCallGraph.mli +++ b/CodeHawk/CHJ/jchsys/jCHCallGraph.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHCodeTransformers.ml b/CodeHawk/CHJ/jchsys/jCHCodeTransformers.ml index 296bc18c..b36a9e72 100644 --- a/CodeHawk/CHJ/jchsys/jCHCodeTransformers.ml +++ b/CodeHawk/CHJ/jchsys/jCHCodeTransformers.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -217,7 +217,7 @@ class variable_transformer_t = | INSERT _ | DELETE _ | ASSIGN_TABLE _ -> - pr_debug [STR "command not supported "; command_to_pretty 0 cmd] ; + pr_debug [STR "command not supported "; command_to_pretty 0 cmd]; raise (JCH_failure (LBLOCK [STR "command not supported "; command_to_pretty 0 cmd])) @@ -249,20 +249,20 @@ class skip_and_code_remover_t = inherit code_transformer_t as super method !transformCode (code:code_int) = - super#transformCode code ; + super#transformCode code; code#removeSkips method !transformCmd (cmd:(code_int, cfg_int) command_t):(code_int, cfg_int) command_t = match cmd with | CODE (s, code) -> - self#transformCode code ; + self#transformCode code; if code#length = 0 then SKIP else CODE (s, code) | TRANSACTION (s, code, None) -> - self#transformCode code ; + self#transformCode code; if code#length = 0 then SKIP else diff --git a/CodeHawk/CHJ/jchsys/jCHCodeTransformers.mli b/CodeHawk/CHJ/jchsys/jCHCodeTransformers.mli index 11f38f40..9a37dcc7 100644 --- a/CodeHawk/CHJ/jchsys/jCHCodeTransformers.mli +++ b/CodeHawk/CHJ/jchsys/jCHCodeTransformers.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHDominance.ml b/CodeHawk/CHJ/jchsys/jCHDominance.ml index 8c8a608b..dd817f3e 100644 --- a/CodeHawk/CHJ/jchsys/jCHDominance.ml +++ b/CodeHawk/CHJ/jchsys/jCHDominance.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHDominance.mli b/CodeHawk/CHJ/jchsys/jCHDominance.mli index d68e96f2..d9d76b00 100644 --- a/CodeHawk/CHJ/jchsys/jCHDominance.mli +++ b/CodeHawk/CHJ/jchsys/jCHDominance.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHGlobals.ml b/CodeHawk/CHJ/jchsys/jCHGlobals.ml index 911ad74c..a9716c60 100644 --- a/CodeHawk/CHJ/jchsys/jCHGlobals.ml +++ b/CodeHawk/CHJ/jchsys/jCHGlobals.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. sipma + Copyright (c) 2020-2025 Henny B. sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHGlobals.mli b/CodeHawk/CHJ/jchsys/jCHGlobals.mli index f6334236..3dd12f94 100644 --- a/CodeHawk/CHJ/jchsys/jCHGlobals.mli +++ b/CodeHawk/CHJ/jchsys/jCHGlobals.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -109,5 +110,3 @@ val int_dom_name : string val lin_dom_name : string val poly_dom_name : string val lin_eqs_dom_name : string - - diff --git a/CodeHawk/CHJ/jchsys/jCHLoopUtils.ml b/CodeHawk/CHJ/jchsys/jCHLoopUtils.ml index 16a7918f..dbf7f466 100755 --- a/CodeHawk/CHJ/jchsys/jCHLoopUtils.ml +++ b/CodeHawk/CHJ/jchsys/jCHLoopUtils.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -50,7 +50,7 @@ open JCHPrintUtils module H = Hashtbl -let dbg = ref false + let wto_index = ref (-1) @@ -75,7 +75,7 @@ class wto_info_t (* list of outer loops from the inner one to the outer one *) val outer_loops : 'a list ref = ref [] val index = - incr wto_index ; + incr wto_index; !wto_index val var_name = new symbol_t ~seqnr: !wto_index "lc" val var = @@ -114,16 +114,16 @@ class wto_info_t else begin let (epc, fpc, lpc, pcs, lpc') = self#get_entry_first_last in - entry_pc := epc ; - first_pc := fpc ; - last_pc := lpc ; - entry_incoming_pcs := pcs ; + entry_pc := epc; + first_pc := fpc; + last_pc := lpc; + entry_incoming_pcs := pcs; last_in_entry_state := lpc'; self#set_inloop_calls(); let method_info = app#get_method (retrieve_cms proc#getName#getSeqNumber) in let exception_handlers = method_info#get_exception_handlers in - all_catch_blocks := exception_handlers#get_handler_blocks ; + all_catch_blocks := exception_handlers#get_handler_blocks; catch_block_starts := self#find_catch_blocks_that_contain !first_pc end @@ -205,13 +205,13 @@ class wto_info_t else last in if !entry then begin - entry_pc := Option.get st_first_opt ; - entry := false ; - entry_incoming_sts := state#getIncomingEdges ; + entry_pc := Option.get st_first_opt; + entry := false; + entry_incoming_sts := state#getIncomingEdges; last_in_entry_state := st_last - end ; + end; if is_entry_incoming_st st_name then - entry_incoming_pcs := st_last :: !entry_incoming_pcs ; + entry_incoming_pcs := st_last :: !entry_incoming_pcs; get_pcs_rec (new_first, new_last) rest_ws | [] -> (first_opt, last) in let (first_opt, last) = get_pcs_rec (None, -1) [wto] in @@ -276,7 +276,7 @@ class wto_info_t for i = 0 to pred (Array.length table) do if table.(i) = offset then found := true - done ; + done; if !found then 2 else 0 end | OpLookupSwitch (_, pairs) -> @@ -294,7 +294,7 @@ class wto_info_t let check (pc: int) (opc:opcode_t) = if in_loop pc then begin - loop_pcs := (pc,opc) :: !loop_pcs ; + loop_pcs := (pc,opc) :: !loop_pcs; match opc with | OpInvokeStatic (cn,ms) | OpInvokeVirtual (TClass cn,ms) @@ -303,20 +303,20 @@ class wto_info_t call_pcs := (cn#index,ms#index,pc) :: !call_pcs | _ -> () end in - opcodes#iteri check ; + opcodes#iteri check; instr_count := List.length !loop_pcs method get_loop_info () = let get_pc_range w = (w#get_first_pc, w#get_last_pc) in - { li_first_pc = !first_pc ; - li_entry_pc = !entry_pc ; - li_last_pc = !last_pc ; - li_instr_count = !instr_count ; - li_cond_pcs = cond_pcs ; - li_inner_loops = List.map get_pc_range !inner_loops ; - li_outer_loops = List.map get_pc_range !outer_loops ; - li_max_iterations = !max_iterations ; - li_pc_invariants = [] ; + { li_first_pc = !first_pc; + li_entry_pc = !entry_pc; + li_last_pc = !last_pc; + li_instr_count = !instr_count; + li_cond_pcs = cond_pcs; + li_inner_loops = List.map get_pc_range !inner_loops; + li_outer_loops = List.map get_pc_range !outer_loops; + li_max_iterations = !max_iterations; + li_pc_invariants = []; li_calls = !call_pcs; } @@ -346,10 +346,10 @@ class wto_info_t pp_list_int !catch_block_starts] in LBLOCK [STR "wto "; name#toPretty; STR " from "; proc#getName#toPretty; NL; INDENT (5, LBLOCK [STR " index: "; INT index; NL; - pp_p; pp_ch; NL; - pp_w; NL; - pp_cb ; NL; - INDENT (5, LBLOCK [pp_c conds; pp_ec]); NL])] + pp_p; pp_ch; NL; + pp_w; NL; + pp_cb; NL; + INDENT (5, LBLOCK [pp_c conds; pp_ec]); NL])] end @@ -404,10 +404,10 @@ let get_first_states_out (cfg:cfg_int) (wto: wto_t) = List.find has_opp_name cfg#getStates with | Not_found -> - pr__debug [STR "state "; STR opp_name; STR " not found in JCHLoopUtils" ] ; + pr__debug [STR "state "; STR opp_name; STR " not found in JCHLoopUtils" ]; raise (JCH_failure - (LBLOCK [ STR "state " ; STR opp_name ; + (LBLOCK [ STR "state "; STR opp_name; STR " not found in JCHLoopUtils" ])) in let get_succ_out (s:symbol_t) = let state = cfg#getState s in @@ -433,7 +433,7 @@ let find_scc_prev_states if not (states#has p) then all_other_states := p :: !all_other_states in List.iter add_prev prev_states in - states#iter add ; + states#iter add; !all_other_states (* Finds other conditions the exit is under *) @@ -453,7 +453,7 @@ let find_prev_conds match !work_states with | s :: rest_states -> begin - work_states := rest_states ; + work_states := rest_states; let add_previous in_scc p = let p_name = p#getBaseName in (if p_name = wtoHead_name then @@ -464,7 +464,7 @@ let find_prev_conds begin covered_states#add p_name; if is_conditional p then - all_conds#add p ; + all_conds#add p; if in_scc then () else @@ -474,14 +474,14 @@ let find_prev_conds match H.find_opt state_to_scc_states s with | Some scc_states -> let prevs = find_scc_prev_states cfg scc_states in - scc_states#iter (add_previous true) ; + scc_states#iter (add_previous true); prevs | _ -> [] in - List.iter (add_previous false) ps ; + List.iter (add_previous false) ps; find_prev_states (); end | [] -> () in - find_prev_states () ; + find_prev_states (); all_conds#toList let add_all_wto_states (ws: wto_component_t list) = @@ -492,10 +492,10 @@ let add_all_wto_states (ws: wto_component_t list) = states#add s; add rest_ws | (SCC ws') :: rest_ws -> - add ws' ; + add ws'; add rest_ws | _ -> () in - add ws ; + add ws; states let make_state_to_scc_states (wto: wto_component_t) = @@ -536,7 +536,7 @@ let make_wto_info ~proc ~cfg ~proc_wto in - wto_info#set_outer_loops outer_loops ; + wto_info#set_outer_loops outer_loops; wto_info @@ -561,18 +561,18 @@ let get_sccs_proc procedure (proc_name: symbol_t) = match loops with | loop :: _rest_loops -> loop#add_inner_loop wto_info | _ -> () in - wto_infos := wto_info :: !wto_infos ; + wto_infos := wto_info :: !wto_infos; let new_depth = succ depth in (if new_depth > !max_depth then max_depth := new_depth else - ()) ; - addSCCs inner_ws (wto_info :: loops) new_depth ; + ()); + addSCCs inner_ws (wto_info :: loops) new_depth; addSCCs rest_ws loops depth | (VERTEX _) :: rest_ws -> addSCCs rest_ws loops depth | [] -> () in - addSCCs wto [] 0 ; + addSCCs wto [] 0; (List.rev !wto_infos, wto, !max_depth) @@ -585,18 +585,18 @@ let get_loop_infos (mInfo:method_info_int) = with | JCH_failure p -> begin - pr_debug [ STR "Failure in translating " ; - mInfo#get_class_method_signature#toPretty ; - STR ": " ; p ; NL ] ; - [ { li_first_pc = (-1) ; - li_entry_pc = (-1) ; - li_last_pc = (-1) ; - li_instr_count = (-1) ; - li_cond_pcs = [] ; - li_inner_loops = [] ; - li_outer_loops = [] ; - li_max_iterations = [] ; - li_pc_invariants = [] ; + pr_debug [ STR "Failure in translating "; + mInfo#get_class_method_signature#toPretty; + STR ": "; p; NL ]; + [ { li_first_pc = (-1); + li_entry_pc = (-1); + li_last_pc = (-1); + li_instr_count = (-1); + li_cond_pcs = []; + li_inner_loops = []; + li_outer_loops = []; + li_max_iterations = []; + li_pc_invariants = []; li_calls = [] } ] end diff --git a/CodeHawk/CHJ/jchsys/jCHLoopUtils.mli b/CodeHawk/CHJ/jchsys/jCHLoopUtils.mli index d5a85dad..f53d8b08 100644 --- a/CodeHawk/CHJ/jchsys/jCHLoopUtils.mli +++ b/CodeHawk/CHJ/jchsys/jCHLoopUtils.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -37,7 +37,7 @@ open JCHBasicTypesAPI (* jchpre *) open JCHPreAPI -val dbg : bool ref + class wto_info_t : is_proc_wto:bool -> name:symbol_t diff --git a/CodeHawk/CHJ/jchsys/jCHPrintUtils.ml b/CodeHawk/CHJ/jchsys/jCHPrintUtils.ml index ea9c16ba..a9dbbe29 100644 --- a/CodeHawk/CHJ/jchsys/jCHPrintUtils.ml +++ b/CodeHawk/CHJ/jchsys/jCHPrintUtils.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyrigth (c) 2020-2024 Henny B. Sipma + Copyrigth (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -62,13 +62,13 @@ let op_args_to_pretty op_args : pretty_t = | WRITE -> "WRITE" | _ -> "READ_WRITE" in let pp_arg (s,v,am) : pretty_t = - LBLOCK [ STR ("("^s^" , ") ; v#toPretty ; - STR " , "; STR (arg_mode_to_string am) ; + LBLOCK [STR ("("^s^" , "); v#toPretty; + STR " , "; STR (arg_mode_to_string am); STR " )"; NL] in pretty_print_list op_args pp_arg "" "" "" let operation_to_pretty op = - LBLOCK [ STR "operation " ; op.op_name#toPretty ;NL; + LBLOCK [STR "operation "; op.op_name#toPretty;NL; STR "op_args: "; NL; op_args_to_pretty op.op_args; STR "end op_args"; NL] @@ -94,7 +94,8 @@ let postcond_preds_to_pretty preds = pretty_print_list preds postcond_pred_to_pretty "{" "\n" " }" let precond_preds_to_pretty preds = - pretty_print_list preds JCHFunctionSummary.precondition_predicate_to_pretty "{" "\n" " }" + pretty_print_list + preds JCHFunctionSummary.precondition_predicate_to_pretty "{" "\n" " }" let side_effects_to_pretty preds = pretty_print_list preds JCHFunctionSummary.sideeffect_to_pretty "{" "\n" " }" @@ -118,8 +119,10 @@ let proc_table_pp (table: _ SymbolCollections.table_t) = (* print table proc -> set or table that prints only if they are not empty *) let proc_ltable_pp (table: _ SymbolCollections.table_t) = let add a k v = - if v#size = 0 then a - else [proc_name_pp k; STR " -> "; NL; INDENT (5, v#toPretty); NL] @ a in + if v#size = 0 then + a + else + [proc_name_pp k; STR " -> "; NL; INDENT (5, v#toPretty); NL] @ a in let elts = table#fold add [] in LBLOCK [STR "{"; NL; INDENT (2, LBLOCK elts); STR "}"] @@ -149,8 +152,11 @@ let pp_pc_table pc_table = [STR "{"; LBLOCK ( List.map - (fun pc -> LBLOCK [STR "pc = "; INT pc; STR " -> "; NL; - INDENT (5, (Option.get (pc_table#get pc))#toPretty); NL]) + (fun pc -> + LBLOCK [STR "pc = "; + INT pc; + STR " -> "; NL; + INDENT (5, (Option.get (pc_table#get pc))#toPretty); NL]) (List.rev (pc_table#listOfKeys))); NL; STR "}"] @@ -161,11 +167,15 @@ let pp_procpc_table sym_table = [STR "{"; LBLOCK ( List.map - (fun proc -> LBLOCK [proc#toPretty; STR ":"; NL; - INDENT (2, pp_pc_table (Option.get (sym_table#get proc))); NL]) + (fun proc -> + LBLOCK [ + proc#toPretty; + STR ":"; NL; + INDENT (2, pp_pc_table (Option.get (sym_table#get proc))); NL]) sym_table#listOfKeys); NL; STR "}"] + class pretty_int_t i = object @@ -203,7 +213,9 @@ let proc_name_str proc_name = let pp = (retrieve_cms proc_name#getSeqNumber)#toPretty in string_of_pretty [pp] -let pp_var_table_pred (table: VariableCollections.table_t) pred : pretty_t = +let pp_var_table_pred + (table: VariableCollections.table_t) + pred: pretty_t = let sorted_vars = let vars = List.filter pred (table#listOfKeys) in let compare (v1: variable_t) (v2: variable_t) = @@ -211,20 +223,20 @@ let pp_var_table_pred (table: VariableCollections.tabl List.sort compare vars in let mk_pp k = let vl = Option.get (table#get k) in - LBLOCK [k#toPretty ; STR " -> "; vl#toPretty; NL] in + LBLOCK [k#toPretty; STR " -> "; vl#toPretty; NL] in LBLOCK (List.map mk_pp sorted_vars) let pp_assoc_list_vars ls = let pp_pair (v1, v2) = - LBLOCK [ STR "("; v1#toPretty; STR ", "; v2#toPretty; STR ")"] in + LBLOCK [STR "("; v1#toPretty; STR ", "; v2#toPretty; STR ")"] in pretty_print_list ls pp_pair "{" ", " "}" let pp_assoc_list_ints ls = - let pp_pair (i1, i2) = LBLOCK [ STR "("; INT i1; STR ", "; INT i2; STR ")"] in + let pp_pair (i1, i2) = LBLOCK [STR "("; INT i1; STR ", "; INT i2; STR ")"] in pretty_print_list ls pp_pair "{" ", " "}" let pp_assoc_list_var_int ls = - let pp_pair (k, i) = LBLOCK [ STR "("; k#toPretty; STR ", "; INT i; STR ")"] in + let pp_pair (k, i) = LBLOCK [STR "("; k#toPretty; STR ", "; INT i; STR ")"] in pretty_print_list ls pp_pair "{" ", " "}" @@ -237,8 +249,8 @@ let read_int_to_var_set file_name = let (proc_name, list) (* : int * variable_t list *) = Marshal.from_channel in_channel in proc_to_set#set proc_name (VariableCollections.set_of_list list) - done ; - close_in in_channel ; + done; + close_in in_channel; proc_to_set (* Reads from file name a table int -> int set *) @@ -250,8 +262,8 @@ let read_int_to_int_set file_name = let (proc_name, list) (* : int * int list *) = Marshal.from_channel in_channel in proc_to_set#set proc_name (IntCollections.set_of_list list) - done ; - close_in in_channel ; + done; + close_in in_channel; proc_to_set (* Reads from file name a table int -> (table variable_t -> variable_t) *) @@ -264,10 +276,10 @@ let read_int_to_var_to_var file_name = Marshal.from_channel in_channel in let table = new VariableCollections.table_t in let add_pair (v1, v2) = table#set v1 v2 in - List.iter add_pair list ; + List.iter add_pair list; proc_to_set#set proc_name table - done ; - close_in in_channel ; + done; + close_in in_channel; proc_to_set (* Reads from file name a table int -> string set *) @@ -279,8 +291,8 @@ let read_int_to_string_set file_name = let (proc_name, list) (* : int * string list *) = Marshal.from_channel in_channel in proc_to_set#set proc_name (StringCollections.set_of_list list) - done ; - close_in in_channel ; + done; + close_in in_channel; proc_to_set let jch_stats_log = CHLogger.mk_logger () @@ -316,7 +328,10 @@ let rec jterm_to_string jterm = | JSize t -> "size (" ^ (jterm_to_string t) ^ ")" | JPower (t,n) -> "pow (" ^ (jterm_to_string t) ^ ", " ^ (string_of_int n) ^ ")" | JUninterpreted (name,terms) -> - "un:" ^ name ^ " (" ^ (String.concat "," (List.map jterm_to_string terms)) ^ ")" + "un:" + ^ name + ^ " (" ^ (String.concat "," (List.map jterm_to_string terms)) + ^ ")" | JArithmeticExpr (op, t1, t2) -> (jterm_to_string t1) ^ (arithmetic_op_to_string op) ^ (jterm_to_string t2) | jterm -> JCHJTerm.jterm_to_string jterm @@ -325,7 +340,7 @@ let relational_expr_to_string (op, t1, t2) = (jterm_to_string t1) ^ (relational_op_to_string op) ^ (jterm_to_string t2) let pr__debug_large_table pp table = - pr__debug [STR "{"; NL] ; + pr__debug [STR "{"; NL]; List.iter (fun (k, v) -> pr__debug [INT k; STR " -> "]; pp v; pr__debug[NL]) table#listOfPairs; pr__debug [STR "}"; NL] diff --git a/CodeHawk/CHJ/jchsys/jCHPrintUtils.mli b/CodeHawk/CHJ/jchsys/jCHPrintUtils.mli index 7f0f7aad..3da5b585 100644 --- a/CodeHawk/CHJ/jchsys/jCHPrintUtils.mli +++ b/CodeHawk/CHJ/jchsys/jCHPrintUtils.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -74,7 +74,8 @@ val proc_list_pp : symbol_t list -> pretty_t val dot_name : symbol_t -> string -val pp_var_table : (int * int * string * value_type_t * int) list option -> pretty_t +val pp_var_table : + (int * int * string * value_type_t * int) list option -> pretty_t val pp_pc_table : < toPretty : pretty_t; .. > IntCollections.table_t -> pretty_t @@ -145,4 +146,5 @@ val jch_stats_log : logger_int val jterm_to_string : jterm_t -> string val relational_expr_to_string : relational_expr_t -> string -val pr__debug_large_table : ('a -> unit) -> < listOfPairs : (int * 'a) list; .. > -> unit +val pr__debug_large_table : + ('a -> unit) -> < listOfPairs : (int * 'a) list; .. > -> unit diff --git a/CodeHawk/CHJ/jchsys/jCHProcInfo.ml b/CodeHawk/CHJ/jchsys/jCHProcInfo.ml index 2a27350a..c6b66c54 100644 --- a/CodeHawk/CHJ/jchsys/jCHProcInfo.ml +++ b/CodeHawk/CHJ/jchsys/jCHProcInfo.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -41,7 +42,6 @@ open JCHJTerm (* jchpre *) open JCHApplication -open JCHBytecodeLocation open JCHPreAPI (* jchsys *) @@ -49,15 +49,14 @@ open JCHGlobals open JCHPrintUtils open JCHVarInfo -let dbg = ref false class scope_t (* (orig_var: variable_t) *) ~(first_pc: int) ~(last_pc: int) ~(types: value_type_t list) ~(index: int) - ~(vars: VariableCollections.set_t) = - object (self: 'a) + ~(vars: VariableCollections.set_t) = + object (self: 'a) val first_pc = ref first_pc val last_pc = ref last_pc val types = ref types @@ -65,53 +64,53 @@ class scope_t (* (orig_var: variable_t) *) method get_first_pc = !first_pc method get_last_pc = !last_pc - method get_types = !types + method get_types = !types method get_index = index method get_vars = !vars - + method set_vars vs = vars := vs method set_types ts = types := ts - method private is_in pc = + method private is_in pc = pc >= !first_pc && pc <= !last_pc - method overlaps (s: 'a) = - index = s#get_index && + method overlaps (s: 'a) = + index = s#get_index && (self#is_in s#get_first_pc || self#is_in s#get_last_pc) method private union_types (types1:value_type_t list) - (types2:value_type_t list) = - let add_type types vt = + (types2:value_type_t list) = + let add_type types vt = if List.exists (fun t -> compare_value_types vt t = 0) types1 then types else vt :: types in List.fold_left add_type types1 types2 - method union (s: 'a) = - {< first_pc = ref (min !first_pc s#get_first_pc) ; - last_pc = ref (max !last_pc s#get_last_pc) ; - types = ref (self#union_types !types s#get_types) ; + method union (s: 'a) = + {< first_pc = ref (min !first_pc s#get_first_pc); + last_pc = ref (max !last_pc s#get_last_pc); + types = ref (self#union_types !types s#get_types); vars = ref (!vars#union s#get_vars) >} - method union_keep_vars (s: 'a) = - {< first_pc = ref (min !first_pc s#get_first_pc) ; - last_pc = ref (max !last_pc s#get_last_pc) ; + method union_keep_vars (s: 'a) = + {< first_pc = ref (min !first_pc s#get_first_pc); + last_pc = ref (max !last_pc s#get_last_pc); types = ref (self#union_types !types s#get_types) >} - method decrease_first_pc pc = + method decrease_first_pc pc = if pc < !first_pc then first_pc := pc - method increase_last_pc pc = + method increase_last_pc pc = if pc > !last_pc then last_pc := pc (* sorted_scopes have to be sorted increasingly in the order of first_pc * It increases the scope of the corresponding write scope *) method add_to_list (sorted_scopes: 'a list) = - let rec find_scope (prev_scope:'a option) (scopes:'a list) = - match scopes with - | scope :: rest_scopes -> + let rec find_scope (prev_scope:'a option) (scopes:'a list) = + match scopes with + | scope :: rest_scopes -> if scope#get_first_pc > !first_pc then prev_scope else @@ -121,187 +120,188 @@ class scope_t (* (orig_var: variable_t) *) (* It's possible that there is no write before the read *) | Some scope -> begin - scope#increase_last_pc !last_pc ; - scope#set_types (self#union_types !types scope#get_types) ; + scope#increase_last_pc !last_pc; + scope#set_types (self#union_types !types scope#get_types); scope#set_vars (!vars#union scope#get_vars) end - | _ -> + | _ -> let scope = List.hd sorted_scopes in begin - scope#decrease_first_pc !first_pc ; - scope#set_types (self#union_types !types scope#get_types) ; + scope#decrease_first_pc !first_pc; + scope#set_types (self#union_types !types scope#get_types); scope#set_vars (!vars#union scope#get_vars) end - method make_var_table_line (opcodes:opcodes_int) (mInfo:method_info_int) = + method make_var_table_line (opcodes:opcodes_int) (mInfo:method_info_int) = let first_pc = if !first_pc <= 0 then 0 - else + else try - Option.get (opcodes#next !first_pc) + Option.get (opcodes#next !first_pc) with _ -> !first_pc in - let last_pc = + let last_pc = if !last_pc = -1 then - 0 + 0 else if !last_pc < first_pc then - first_pc + first_pc else - !last_pc in - let name = + !last_pc in + let name = let name = mInfo#get_local_variable_name index last_pc in - match name with - | "none" -> mInfo#get_local_variable_name index first_pc + match name with + | "none" -> mInfo#get_local_variable_name index first_pc | _ -> name in (first_pc, last_pc, name, JCHTypeUtils.get_compact_type !types, index) - method toPretty = - LBLOCK [ STR "scope "; INT index ; STR " "; !vars#toPretty ; STR " ["; - INT !first_pc; STR "; "; INT !last_pc; - pretty_print_list !types value_type_to_pretty "] {" ", " "}" ; - NL ] - + method toPretty = + LBLOCK [STR "scope "; INT index; STR " "; !vars#toPretty; STR " ["; + INT !first_pc; STR "; "; INT !last_pc; + pretty_print_list !types value_type_to_pretty "] {" ", " "}"; + NL] + end - + module ScopeCollections = CHCollections.Make - (struct + (struct type t = scope_t - let compare (s1: scope_t) (s2: scope_t) = + let compare (s1: scope_t) (s2: scope_t) = let n = s1#get_index - s2#get_index in - if n = 0 then + if n = 0 then let m = s1#get_first_pc - s2#get_first_pc in - if m = 0 then - s1#get_last_pc - s2#get_last_pc + if m = 0 then + s1#get_last_pc - s2#get_last_pc else m - else n + else n let toPretty s = s#toPretty end) class pc_analysis_results_t = -object (self: 'a) - +object + val invariants = ref [] - (* (var, untrusted_origin_set, unknown_origin_set) list *) - val taint_origins = ref [] - - method set_invariants (invs: relational_expr_t list) = + (* (var, untrusted_origin_set, unknown_origin_set) list *) + val taint_origins = ref [] + + method set_invariants (invs: relational_expr_t list) = invariants := invs - - method get_invariants = !invariants - method set_taint_origins (origs: (variable_t * taint_origin_set_int) list) = + method get_invariants = !invariants + + method set_taint_origins (origs: (variable_t * taint_origin_set_int) list) = taint_origins := origs - + method get_taint_origins = !taint_origins - method toPretty = - let pp_invariants = - let pp_rel (op, t1, t2) = - LBLOCK [ STR " "; jterm_to_pretty t1; - STR (" "^ (relational_op_to_string op) ^ " "); - jterm_to_pretty t2; NL ] in + method toPretty = + let pp_invariants = + let pp_rel (op, t1, t2) = + LBLOCK [STR " "; jterm_to_pretty t1; + STR (" "^ (relational_op_to_string op) ^ " "); + jterm_to_pretty t2; NL] in LBLOCK (List.map pp_rel !invariants) in - let pp_taints = + let pp_taints = let pp_taint (v, untrusted) = - LBLOCK [ STR " "; - v#toPretty; STR "("; untrusted#toPretty; STR ")"; NL ] in + LBLOCK [STR " "; + v#toPretty; STR "("; untrusted#toPretty; STR ")"; NL] in LBLOCK (List.map pp_taint !taint_origins) in - LBLOCK [pp_invariants; pp_taints] - + LBLOCK [pp_invariants; pp_taints] + end -class analysis_results_t = -object (self: 'a) - +class analysis_results_t = +object + val pc_to_res = new IntCollections.table_t (* pc -> pc_analysis_results *) - + val return_origins = ref None - + method get_pc_analysis_results = pc_to_res - + method get_return_origins = !return_origins - method set_invariants (pc:int) (invs:relational_expr_t list) = - let res = - match pc_to_res#get pc with + method set_invariants (pc:int) (invs:relational_expr_t list) = + let res = + match pc_to_res#get pc with | Some res -> res - | _ -> + | _ -> let res = new pc_analysis_results_t in begin - pc_to_res#set pc res ; + pc_to_res#set pc res; res end in - res#set_invariants invs + res#set_invariants invs method set_taint_origins - (pc:int) (origs:(variable_t * taint_origin_set_int) list) = + (pc:int) (origs:(variable_t * taint_origin_set_int) list) = match pc_to_res#get pc with - | Some res -> + | Some res -> res#set_taint_origins origs - | _ -> + | _ -> let res = new pc_analysis_results_t in begin - res#set_taint_origins origs ; + res#set_taint_origins origs; pc_to_res#set pc res end - + method set_return_origins (untrusted_origins: taint_origin_set_int) = return_origins := Some (untrusted_origins) - method toPretty = - let pp_return_origins = - match !return_origins with + method toPretty = + let pp_return_origins = + match !return_origins with | Some (untrusted) -> LBLOCK [STR "return taint: "; untrusted#toPretty] | _ -> STR "" in - LBLOCK [STR "analysis results: "; NL; pc_to_res#toPretty; pp_return_origins; NL] + LBLOCK [STR "analysis results: "; NL; pc_to_res#toPretty; pp_return_origins; NL] end + class jproc_info_t ~(proc_name: symbol_t) ~(proc: procedure_int) ~(wto: CHSCC.wto_t) (* wto of the method *) (* wto_info's for all the loops, including inner loops *) - ~(wto_infos: JCHLoopUtils.wto_info_t list) + ~(wto_infos: JCHLoopUtils.wto_info_t list) ~(loop_depth: int) (* maximum loop depth *) - ~(pc_to_instr: int -> int) (* instruction offset -> istruction number *) + ~(pc_to_instr: int -> int) (* instruction offset -> istruction number *) ~(instr_to_pc: int -> int) = (* instruction number -> instruction offset *) - object (self: 'a) - + object (self: 'a) + val jvar_infos : jvar_info_t VariableCollections.table_t ref = ref (new VariableCollections.table_t) - + val cms = retrieve_cms proc_name#getSeqNumber - + val meth = (app#get_method (retrieve_cms proc_name#getSeqNumber))#get_method - + val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - - val bytecode = + + val bytecode = let mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) in if mInfo#has_bytecode then mInfo#get_bytecode else raise (JCH_failure (STR "expected bytecode")) - + val var_to_var_to_eqs = ref None (* x -> y -> states where ASSERT x = y *) - (* x -> y -> states where ASSERT x < y or x <= y *) + (* x -> y -> states where ASSERT x < y or x <= y *) val var_to_var_to_ineqs = ref None (* number of variables that could carry numeric info such as int, long, ..., - * java.lang.Integer, ..., java.util.Collections, ..., java.lang.Object *) + * java.lang.Integer, ..., java.util.Collections, ..., java.lang.Object *) val numeric_vars = ref 0 - + val number_vars = ref 0 (* number of variables that have _num suffix *) - (* obtained from the local variable table or constructed if this is not - * available : first instr * last instr * types * index *) + (* obtained from the local variable table or constructed if this is not + * available : first instr * last instr * types * index *) val var_table = ref [] - + val analysis_results = new analysis_results_t - - method get_analysis_results = analysis_results - method get_name = proc_name + + method get_analysis_results = analysis_results + method get_name = proc_name method get_method = meth method get_method_info = mInfo method get_procedure = proc @@ -309,17 +309,17 @@ class jproc_info_t method get_wto_infos = wto_infos method get_wto = wto method get_loop_depth = loop_depth - method get_loop_number = List.length wto_infos + method get_loop_number = List.length wto_infos method get_pc_to_instr = pc_to_instr method get_instr_to_pc = instr_to_pc method get_jvar_infos = !jvar_infos method get_jvar_info v = Option.get (!jvar_infos#get v) - method get_bytecode = bytecode + method get_bytecode = bytecode method get_opcodes = bytecode#get_code method get_variables = proc#getScope#getVariables - method get_var_to_var_to_eqs = Option.get !var_to_var_to_eqs - method get_var_to_var_to_ineqs = Option.get !var_to_var_to_ineqs - method get_count_numeric_vars = !numeric_vars + method get_var_to_var_to_eqs = Option.get !var_to_var_to_eqs + method get_var_to_var_to_ineqs = Option.get !var_to_var_to_ineqs + method get_count_numeric_vars = !numeric_vars method get_count_number_vars = !number_vars method get_var_table = !var_table method get_source_origin = (app#get_class cms#class_name)#get_source_origin @@ -327,12 +327,12 @@ class jproc_info_t method set_var_table (table:(int * int * string * value_type_t list * int) list) = var_table := table - - method has_orig_var_table = - Option.is_some bytecode#get_local_variable_table + + method has_orig_var_table = + Option.is_some bytecode#get_local_variable_table (* It makes sets of local variables that are connected via phi variables - * Such variables will get a single line in the local variable table *) + * Such variables will get a single line in the local variable table *) method private group_local_vars (aliases:JCHTransformUtils.alias_sets_t) (orig_phi_to_vars: VariableCollections.set_t VariableCollections.table_t) = @@ -341,112 +341,114 @@ class jproc_info_t let consts = new VariableCollections.set_t in let const_to_phis = new VariableCollections.table_t in - let add_var (var:variable_t) (var_info:jvar_info_t) = - if var_info#is_local_var then + let add_var (var:variable_t) (var_info:jvar_info_t) = + if var_info#is_local_var then begin if (List.length var_info#get_local_indices) = 1 then - (* The constant versions are omitted if they correspond to - * multiple registers *) + (* The constant versions are omitted if they correspond to + * multiple registers *) begin - var_to_rep#set var var ; - rep_to_vars#set var (VariableCollections.set_of_list [var]) + var_to_rep#set var var; + rep_to_vars#set var (VariableCollections.set_of_list [var]) end else - consts#add var + consts#add var end in - !jvar_infos#iter add_var ; - - (* Add the original SSA variables that were aliased to a constant local + !jvar_infos#iter add_var; + + (* Add the original SSA variables that were aliased to a constant local * variable *) let representatives = aliases#get_representatives in - let add_consts (orig_var:variable_t) (rep:variable_t) = - if JCHSystemUtils.is_register orig_var then + let add_consts (orig_var:variable_t) (rep:variable_t) = + if JCHSystemUtils.is_register orig_var then begin - match !jvar_infos#get rep with - | Some jvar_info -> + match !jvar_infos#get rep with + | Some jvar_info -> if jvar_info#is_local_var - && Option.is_some jvar_info#get_constant then + && Option.is_some jvar_info#get_constant then begin - var_to_rep#set orig_var orig_var ; + var_to_rep#set orig_var orig_var; rep_to_vars#set - orig_var (VariableCollections.set_of_list [orig_var]) + orig_var (VariableCollections.set_of_list [orig_var]) end - | _ -> () + | _ -> () end in - - representatives#iter add_consts ; + + representatives#iter add_consts; let add_const_to_phis - (orig_phi: variable_t) (orig_vars: VariableCollections.set_t) = - if JCHSystemUtils.is_register orig_phi then + (orig_phi: variable_t) (orig_vars: VariableCollections.set_t) = + if JCHSystemUtils.is_register orig_phi then match aliases#get_representative orig_phi with - | Some phi -> - let add_const orig_var = - if JCHSystemUtils.is_register orig_var then - match aliases#get_representative orig_var with - | Some var -> + | Some phi -> + let add_const orig_var = + if JCHSystemUtils.is_register orig_var then + match aliases#get_representative orig_var with + | Some var -> begin - match !jvar_infos#get var with - | Some jvar_info -> + match !jvar_infos#get var with + | Some jvar_info -> if jvar_info#is_local_var - && Option.is_some jvar_info#get_constant then + && Option.is_some jvar_info#get_constant then begin - var_to_rep#set orig_var orig_var ; + var_to_rep#set orig_var orig_var; rep_to_vars#set - orig_var (VariableCollections.set_of_list [orig_var]) ; - match const_to_phis#get orig_var with + orig_var + (VariableCollections.set_of_list [orig_var]); + match const_to_phis#get orig_var with | Some set -> set#add phi - | _ -> const_to_phis#set - orig_var (VariableCollections.set_of_list [phi]) + | _ -> + const_to_phis#set + orig_var (VariableCollections.set_of_list [phi]) end - | _ -> () + | _ -> () end | _ -> () in - orig_vars#iter add_const ; + orig_vars#iter add_const; | _ -> () in - - orig_phi_to_vars#iter add_const_to_phis ; - let add_connection (var1:variable_t) (var2:variable_t) = - try + orig_phi_to_vars#iter add_const_to_phis; + + let add_connection (var1:variable_t) (var2:variable_t) = + try let rep1 = Option.get (var_to_rep#get var1) in let rep2 = Option.get (var_to_rep#get var2) in - if rep1#getIndex <> rep2#getIndex then + if rep1#getIndex <> rep2#getIndex then let set1 = Option.get (rep_to_vars#get rep1) in let set2 = Option.get (rep_to_vars#get rep2) in begin - rep_to_vars#set rep1 (set1#union set2) ; - set2#iter (fun v -> var_to_rep#set v rep1) ; - rep_to_vars#remove rep2 ; - end + rep_to_vars#set rep1 (set1#union set2); + set2#iter (fun v -> var_to_rep#set v rep1); + rep_to_vars#remove rep2; + end with _ -> () in - let add_connections (var:variable_t) = - match !jvar_infos#get var with - | Some jvar_info -> - if jvar_info#is_phi then - let is_non_const (var:variable_t) = + let add_connections (var:variable_t) = + match !jvar_infos#get var with + | Some jvar_info -> + if jvar_info#is_phi then + let is_non_const (var:variable_t) = Option.is_none ((Option.get (!jvar_infos#get var))#get_constant) in List.iter (add_connection var) - (List.filter is_non_const jvar_info#get_read_vars) - | _ -> + (List.filter is_non_const jvar_info#get_read_vars) + | _ -> begin - match const_to_phis#get var with - | Some phis -> phis#iter (fun phi -> add_connection phi var) - | _ -> () + match const_to_phis#get var with + | Some phis -> phis#iter (fun phi -> add_connection phi var) + | _ -> () end in - - List.iter add_connections (var_to_rep#listOfKeys) ; + + List.iter add_connections (var_to_rep#listOfKeys); var_to_rep - + method set_var_infos - ~(chif:system_int) ~(dom_info:JCHDominance.dominance_info_t) ~(aliases:JCHTransformUtils.alias_sets_t) - ~(extra_assert_vars:SymbolCollections.set_t VariableCollections.table_t) = + ~(extra_assert_vars: + SymbolCollections.set_t VariableCollections.table_t) = let cfg = JCHSystemUtils.get_CFG proc in - let opcodes = bytecode#get_code in + let _opcodes = bytecode#get_code in let lc_to_pc:(variable_t * int) list = List.map (fun wto_info -> (wto_info#get_var, wto_info#get_entry_pc)) @@ -456,100 +458,98 @@ class jproc_info_t v_to_v_to_ineqs, nvars1, nvars2, - local_var_index_to_pc_to_var) = + local_var_index_to_pc_to_var) = make_jvar_infos - ~chif ~meth ~proc ~cfg - ~opcodes ~lc_to_pc ~wto ~dom_info ~aliases ~extra_assert_vars in begin - jvar_infos := var_infos ; - var_to_var_to_eqs := Some v_to_v_to_eqs ; - var_to_var_to_ineqs := Some v_to_v_to_ineqs ; - numeric_vars := nvars1 ; - number_vars := nvars2 ; + jvar_infos := var_infos; + var_to_var_to_eqs := Some v_to_v_to_eqs; + var_to_var_to_ineqs := Some v_to_v_to_ineqs; + numeric_vars := nvars1; + number_vars := nvars2; local_var_index_to_pc_to_var end - + method private make_local_variable_table - ~(aliases:JCHTransformUtils.alias_sets_t) + ~(aliases:JCHTransformUtils.alias_sets_t) ~(rvar_to_pc_to_versions:VariableCollections.set_t IntCollections.table_t VariableCollections.table_t) ~(orig_phi_to_vars:VariableCollections.set_t - VariableCollections.table_t) + VariableCollections.table_t) ~(local_var_index_to_pc_to_var: variable_t IntCollections.table_t IntCollections.table_t) = let index_to_scopes = new IntCollections.table_t in - let get_rep var = - match aliases#get_representative var with + let get_rep var = + match aliases#get_representative var with | Some rep -> rep - | _ -> var in + | _ -> var in let var_to_rep = self#group_local_vars aliases orig_phi_to_vars in let index_to_rvar = new IntCollections.table_t in (* Note: table is not used in this function *) - let add_rvar (v:variable_t) table = + let add_rvar (v:variable_t) _table = let name = v#getName#getBaseName in - if name.[0] = 'r' && name.[1] <> 'e' then + if name.[0] = 'r' && name.[1] <> 'e' then begin let ind = int_of_string (Str.string_after name 1) in - index_to_rvar#set ind v + index_to_rvar#set ind v end in - rvar_to_pc_to_versions#iter add_rvar ; + rvar_to_pc_to_versions#iter add_rvar; - let add_write_var (index:int) table = - let add_scope (pc:int) (var:variable_t) = + let add_write_var (index:int) table = + let add_scope (pc:int) (var:variable_t) = let jvar_info = Option.get (!jvar_infos#get var) in - let types = jvar_info#get_types in - let vars = + let types = jvar_info#get_types in + let vars = if Option.is_some jvar_info#get_constant then - let orig_var = Option.get (index_to_rvar#get index) in - let table = Option.get (rvar_to_pc_to_versions#get orig_var) in - match table#get pc with - | Some versions -> - let reps = new VariableCollections.set_t in - let add_rep v = - match var_to_rep#get v with - | Some rep -> reps#add rep + let orig_var = Option.get (index_to_rvar#get index) in + let table = Option.get (rvar_to_pc_to_versions#get orig_var) in + match table#get pc with + | Some versions -> + let reps = new VariableCollections.set_t in + let add_rep v = + match var_to_rep#get v with + | Some rep -> reps#add rep | _ -> () in begin - versions#iter add_rep ; + versions#iter add_rep; reps end - | _ -> VariableCollections.set_of_list [var] + | _ -> VariableCollections.set_of_list [var] else VariableCollections.set_of_list [var] in - let scope = new scope_t ~first_pc:pc ~last_pc:pc ~types ~index ~vars in - match index_to_scopes#get index with - | Some set -> set#add scope ; + let scope = new scope_t ~first_pc:pc ~last_pc:pc ~types ~index ~vars in + match index_to_scopes#get index with + | Some set -> set#add scope; | _ -> - index_to_scopes#set index (ScopeCollections.set_of_list [scope]) in + index_to_scopes#set index (ScopeCollections.set_of_list [scope]) in - table#iter add_scope in - local_var_index_to_pc_to_var#iter add_write_var ; + table#iter add_scope in + local_var_index_to_pc_to_var#iter add_write_var; let index_to_sorted_scopes = ref [] in - let sort_scopes (ind:int) (scopes:ScopeCollections.set_t) = + let sort_scopes (ind:int) (scopes:ScopeCollections.set_t) = let sorted_scopes = List.sort (fun s1 s2 -> s1#get_first_pc - s2#get_first_pc) scopes#toList in index_to_sorted_scopes := (ind, sorted_scopes) :: !index_to_sorted_scopes in - index_to_scopes#iter sort_scopes ; - + index_to_scopes#iter sort_scopes; + let add_read_scope_v - (orig:variable_t) (name:string) (pc:int) (v:variable_t) = + (_orig: variable_t) (name: string) (pc:int) (v: variable_t) = let rep = get_rep v in let index = int_of_string (Str.string_after name 1) in - match !jvar_infos#get rep with + match !jvar_infos#get rep with | Some jvar_info -> begin let types = jvar_info#get_types in @@ -561,7 +561,7 @@ class jproc_info_t ~index ~vars:(VariableCollections.set_of_list [v]) in let sorted_scopes = List.assoc index !index_to_sorted_scopes in - scope#add_to_list sorted_scopes + scope#add_to_list sorted_scopes end | _ -> () in @@ -570,43 +570,43 @@ class jproc_info_t (orig:variable_t) (name:string) (pc:int) - (vs:VariableCollections.set_t) = + (vs:VariableCollections.set_t) = vs#iter (add_read_scope_v orig name pc) in let name = var#getName#getBaseName in - if name.[0] = 'r' && name.[1] != 'e' then - table#iter (add_read_scope var name) in + if name.[0] = 'r' && name.[1] != 'e' then + table#iter (add_read_scope var name) in + + rvar_to_pc_to_versions#iter add_read_var; - rvar_to_pc_to_versions#iter add_read_var ; - let new_index_to_sorted_scopes = ref [] in - let compact (index, scopes) = + let compact (index, scopes) = let scope_set = ScopeCollections.set_of_list scopes in - let rec compact_scopes () = - let rec compact_one scope = + let rec compact_scopes () = + let compact_one scope = let vars = scope#get_vars in - let check scope' = + let check scope' = let vars' = scope'#get_vars in if scope#get_first_pc <> scope'#get_first_pc - && not (vars#inter vars')#isEmpty then + && not (vars#inter vars')#isEmpty then begin - scope_set#remove scope ; - scope_set#remove scope' ; - let new_scope = scope#union scope' in - scope_set#add new_scope ; - compact_scopes () + scope_set#remove scope; + scope_set#remove scope'; + let new_scope = scope#union scope' in + scope_set#add new_scope; + compact_scopes () end in scope_set#iter check in scope_set#iter compact_one in - compact_scopes () ; + compact_scopes (); let sorted_scopes = List.sort (fun s1 s2 -> s1#get_first_pc - s2#get_first_pc) scope_set#toList in - let rec reduce_scopes (red_scopes:scope_t list) (scopes:scope_t list) = - match scopes with - | scope1 :: scope2 :: rest_scopes -> - if scope1#get_last_pc > scope2#get_first_pc then - reduce_scopes red_scopes ((scope1#union scope2) :: rest_scopes) + let rec reduce_scopes (red_scopes:scope_t list) (scopes:scope_t list) = + match scopes with + | scope1 :: scope2 :: rest_scopes -> + if scope1#get_last_pc > scope2#get_first_pc then + reduce_scopes red_scopes ((scope1#union scope2) :: rest_scopes) else reduce_scopes (scope1 :: red_scopes) (scope2 :: rest_scopes) | [scope] -> scope :: red_scopes @@ -614,80 +614,80 @@ class jproc_info_t new_index_to_sorted_scopes := (index, reduce_scopes [] sorted_scopes) :: !new_index_to_sorted_scopes in - List.iter compact !index_to_sorted_scopes ; - index_to_sorted_scopes := !new_index_to_sorted_scopes ; - + List.iter compact !index_to_sorted_scopes; + index_to_sorted_scopes := !new_index_to_sorted_scopes; + let all_scopes = List.flatten (List.map snd !index_to_sorted_scopes) in List.map (fun s -> s#make_var_table_line self#get_opcodes self#get_method_info) - all_scopes - + all_scopes + method make_var_table ~(aliases: JCHTransformUtils.alias_sets_t) ~(rvar_to_pc_to_versions:VariableCollections.set_t IntCollections.table_t - VariableCollections.table_t) + VariableCollections.table_t) ~(orig_phi_to_vars: VariableCollections.set_t - VariableCollections.table_t) + VariableCollections.table_t) ~(local_var_index_to_pc_to_var :variable_t IntCollections.table_t - IntCollections.table_t) = - match bytecode#get_local_variable_table with - | Some local_var_table -> - let transform_line (first_pc, len_pc, name, vtype, index) = + IntCollections.table_t) = + match bytecode#get_local_variable_table with + | Some local_var_table -> + let transform_line (first_pc, len_pc, name, vtype, index) = (first_pc, first_pc + len_pc, name, [vtype], index) in let loc_var_table = List.map transform_line local_var_table in - var_table := loc_var_table ; - | _ -> + var_table := loc_var_table; + | _ -> var_table := self#make_local_variable_table ~aliases ~rvar_to_pc_to_versions ~orig_phi_to_vars - ~local_var_index_to_pc_to_var + ~local_var_index_to_pc_to_var (* Has to be called after set_var_infos *) (* Is not used yet *) - method get_length (var:variable_t) = - try + method get_length (var:variable_t) = + try let var_info = self#get_jvar_info var in let (len_opt, has_length_var) = (* This is not the same variable as the one in the scope of the method *) - var_info#get_length in - let len = Option.get len_opt in + var_info#get_length in + let len = Option.get len_opt in let length = List.find len#equal self#get_variables in - if not has_length_var then + if not has_length_var then begin - var_info#set_corresp_length length ; + var_info#set_corresp_length length; let length_info = Option.get (!jvar_infos#get length) in - length_info#set_corresp_var var - end ; + length_info#set_corresp_var var + end; Some length with _ -> None - method get_variable_from_length (length:variable_t) = - try + method get_variable_from_length (length:variable_t) = + try let length_info = self#get_jvar_info length in let (v_opt, has_var) = (* This is not the same variable as the one in the scope of the method *) - length_info#get_variable_from_length in + length_info#get_variable_from_length in let v = Option.get v_opt in let var = List.find v#equal self#get_variables in - if not has_var then + if not has_var then begin - length_info#set_corresp_var var ; + length_info#set_corresp_var var; let var_info = Option.get (!jvar_infos#get var) in var_info#set_corresp_length length - end ; + end; Some var with _ -> None - method get_wto_prev_pc_to_entry_pcs = + method get_wto_prev_pc_to_entry_pcs = let pc_to_entry_pcs = ref [] in - let add_wto (wto:JCHLoopUtils.wto_info_t) = + let add_wto (wto:JCHLoopUtils.wto_info_t) = let pc = wto#get_entry_pc in let state = self#get_cfg#getState wto#get_name in let prev_pcs = @@ -696,35 +696,35 @@ class jproc_info_t (fun prev_pc -> pc_to_entry_pcs := (prev_pc, pc) :: !pc_to_entry_pcs) prev_pcs in begin - List.iter add_wto wto_infos ; + List.iter add_wto wto_infos; !pc_to_entry_pcs end - - method private pp_var_table_ table = - let pp_var_table_line (first, last, name, types, ind) = - LBLOCK [INT first; STR " "; INT last; STR (" "^ name); + + method private pp_var_table_ table = + let pp_var_table_line (first, last, name, types, ind) = + LBLOCK [INT first; STR " "; INT last; STR (" "^ name); pretty_print_list types value_type_to_pretty " {" ", " "} "; INT ind; NL] in - LBLOCK (List.map pp_var_table_line table) - + LBLOCK (List.map pp_var_table_line table) + method toPretty = LBLOCK [proc_name#toPretty; NL; INDENT (2, LBLOCK - [STR "procedure: "; NL; proc#toPretty; NL; + [STR "procedure: "; NL; proc#toPretty; NL; STR "wto_infos: "; NL; pp_list wto_infos; NL; STR "local var table: "; NL; - pp_var_table bytecode#get_local_variable_table; NL; + pp_var_table bytecode#get_local_variable_table; NL; STR "constructed var table: "; NL; - self#pp_var_table_ !var_table; NL; - STR "var infos: "; NL; !jvar_infos#toPretty; NL; + self#pp_var_table_ !var_table; NL; + STR "var infos: "; NL; !jvar_infos#toPretty; NL; STR "bytecode: "; NL; bytecode#toPretty; NL; STR "states where vars are equal: "; (Option.get !var_to_var_to_eqs)#toPretty; NL])] end -let is_handler (state_name:symbol_t) = +let _is_handler (state_name: symbol_t) = let str = state_name#getBaseName in if String.length str < 8 then false @@ -735,7 +735,7 @@ let is_handler (state_name:symbol_t) = (* Adds operations to add variables in the analysis before they are first used * or remove them from the analysis when they are not used any more *) -let add_var_ops (jproc_info:jproc_info_t) = +let add_var_ops (jproc_info:jproc_info_t) = let jvar_infos = jproc_info#get_jvar_infos in let state_to_done_vars = make_state_to_done_num_vars jvar_infos in let state_to_start_vars = make_state_to_start_num_vars jvar_infos in @@ -743,70 +743,69 @@ let add_var_ops (jproc_info:jproc_info_t) = let proc_name = proc#getName in let cms = retrieve_cms proc_name#getSeqNumber in let cfg = jproc_info#get_cfg in - let add_operation state_name = + let add_operation state_name = if not (state_name#getIndex = exceptional_exit_sym#getIndex - || state_name#getIndex = method_exit_sym#getIndex) then - let done_vars = + || state_name#getIndex = method_exit_sym#getIndex) then + let done_vars = match state_to_done_vars#get state_name with | Some set -> set#toList | None -> [] in - let start_vars = + let start_vars = match state_to_start_vars#get state_name with - | Some set -> set#toList + | Some set -> set#toList | None -> [] in let state = cfg#getState state_name in JCHAnalysisSetUp.add_vars_op - ~proc ~cms ~state ~add_vars:start_vars ~remove_vars:done_vars + ~proc ~cms ~state ~add_vars:start_vars ~remove_vars:done_vars in - List.iter add_operation cfg#getStates + List.iter add_operation cfg#getStates (* Adds the transformed variable to each slot - * A variant of the variable was added in SSA but it has to be changed + * A variant of the variable was added in SSA but it has to be changed * with the representative which was computed later *) let set_tr_variable - (proc_name:symbol_t) - (proc:procedure_int) - (aliases:JCHTransformUtils.alias_sets_t) = + (proc_name: symbol_t) + (_proc: procedure_int) + (aliases: JCHTransformUtils.alias_sets_t) = let cms = retrieve_cms proc_name#getSeqNumber in let mInfo = app#get_method cms in let pc_stack_layouts = mInfo#get_method_stack_layout#get_pc_stack_layouts in let pc_to_instruction = new IntCollections.table_t in let _ = List.iter (fun (pc,s) -> pc_to_instruction#set pc s) pc_stack_layouts in - let get_rep (v:variable_t) = - match aliases#get_representative v with + let get_rep (v:variable_t) = + match aliases#get_representative v with | Some v' -> v' | _ -> v in - let set_tr_var_instr (pc:int) (stack_layout:op_stack_layout_int) = - let set_tr_var_slot (slot:logical_stack_slot_int) = + let set_tr_var_instr (pc:int) (stack_layout:op_stack_layout_int) = + let set_tr_var_slot (slot:logical_stack_slot_int) = try - slot#set_transformed_variable (get_rep slot#get_transformed_variable) + slot#set_transformed_variable (get_rep slot#get_transformed_variable) with | _ -> - pr__debug [proc_name#toPretty; STR " has unreachable pc "; INT pc; NL] in + pr__debug [proc_name#toPretty; STR " has unreachable pc "; INT pc; NL] in List.iter set_tr_var_slot stack_layout#get_slots in pc_to_instruction#iter set_tr_var_instr let make_jproc_info - ~(chif:system_int) ~(proc_name:symbol_t) ~(proc:procedure_int) ~(wto:CHSCC.wto_t) ~(wto_infos:JCHLoopUtils.wto_info_t list) ~(loop_depth:int) ~(dom_info:JCHDominance.dominance_info_t) - ~(aliases:JCHTransformUtils.alias_sets_t) + ~(aliases:JCHTransformUtils.alias_sets_t) ~(rvar_to_pc_to_versions: VariableCollections.set_t IntCollections.table_t VariableCollections.table_t) ~(orig_phi_to_vars:VariableCollections.set_t VariableCollections.table_t) ~(extra_assert_vars:SymbolCollections.set_t VariableCollections.table_t) - ~(jproc_info_opt:jproc_info_t option) = - match jproc_info_opt with - | Some jproc_info -> + ~(jproc_info_opt:jproc_info_t option) = + match jproc_info_opt with + | Some jproc_info -> let pc_to_instr = jproc_info#get_pc_to_instr in let instr_to_pc = jproc_info#get_instr_to_pc in - let new_proc_info = + let new_proc_info = new jproc_info_t ~proc_name ~proc @@ -817,19 +816,19 @@ let make_jproc_info ~instr_to_pc in let local_var_index_to_pc_to_var = new_proc_info#set_var_infos - ~chif ~dom_info ~aliases ~extra_assert_vars in + ~dom_info ~aliases ~extra_assert_vars in begin new_proc_info#make_var_table ~aliases ~rvar_to_pc_to_versions ~orig_phi_to_vars - ~local_var_index_to_pc_to_var ; - add_var_ops new_proc_info ; - JCHCodeTransformers.remove_skips_code_p proc; + ~local_var_index_to_pc_to_var; + add_var_ops new_proc_info; + JCHCodeTransformers.remove_skips_code_p proc; new_proc_info end | _ -> - let (bytecode, (offset_to_instrn_array, instrn_to_offset_array)) = + let (_bytecode, (offset_to_instrn_array, instrn_to_offset_array)) = let cms = retrieve_cms proc_name#getSeqNumber in let mInfo = app#get_method cms in if mInfo#has_bytecode then @@ -837,16 +836,16 @@ let make_jproc_info (bc, bc#get_code#offset_to_from_instrn_arrays) else raise (JCH_failure - (LBLOCK [ STR "Expected bytecode in " ; cms#toPretty ])) in - let pc_to_instr n = - try offset_to_instrn_array.(n) + (LBLOCK [STR "Expected bytecode in "; cms#toPretty])) in + let pc_to_instr n = + try offset_to_instrn_array.(n) with - | _ -> + | _ -> let length = Array.length offset_to_instrn_array in offset_to_instrn_array.(pred length) in let instr_to_pc n = instrn_to_offset_array.(n) in - set_tr_variable proc_name proc aliases ; - let new_proc_info = + set_tr_variable proc_name proc aliases; + let new_proc_info = new jproc_info_t ~proc_name ~proc @@ -857,12 +856,12 @@ let make_jproc_info ~instr_to_pc in let local_var_index_to_pc_to_var = new_proc_info#set_var_infos - ~chif ~dom_info ~aliases ~extra_assert_vars in + ~dom_info ~aliases ~extra_assert_vars in begin new_proc_info#make_var_table ~aliases ~rvar_to_pc_to_versions ~orig_phi_to_vars - ~local_var_index_to_pc_to_var ; + ~local_var_index_to_pc_to_var; new_proc_info end diff --git a/CodeHawk/CHJ/jchsys/jCHProcInfo.mli b/CodeHawk/CHJ/jchsys/jCHProcInfo.mli index 5794e864..17a0b6de 100644 --- a/CodeHawk/CHJ/jchsys/jCHProcInfo.mli +++ b/CodeHawk/CHJ/jchsys/jCHProcInfo.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -59,20 +60,20 @@ class analysis_results_t : class jproc_info_t : proc_name:symbol_t -> proc:procedure_int - -> wto:CHSCC.wto_t + -> wto:CHSCC.wto_t -> wto_infos:JCHLoopUtils.wto_info_t list - -> loop_depth:int - -> pc_to_instr:(int -> int) + -> loop_depth:int + -> pc_to_instr:(int -> int) -> instr_to_pc:(int -> int) -> object method get_analysis_results : analysis_results_t method get_variable_from_length : variable_t -> variable_t option method get_bytecode : bytecode_int - method get_count_number_vars : int - method get_count_numeric_vars : int + method get_count_number_vars : int + method get_count_numeric_vars : int method get_cfg : cfg_int method get_instr_to_pc : int -> int - method get_jvar_info : variable_t -> JCHVarInfo.jvar_info_t + method get_jvar_info : variable_t -> JCHVarInfo.jvar_info_t method get_jvar_infos : JCHVarInfo.jvar_info_t VariableCollections.table_t method get_length : variable_t -> variable_t option method get_loop_depth : int @@ -90,33 +91,31 @@ class jproc_info_t : method get_var_to_var_to_ineqs : SymbolCollections.set_t VariableCollections.table_t VariableCollections.table_t method get_variables : variable_t list - method get_wto_infos : JCHLoopUtils.wto_info_t list + method get_wto_infos : JCHLoopUtils.wto_info_t list method get_wto_prev_pc_to_entry_pcs : (int * int) list method get_wto : CHSCC.wto_t method has_orig_var_table : bool - - method make_var_table : + + method make_var_table : aliases:JCHTransformUtils.alias_sets_t -> rvar_to_pc_to_versions:VariableCollections.set_t IntCollections.table_t VariableCollections.table_t -> orig_phi_to_vars:VariableCollections.set_t VariableCollections.table_t -> local_var_index_to_pc_to_var:variable_t IntCollections.table_t IntCollections.table_t -> unit - + method set_var_infos : - chif:system_int - -> dom_info:JCHDominance.dominance_info_t + dom_info:JCHDominance.dominance_info_t -> aliases:JCHTransformUtils.alias_sets_t -> extra_assert_vars:SymbolCollections.set_t VariableCollections.table_t -> variable_t IntCollections.table_t IntCollections.table_t - + method set_var_table : (int * int * string * value_type_t list * int) list -> unit method toPretty : pretty_t end -val make_jproc_info : - chif:system_int - -> proc_name:symbol_t +val make_jproc_info : + proc_name:symbol_t -> proc:procedure_int -> wto:CHSCC.wto_t -> wto_infos:JCHLoopUtils.wto_info_t list @@ -127,5 +126,4 @@ val make_jproc_info : -> orig_phi_to_vars:VariableCollections.set_t VariableCollections.table_t -> extra_assert_vars:SymbolCollections.set_t VariableCollections.table_t -> jproc_info_opt:jproc_info_t option - -> jproc_info_t - + -> jproc_info_t diff --git a/CodeHawk/CHJ/jchsys/jCHRevDominance.ml b/CodeHawk/CHJ/jchsys/jCHRevDominance.ml index 401f0fb2..5fa877a0 100644 --- a/CodeHawk/CHJ/jchsys/jCHRevDominance.ml +++ b/CodeHawk/CHJ/jchsys/jCHRevDominance.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHRevDominance.mli b/CodeHawk/CHJ/jchsys/jCHRevDominance.mli index 07027046..9c2e0531 100644 --- a/CodeHawk/CHJ/jchsys/jCHRevDominance.mli +++ b/CodeHawk/CHJ/jchsys/jCHRevDominance.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHSSA.ml b/CodeHawk/CHJ/jchsys/jCHSSA.ml old mode 100755 new mode 100644 index 900a4765..4ef95468 --- a/CodeHawk/CHJ/jchsys/jCHSSA.ml +++ b/CodeHawk/CHJ/jchsys/jCHSSA.ml @@ -1,723 +1,718 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -(* chlib *) -open CHLanguage -open CHNumerical -open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil - -(* jchlib *) -open JCHBasicTypes -open JCHBasicTypesAPI -open JCHDictionary - -(* jchpre *) -open JCHApplication - -(* jchsys *) -open JCHGlobals -open JCHPrintUtils - -module F = CHOnlineCodeSet.LanguageFactory - -let dbg = ref false - -(* Transforms the CHIF by adding phi operations wherever needed *) -class ssa_phi_t - ~(procedure: procedure_int) - ~(cfg: cfg_int) - ~(dominance: JCHDominance.dominance_info_t) - ~(nr_states: int) = - object (self: _) - - val proc_name = procedure#getName - val arg_inds = - List.filter (fun v_ind -> v_ind <> exception_var_index) - (List.map (fun (_,v) -> v#getIndex) procedure#getBindings) - val cms = retrieve_cms procedure#getName#getSeqNumber - val states = cfg#getStates - val writeVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) - val readVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) - val readWriteVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) - - val work_array = JCHSplitArray.make nr_states 0 - val hasAlready_array = JCHSplitArray.make nr_states 0 - val iter_count = ref 0 - val phiNeeded_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) - val current_state = ref state_name_sym - - method initialize_array () = - for i = 0 to nr_states - 1 do - phiNeeded_array#set i new VariableCollections.set_t - done - - method initialize = - let _ = self#initialize_array () in - let initialize_state state = - if dominance#is_reachable state then - let state_index = dominance#get_index state in - let code = (cfg#getState state)#getCode in - let (rvars, wvars, rwvars) = - JCHTransformUtils.get_vars_in_code proc_name code in - writeVars_array#set state_index wvars ; - readVars_array#set state_index rvars ; - readWriteVars_array#set state_index rwvars - else - () in - List.iter initialize_state states ; - - (* Used to determine if the phi variable is needed - * However this does eliminate all the unnecessary ohi variables *) - method isWriteBeforeRead (var:variable_t) (st_index:int) = - let state = cfg#getState (dominance#get_state st_index) in - let code = state#getCode in - let res = ref 0 in (* 1 is write first, 2 is read first *) - let rec findVar cd = - for i = 0 to cd#length - 1 do - match cd#getCmdAt i with - | CODE (_, code) -> findVar code - | RELATION code -> - findVar code - | TRANSACTION (_, code, post_code_opt) -> - begin - findVar code ; - match post_code_opt with - | None -> () - | Some post_code -> - findVar post_code - end - | cmd -> let (rvars, wvars, rwvars) = - JCHTransformUtils.get_vars_in_cmd proc_name cmd in - if (rvars#has var) || (rwvars#has var) then - let _ = res := 2 in - raise Exit - else if wvars#has var then - let _ = res := 1 in - raise Exit - done in - try - findVar code ; - false ; - with - | Exit -> - !res = 1 - - method get_states_that_write var = - let write_list = ref [] in - let read_list = ref [] in - let read_write_list = ref [] in - for i = 0 to nr_states - 1 do - if (writeVars_array#get i)#has var then - write_list := i :: !write_list - else () ; - if (readVars_array#get i)#has var then - read_list := i :: !read_list - else () ; - if (readWriteVars_array#get i)#has var then - read_write_list := i :: !read_write_list - else () - done ; - match (List.length !write_list, - List.length !read_write_list, - List.length !read_list) with - | (1, 0, _) (* The writes have to come before the reads unless it is a parameter *) - | (0, 1, _) -> - if List.mem var#getIndex arg_inds then - !write_list @ !read_write_list - else [] - | (1, 1, 0) -> - let w_st = List.hd !write_list in - let rw_st = List.hd !read_write_list in - if List.mem var#getIndex arg_inds then - !write_list @ !read_write_list - else if (w_st = rw_st) && (self#isWriteBeforeRead var w_st) then - [] - else - !write_list @ !read_write_list - | _ -> - !write_list @ !read_write_list - - method find_phi_var (var:variable_t) = - let _ = iter_count := !iter_count + 1 in - let write_list = self#get_states_that_write var in - let init_work i = work_array#set i !iter_count in - let workList = ref write_list in - List.iter init_work write_list ; - while !workList != [] do - let (state_index, rest_list) = (List.hd !workList, List.tl !workList) in - workList := rest_list ; - let set = dominance#get_dom_frontier state_index in - let addState y = - let y_index = dominance#get_index y in - if (hasAlready_array#get y_index) < !iter_count - then - begin - (phiNeeded_array#get y_index)#add var ; - hasAlready_array#set y_index !iter_count ; - if (work_array#get y_index) < !iter_count then - begin - work_array#set y_index !iter_count ; - workList := y_index :: !workList - end - else () - end - else () - in - set#iter addState - done - - method find_phi = - let variables = - let allVars = procedure#getScope#getVariables in - let is_phi_var (v:variable_t) = - not (v#isTmp - || JCHSystemUtils.is_exception v - || JCHSystemUtils.is_constant v) in - List.filter is_phi_var allVars in - self#initialize ; - List.iter self#find_phi_var variables - - method private mk_code cmds = JCHIFSystem.chif_system#make_code cms cmds - - method mkPhis_state (state_name:symbol_t) (state:state_int) = - let _ = current_state := state_name in - let enter_code_cmds = - let mkPhiArg var s_name = - (s_name#getBaseName, var, READ) in - let (phi_s, enter_s) = - if state_name#getIndex = normal_exit_sym#getIndex then - (final_phi_sym , enter_final_state_sym) - else - (phi_sym, enter_state_sym) in - let mkArgs var = - ("phi", var, WRITE) :: - (List.map (mkPhiArg var) state#getIncomingEdges) in - let mkPhi var = - OPERATION { op_name = phi_s; op_args = mkArgs var } in - let enter_cmds = - if state_name#getBaseName = exceptional_exit_sym#getBaseName - || state_name#getBaseName = method_exit_sym#getBaseName then - [] - else if dominance#is_reachable state_name then - let n = dominance#get_index state_name in - List.map mkPhi (phiNeeded_array#get n)#toList - else - [] in - [CODE (enter_s, self#mk_code enter_cmds)] - in - let exit_code_cmds = [CODE (exit_state_sym, self#mk_code [])] in - JCHTransformUtils.mk_state - state - (JCHSystemUtils.add_cmds - ~cms - ~init_cmds:enter_code_cmds - ~final_cmds:exit_code_cmds - ~code:state#getCode) - - method mkPhi_cfg = - let _ = self#find_phi in - let change_state state_name = - self#mkPhis_state state_name (cfg#getState state_name) in - let new_states = - List.rev_map change_state cfg#getStates in - let new_cfg = F.mkCFG cfg#getEntry cfg#getExit in - new_cfg#addStates new_states ; - new_cfg - - end - -(* Transforms the CHIF by introducing a new version of a variable - * at every new write on that variable. - * It also creates alias sets to be used by the alias_transformer - * It also transforms the variable in the tables that keep track of char vars *) -class ssa_transformer_t - ~(proc_name: symbol_t) - ~(phi_cfg: cfg_int) - ~(dominance: JCHDominance.dominance_info_t) = - object (self: _) - - inherit JCHCodeTransformers.variable_transformer_t as super - - val cms = retrieve_cms proc_name#getSeqNumber - val stacks = new JCHTransformUtils.vv_stacks_t - val alias_sets = new JCHTransformUtils.alias_sets_t - val ssa_vars = new JCHTransformUtils.ssa_variable_t - val current_pc = ref 0 - val rvar_to_pc_to_versions = new VariableCollections.table_t - val pc_to_instruction = - let method_info = app#get_method (retrieve_cms proc_name#getSeqNumber) in - let stack_layouts = - method_info#get_method_stack_layout#get_pc_stack_layouts in - let table = new IntCollections.table_t in - let _ = List.iter (fun (pc,s) -> table#set pc s) stack_layouts in - table - - method get_rvar_to_pc_to_versions = rvar_to_pc_to_versions - - method get_alias_sets = alias_sets - - method replace_in_phi (cfg: cfg_int) (state: symbol_t) (succ: symbol_t) = - let replace_in_phi_arg arg = - match arg with - | (_,_,WRITE) -> arg - | (str, var, mode) -> - if str = state#getBaseName - then - match stacks#get var with - | Some stack -> - begin - try - let v = stack#top in - (str, v, mode) - with - | _ -> arg - end - | None -> arg - else arg in - - let replace_in_phi_cmd cmd = - match cmd with - | OPERATION { op_name = name ; op_args = args } -> - let new_args = List.map replace_in_phi_arg args in - OPERATION { op_name = name ; op_args = new_args } - | _ -> cmd in - - (* first command in state is CODE enter_state with *) - match (cfg#getState succ)#getCode#getCmdAt 0 with - | CODE (_, enter_code) -> - for i = 0 to enter_code#length - 1 do - let new_cmd = replace_in_phi_cmd (enter_code#getCmdAt i) in - enter_code#setCmdAt i new_cmd - done - | _ -> () - - - method private mk_code cmds = JCHIFSystem.chif_system#make_code cms cmds - - val init_cmd = ref SKIP - val final_cmd = ref SKIP - val new_states = ref ([]: state_int list) - val write_params = ref ([]: variable_t list) - val transformed_normal_exit = ref false - - method set_var = - match pc_to_instruction#get !current_pc with - | Some stack_layout -> - let set_tr_var_slot (slot: logical_stack_slot_int) = - let orig_var = slot#get_variable in - let var = - try (Option.get (stacks#get orig_var))#top - with _ -> orig_var in - (* var is not the final variable; - * (aliases#get_representative var) will be set later *) - slot#set_transformed_variable var in - List.iter set_tr_var_slot stack_layout#get_slots - | _ -> () - - - method transformState (cfg:cfg_int) (state_name:symbol_t) = - let state = cfg#getState state_name in - let code = state#getCode in - let new_enter_cmd = - match code#getCmdAt 0 with (* This is the enter code *) - | CODE (s, enter_code) -> - let new_enter_code = - if state#getLabel = method_entry_sym then - JCHSystemUtils.add_cmds - ~cms - ~init_cmds:[!init_cmd] - ~final_cmds:[] - ~code:enter_code - else if state#getLabel#getIndex = normal_exit_sym#getIndex then - let _ = transformed_normal_exit := true in - JCHSystemUtils.add_cmds - ~cms - ~init_cmds:[] - ~final_cmds:[!final_cmd] - ~code:enter_code - else - enter_code in - CODE (s, new_enter_code) - | _ -> raise (JCH_failure (STR "CODE enter state expected")) in - code#setCmdAt 0 new_enter_cmd ; - new_states := state :: !new_states ; - (try - current_pc := JCHSystemUtils.sym_to_pc state_name ; - self#set_var ; - with _ -> ()) ; - let succs = state#getOutgoingEdges in - stacks#reset_num_assignments ; - self#transformCode code ; - let num_assignments = stacks#num_assignments in - List.iter (self#replace_in_phi cfg state_name) succs ; - begin - if dominance#is_reachable state_name then - let children = dominance#get_immediate_dominated_children state_name in - children#iter (self#transformState cfg) - else - () - end ; - stacks#pop num_assignments - - method makeAssign isPre (v, t) = - match v#getType with - | NUM_LOOP_COUNTER_TYPE - | NUM_TMP_VAR_TYPE - | NUM_VAR_TYPE -> - if isPre then - ASSIGN_NUM (t, NUM_VAR (self#transformVar v)) - else - ASSIGN_NUM (self#make_new_variable v, NUM_VAR t) - | SYM_TMP_VAR_TYPE - | SYM_VAR_TYPE -> - if isPre then - ASSIGN_SYM (t, SYM_VAR (self#transformVar v)) - else - ASSIGN_SYM (self#make_new_variable v, SYM_VAR t) - | STRUCT_TYPE _ -> - if isPre then - ASSIGN_STRUCT (t, self#transformVar v) - else - ASSIGN_STRUCT (self#make_new_variable v, t) - | _ -> raise (JCH_failure (STR "SSA: var types not covered")) - - method transformOtherOperation op = - let transformArg (s,v,m) = - match m with - | READ -> - (s, self#transformVar v, m) - | _ -> - (s, self#make_new_variable v, m) in - let new_args = List.map transformArg op.op_args in - OPERATION { op_name = op.op_name; op_args = new_args } - - method transformOperation op = - let addReadAssigns assigns (s,v,m) = - match m with - | READ -> - (self#makeAssign false (v, v)) :: assigns - | _ -> - assigns in - - let addWriteAssigns assigns (s,v,m) = - if v#getIndex = exception_var_index - then - assigns - else - match m with - | WRITE -> - (self#makeAssign true (v, v)) :: assigns - | _ -> assigns in - - match op.op_name#getBaseName with - | "initialize" -> - let read_assigns = List.fold_left addReadAssigns [] op.op_args in - CODE (initial_assigns_sym, self#mk_code read_assigns) - | "finalize" -> - begin - try - let write_assigns = - List.fold_left addWriteAssigns [] op.op_args in - CODE (final_assigns_sym, self#mk_code write_assigns) - with - | _ -> - (* The return variable was never assigned as in the case when - * the method just throws an exception *) - ASSERT FALSE - end - | "phi" -> - let changeArg (s,v,m) = (s, self#make_new_variable v, m) in - let new_args = - (changeArg (List.hd op.op_args)) :: (List.tl op.op_args) in - OPERATION { op_name = op.op_name ; op_args = new_args } - | "final_phi" -> - let (_,v0,_) = List.hd op.op_args in - if (List.mem v0 !write_params) - then - let changeArg (s,v,m) = (s, self#make_new_variable v, m) in - let new_args = - (changeArg (List.hd op.op_args)) :: (List.tl op.op_args) in - OPERATION { op_name = phi_sym ; op_args = new_args } - else SKIP - | "enter_final_state" -> OPERATION op - | "dead_vars" -> SKIP - | "v" -> - current_pc := op.op_name#getSeqNumber; - self#set_var ; - self#transformOtherOperation op - | _ -> self#transformOtherOperation op - - method set_write_vars cmd = - let addWriteVar vars (s,v,m) = - match m with - | WRITE -> v::vars - | _ -> vars in - match cmd with - | OPERATION op -> - let write_vars = List.fold_left addWriteVar [] op.op_args in - write_params := write_vars - | _ -> () - - method transformVar var = - let index = var#getIndex in - if index = exception_var_index - || index = num_return_var_index - || index = sym_return_var_index - || var#getName#getBaseName.[0] = 'c' then - var - else - try - let new_var = stacks#get_top var in - let table = - match rvar_to_pc_to_versions#get var with - | Some table -> table - | _ -> - let table = new IntCollections.table_t in - rvar_to_pc_to_versions#set var table ; - table in - (match table#get !current_pc with - | Some set -> - set#add new_var - | _ -> table#set - !current_pc (VariableCollections.set_of_list [new_var])) ; - new_var - with _ -> - pr_debug [proc_name_pp proc_name; STR " "; proc_name#toPretty; - STR " variable read before write "; - var#toPretty; STR " at pc = "; INT !current_pc; NL] ; - raise (JCH_failure (STR "failure in transformVar")) - - method make_new_variable var = - let index = var#getIndex in - if index = exception_var_index - || index = num_return_var_index - || index = sym_return_var_index then - var - else - ssa_vars#make_new_variable var - - method add_to_alias_sets v w = - let index = v#getIndex in - if index = num_return_var_index || index = sym_return_var_index then - () - else - alias_sets#add v w - - val in_branch = ref 10 - val in_branch_var = ref (make_variable "branch_dummy" NUM_VAR_TYPE) - - method transformCmd cmd = - match cmd with - | CFG (name, cfg) -> - let _ = self#transformState phi_cfg method_entry_sym in - let _ = - try - let _ = phi_cfg#getState exceptional_exit_sym in - (* taken out by the dominance functions *) - self#transformState phi_cfg exceptional_exit_sym - with _ -> () in - let _ = - if !transformed_normal_exit then - () - else (* The method never terminates *) - let _ = self#transformState phi_cfg normal_exit_sym in - let _ = self#transformState phi_cfg method_exit_sym in - () in - let newCFG = F.mkCFG_s method_entry_sym method_exit_sym in - let addState state = - let is_reachable s = - List.exists (fun st -> - st#getLabel#getBaseName = s#getBaseName) !new_states in - let new_edges = List.filter is_reachable state#getIncomingEdges in - let new_state = F.mkState state#getLabel state#getCode in - let _ = - List.iter new_state#addIncomingEdge new_edges in - let _ = - List.iter new_state#addOutgoingEdge state#getOutgoingEdges in - newCFG#addState new_state in - List.iter addState !new_states ; - CFG (name, newCFG) - | CODE (str, code) -> - if str#getBaseName = "enter_final_state" && code#length > 0 - then ( - self#set_write_vars (code#getCmdAt (code#length - 1)) ; - self#transformCode code ; - CODE (enter_state_sym, code)) - else - super#transformCmd cmd - | TRANSACTION (str, code, copde_opt) -> - if str#getBaseName = "OpNewArray" then - match code#getCmdAt 0 with - | ASSIGN_NUM (length, _) -> - let elements_field = new symbol_t "elements" in - let elements_path = - List.rev (elements_field :: (List.tl (List.rev length#getPath))) in - let array_elements = - new variable_t - length#getName - ~suffix: length#getSuffix - ~path: elements_path - NUM_ARRAY_TYPE in - let _ = self#make_new_variable array_elements in - super#transformCmd cmd - | _ -> - super#transformCmd cmd - else if code#length = 0 then - super#transformCmd cmd - else - begin - match code#getCmdAt 0 with - (* this is taken as one source of information so one variable *) - | BRANCH [c1; c0; c_1] -> - in_branch := 1 ; - super#transformCode c1 ; - in_branch := 0 ; - super#transformCode c0 ; - super#transformCode c_1 ; - in_branch := 10 ; - TRANSACTION (str, F.mkCode [BRANCH [c1; c0; c_1]], None) - | _ -> - super#transformCmd cmd - end - | ABSTRACT_VARS l -> - ABSTRACT_VARS (List.map self#make_new_variable l) - | ASSIGN_NUM (v, NUM_VAR v') -> - let new_v' = self#transformVar v' in - let new_v = self#make_new_variable v in - self#add_to_alias_sets new_v new_v'; - ASSIGN_NUM (new_v, NUM_VAR new_v') - | ASSIGN_NUM (v, NUM c) -> - let new_v = - if !in_branch = 1 then - let v0 = self#make_new_variable v in - in_branch_var := v0 ; - v0 - else if !in_branch = 0 then - !in_branch_var - else ( - let v0 = self#make_new_variable v in - alias_sets#add_const v0 c ; - v0) in - ASSIGN_NUM (new_v, NUM c) - | ASSIGN_NUM (v,e) -> - ASSIGN_NUM (self#make_new_variable v, self#transformNumExp e) - | INCREMENT (v, num) -> - let new_temp = ssa_vars#make_new_temp v in - alias_sets#add_const new_temp num ; - let newCode = - [ASSIGN_NUM (new_temp, NUM num) ; - ASSIGN_NUM (self#make_new_variable v, - PLUS (self#transformVar v, new_temp))] in - TRANSACTION (new symbol_t "increment", self#mk_code newCode, None) - | ASSIGN_SYM (v,SYM_VAR v') -> - let new_v' = self#transformVar v' in - let new_v = self#make_new_variable v in - self#add_to_alias_sets new_v new_v'; - ASSIGN_SYM (new_v, SYM_VAR new_v') - | ASSIGN_SYM (v,e) -> - let new_e = self#transformSymExp e in - let new_v = self#make_new_variable v in - ASSIGN_SYM (new_v, new_e) - | ASSIGN_ARRAY (v, v') -> - let new_v' = self#transformVar v' in - let new_v = self#make_new_variable v in - self#add_to_alias_sets new_v new_v' ; - ASSIGN_ARRAY (new_v, new_v') - | ASSIGN_STRUCT (v,v') -> - let new_v' = self#transformVar v' in - let new_v = self#make_new_variable v in - self#add_to_alias_sets new_v new_v'; - ASSIGN_STRUCT (new_v, new_v') - | READ_NUM_ELT (x, a, i) -> - let new_a = self#transformVar a in - let new_i = self#transformVar i in - let new_x = self#make_new_variable x in - READ_NUM_ELT (new_x, new_a, new_i) - | READ_SYM_ELT (x, a, i) -> - let new_a = self#transformVar a in - let new_i = self#transformVar i in - let new_x = self#make_new_variable x in - READ_SYM_ELT (new_x, new_a, new_i) - | OPERATION op -> self#transformOperation op - | _ -> super#transformCmd cmd - - method transformProcedure (procedure: procedure_int) = - let bindings = procedure#getBindings in - let signature = procedure#getSignature in - let scope = procedure#getScope in - let _ = ssa_vars#set_stacks stacks in - let _ = ssa_vars#set_scope scope in - let mkOpArg (sym,v) = - try - let (_,_,m) = - List.find (fun (s,_,_) -> - sym#getBaseName = s#getBaseName) signature in - (sym#getBaseName, v, m) - with - | Not_found -> - raise - (JCH_failure - (LBLOCK [ STR "op arg " ; sym#toPretty ; STR " not found in " ; - STR "JCHSSA.transformProcedure" ])) in - let op_args = List.map mkOpArg bindings in - let _ = - init_cmd := OPERATION {op_name = initialize_sym; op_args = op_args } in - let _ = - final_cmd := OPERATION {op_name = finalize_sym; op_args = op_args } in - let body = procedure#getBody#clone () in - let _ = self#transformCode body in - F.mkProcedure - procedure#getName - ~signature: signature - ~bindings: bindings - ~scope: scope - ~body: body - -end - -let make_ssa procedure cfg dominance_info = - let proc_name = procedure#getName in - let phi_cfg = - (new ssa_phi_t - ~procedure - ~cfg - ~dominance:dominance_info - ~nr_states:dominance_info#get_nr_states)#mkPhi_cfg in - let ssa_transformer = - new ssa_transformer_t - ~proc_name - ~phi_cfg - ~dominance:dominance_info in - let new_proc = ssa_transformer#transformProcedure procedure in - let alias_sets = ssa_transformer#get_alias_sets in - let rvar_to_pc_to_versions = ssa_transformer#get_rvar_to_pc_to_versions in - (new_proc, alias_sets, rvar_to_pc_to_versions) - +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +(* chlib *) +open CHLanguage +open CHPretty +open CHUtils + +(* jchlib *) +open JCHBasicTypes +open JCHBasicTypesAPI +open JCHDictionary + +(* jchpre *) +open JCHApplication + +(* jchsys *) +open JCHGlobals +open JCHPrintUtils + +module F = CHOnlineCodeSet.LanguageFactory + + +(* Transforms the CHIF by adding phi operations wherever needed *) +class ssa_phi_t + ~(procedure: procedure_int) + ~(cfg: cfg_int) + ~(dominance: JCHDominance.dominance_info_t) + ~(nr_states: int) = + object (self: _) + + val proc_name = procedure#getName + val arg_inds = + List.filter (fun v_ind -> v_ind <> exception_var_index) + (List.map (fun (_,v) -> v#getIndex) procedure#getBindings) + val cms = retrieve_cms procedure#getName#getSeqNumber + val states = cfg#getStates + val writeVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) + val readVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) + val readWriteVars_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) + + val work_array = JCHSplitArray.make nr_states 0 + val hasAlready_array = JCHSplitArray.make nr_states 0 + val iter_count = ref 0 + val phiNeeded_array = JCHSplitArray.make nr_states (new VariableCollections.set_t) + val current_state = ref state_name_sym + + method initialize_array () = + for i = 0 to nr_states - 1 do + phiNeeded_array#set i new VariableCollections.set_t + done + + method initialize = + let _ = self#initialize_array () in + let initialize_state state = + if dominance#is_reachable state then + let state_index = dominance#get_index state in + let code = (cfg#getState state)#getCode in + let (rvars, wvars, rwvars) = + JCHTransformUtils.get_vars_in_code proc_name code in + writeVars_array#set state_index wvars; + readVars_array#set state_index rvars; + readWriteVars_array#set state_index rwvars + else + () in + List.iter initialize_state states; + + (* Used to determine if the phi variable is needed + * However this does eliminate all the unnecessary ohi variables *) + method isWriteBeforeRead (var:variable_t) (st_index:int) = + let state = cfg#getState (dominance#get_state st_index) in + let code = state#getCode in + let res = ref 0 in (* 1 is write first, 2 is read first *) + let rec findVar cd = + for i = 0 to cd#length - 1 do + match cd#getCmdAt i with + | CODE (_, code) -> findVar code + | RELATION code -> + findVar code + | TRANSACTION (_, code, post_code_opt) -> + begin + findVar code; + match post_code_opt with + | None -> () + | Some post_code -> + findVar post_code + end + | cmd -> let (rvars, wvars, rwvars) = + JCHTransformUtils.get_vars_in_cmd proc_name cmd in + if (rvars#has var) || (rwvars#has var) then + let _ = res := 2 in + raise Exit + else if wvars#has var then + let _ = res := 1 in + raise Exit + done in + try + findVar code; + false; + with + | Exit -> + !res = 1 + + method get_states_that_write var = + let write_list = ref [] in + let read_list = ref [] in + let read_write_list = ref [] in + for i = 0 to nr_states - 1 do + if (writeVars_array#get i)#has var then + write_list := i :: !write_list + else (); + if (readVars_array#get i)#has var then + read_list := i :: !read_list + else (); + if (readWriteVars_array#get i)#has var then + read_write_list := i :: !read_write_list + else () + done; + match (List.length !write_list, + List.length !read_write_list, + List.length !read_list) with + | (1, 0, _) (* The writes have to come before the reads unless it is a parameter *) + | (0, 1, _) -> + if List.mem var#getIndex arg_inds then + !write_list @ !read_write_list + else [] + | (1, 1, 0) -> + let w_st = List.hd !write_list in + let rw_st = List.hd !read_write_list in + if List.mem var#getIndex arg_inds then + !write_list @ !read_write_list + else if (w_st = rw_st) && (self#isWriteBeforeRead var w_st) then + [] + else + !write_list @ !read_write_list + | _ -> + !write_list @ !read_write_list + + method find_phi_var (var:variable_t) = + let _ = iter_count := !iter_count + 1 in + let write_list = self#get_states_that_write var in + let init_work i = work_array#set i !iter_count in + let workList = ref write_list in + List.iter init_work write_list; + while !workList != [] do + let (state_index, rest_list) = (List.hd !workList, List.tl !workList) in + workList := rest_list; + let set = dominance#get_dom_frontier state_index in + let addState y = + let y_index = dominance#get_index y in + if (hasAlready_array#get y_index) < !iter_count + then + begin + (phiNeeded_array#get y_index)#add var; + hasAlready_array#set y_index !iter_count; + if (work_array#get y_index) < !iter_count then + begin + work_array#set y_index !iter_count; + workList := y_index :: !workList + end + else () + end + else () + in + set#iter addState + done + + method find_phi = + let variables = + let allVars = procedure#getScope#getVariables in + let is_phi_var (v:variable_t) = + not (v#isTmp + || JCHSystemUtils.is_exception v + || JCHSystemUtils.is_constant v) in + List.filter is_phi_var allVars in + self#initialize; + List.iter self#find_phi_var variables + + method private mk_code cmds = JCHIFSystem.chif_system#make_code cms cmds + + method mkPhis_state (state_name:symbol_t) (state:state_int) = + let _ = current_state := state_name in + let enter_code_cmds = + let mkPhiArg var s_name = + (s_name#getBaseName, var, READ) in + let (phi_s, enter_s) = + if state_name#getIndex = normal_exit_sym#getIndex then + (final_phi_sym , enter_final_state_sym) + else + (phi_sym, enter_state_sym) in + let mkArgs var = + ("phi", var, WRITE) :: + (List.map (mkPhiArg var) state#getIncomingEdges) in + let mkPhi var = + OPERATION { op_name = phi_s; op_args = mkArgs var } in + let enter_cmds = + if state_name#getBaseName = exceptional_exit_sym#getBaseName + || state_name#getBaseName = method_exit_sym#getBaseName then + [] + else if dominance#is_reachable state_name then + let n = dominance#get_index state_name in + List.map mkPhi (phiNeeded_array#get n)#toList + else + [] in + [CODE (enter_s, self#mk_code enter_cmds)] + in + let exit_code_cmds = [CODE (exit_state_sym, self#mk_code [])] in + JCHTransformUtils.mk_state + state + (JCHSystemUtils.add_cmds + ~cms + ~init_cmds:enter_code_cmds + ~final_cmds:exit_code_cmds + ~code:state#getCode) + + method mkPhi_cfg = + let _ = self#find_phi in + let change_state state_name = + self#mkPhis_state state_name (cfg#getState state_name) in + let new_states = + List.rev_map change_state cfg#getStates in + let new_cfg = F.mkCFG cfg#getEntry cfg#getExit in + new_cfg#addStates new_states; + new_cfg + + end + +(* Transforms the CHIF by introducing a new version of a variable + * at every new write on that variable. + * It also creates alias sets to be used by the alias_transformer + * It also transforms the variable in the tables that keep track of char vars *) +class ssa_transformer_t + ~(proc_name: symbol_t) + ~(phi_cfg: cfg_int) + ~(dominance: JCHDominance.dominance_info_t) = + object (self: _) + + inherit JCHCodeTransformers.variable_transformer_t as super + + val cms = retrieve_cms proc_name#getSeqNumber + val stacks = new JCHTransformUtils.vv_stacks_t + val alias_sets = new JCHTransformUtils.alias_sets_t + val ssa_vars = new JCHTransformUtils.ssa_variable_t + val current_pc = ref 0 + val rvar_to_pc_to_versions = new VariableCollections.table_t + val pc_to_instruction = + let method_info = app#get_method (retrieve_cms proc_name#getSeqNumber) in + let stack_layouts = + method_info#get_method_stack_layout#get_pc_stack_layouts in + let table = new IntCollections.table_t in + let _ = List.iter (fun (pc,s) -> table#set pc s) stack_layouts in + table + + method get_rvar_to_pc_to_versions = rvar_to_pc_to_versions + + method get_alias_sets = alias_sets + + method replace_in_phi (cfg: cfg_int) (state: symbol_t) (succ: symbol_t) = + let replace_in_phi_arg arg = + match arg with + | (_,_,WRITE) -> arg + | (str, var, mode) -> + if str = state#getBaseName + then + match stacks#get var with + | Some stack -> + begin + try + let v = stack#top in + (str, v, mode) + with + | _ -> arg + end + | None -> arg + else arg in + + let replace_in_phi_cmd cmd = + match cmd with + | OPERATION { op_name = name; op_args = args } -> + let new_args = List.map replace_in_phi_arg args in + OPERATION { op_name = name; op_args = new_args } + | _ -> cmd in + + (* first command in state is CODE enter_state with *) + match (cfg#getState succ)#getCode#getCmdAt 0 with + | CODE (_, enter_code) -> + for i = 0 to enter_code#length - 1 do + let new_cmd = replace_in_phi_cmd (enter_code#getCmdAt i) in + enter_code#setCmdAt i new_cmd + done + | _ -> () + + + method private mk_code cmds = JCHIFSystem.chif_system#make_code cms cmds + + val init_cmd = ref SKIP + val final_cmd = ref SKIP + val new_states = ref ([]: state_int list) + val write_params = ref ([]: variable_t list) + val transformed_normal_exit = ref false + + method set_var = + match pc_to_instruction#get !current_pc with + | Some stack_layout -> + let set_tr_var_slot (slot: logical_stack_slot_int) = + let orig_var = slot#get_variable in + let var = + try (Option.get (stacks#get orig_var))#top + with _ -> orig_var in + (* var is not the final variable; + * (aliases#get_representative var) will be set later *) + slot#set_transformed_variable var in + List.iter set_tr_var_slot stack_layout#get_slots + | _ -> () + + + method transformState (cfg:cfg_int) (state_name:symbol_t) = + let state = cfg#getState state_name in + let code = state#getCode in + let new_enter_cmd = + match code#getCmdAt 0 with (* This is the enter code *) + | CODE (s, enter_code) -> + let new_enter_code = + if state#getLabel = method_entry_sym then + JCHSystemUtils.add_cmds + ~cms + ~init_cmds:[!init_cmd] + ~final_cmds:[] + ~code:enter_code + else if state#getLabel#getIndex = normal_exit_sym#getIndex then + let _ = transformed_normal_exit := true in + JCHSystemUtils.add_cmds + ~cms + ~init_cmds:[] + ~final_cmds:[!final_cmd] + ~code:enter_code + else + enter_code in + CODE (s, new_enter_code) + | _ -> raise (JCH_failure (STR "CODE enter state expected")) in + code#setCmdAt 0 new_enter_cmd; + new_states := state :: !new_states; + (try + current_pc := JCHSystemUtils.sym_to_pc state_name; + self#set_var; + with _ -> ()); + let succs = state#getOutgoingEdges in + stacks#reset_num_assignments; + self#transformCode code; + let num_assignments = stacks#num_assignments in + List.iter (self#replace_in_phi cfg state_name) succs; + begin + if dominance#is_reachable state_name then + let children = dominance#get_immediate_dominated_children state_name in + children#iter (self#transformState cfg) + else + () + end; + stacks#pop num_assignments + + method makeAssign isPre (v, t) = + match v#getType with + | NUM_LOOP_COUNTER_TYPE + | NUM_TMP_VAR_TYPE + | NUM_VAR_TYPE -> + if isPre then + ASSIGN_NUM (t, NUM_VAR (self#transformVar v)) + else + ASSIGN_NUM (self#make_new_variable v, NUM_VAR t) + | SYM_TMP_VAR_TYPE + | SYM_VAR_TYPE -> + if isPre then + ASSIGN_SYM (t, SYM_VAR (self#transformVar v)) + else + ASSIGN_SYM (self#make_new_variable v, SYM_VAR t) + | STRUCT_TYPE _ -> + if isPre then + ASSIGN_STRUCT (t, self#transformVar v) + else + ASSIGN_STRUCT (self#make_new_variable v, t) + | _ -> raise (JCH_failure (STR "SSA: var types not covered")) + + method transformOtherOperation op = + let transformArg (s,v,m) = + match m with + | READ -> + (s, self#transformVar v, m) + | _ -> + (s, self#make_new_variable v, m) in + let new_args = List.map transformArg op.op_args in + OPERATION { op_name = op.op_name; op_args = new_args } + + method transformOperation op = + let addReadAssigns assigns (_s, v, m) = + match m with + | READ -> + (self#makeAssign false (v, v)) :: assigns + | _ -> + assigns in + + let addWriteAssigns assigns (_s, v, m) = + if v#getIndex = exception_var_index + then + assigns + else + match m with + | WRITE -> + (self#makeAssign true (v, v)) :: assigns + | _ -> assigns in + + match op.op_name#getBaseName with + | "initialize" -> + let read_assigns = List.fold_left addReadAssigns [] op.op_args in + CODE (initial_assigns_sym, self#mk_code read_assigns) + | "finalize" -> + begin + try + let write_assigns = + List.fold_left addWriteAssigns [] op.op_args in + CODE (final_assigns_sym, self#mk_code write_assigns) + with + | _ -> + (* The return variable was never assigned as in the case when + * the method just throws an exception *) + ASSERT FALSE + end + | "phi" -> + let changeArg (s,v,m) = (s, self#make_new_variable v, m) in + let new_args = + (changeArg (List.hd op.op_args)) :: (List.tl op.op_args) in + OPERATION { op_name = op.op_name; op_args = new_args } + | "final_phi" -> + let (_,v0,_) = List.hd op.op_args in + if (List.mem v0 !write_params) + then + let changeArg (s,v,m) = (s, self#make_new_variable v, m) in + let new_args = + (changeArg (List.hd op.op_args)) :: (List.tl op.op_args) in + OPERATION { op_name = phi_sym; op_args = new_args } + else SKIP + | "enter_final_state" -> OPERATION op + | "dead_vars" -> SKIP + | "v" -> + current_pc := op.op_name#getSeqNumber; + self#set_var; + self#transformOtherOperation op + | _ -> self#transformOtherOperation op + + method set_write_vars cmd = + let addWriteVar vars (_s, v, m) = + match m with + | WRITE -> v::vars + | _ -> vars in + match cmd with + | OPERATION op -> + let write_vars = List.fold_left addWriteVar [] op.op_args in + write_params := write_vars + | _ -> () + + method !transformVar var = + let index = var#getIndex in + if index = exception_var_index + || index = num_return_var_index + || index = sym_return_var_index + || var#getName#getBaseName.[0] = 'c' then + var + else + try + let new_var = stacks#get_top var in + let table = + match rvar_to_pc_to_versions#get var with + | Some table -> table + | _ -> + let table = new IntCollections.table_t in + rvar_to_pc_to_versions#set var table; + table in + (match table#get !current_pc with + | Some set -> + set#add new_var + | _ -> table#set + !current_pc (VariableCollections.set_of_list [new_var])); + new_var + with _ -> + pr_debug [proc_name_pp proc_name; STR " "; proc_name#toPretty; + STR " variable read before write "; + var#toPretty; STR " at pc = "; INT !current_pc; NL]; + raise (JCH_failure (STR "failure in transformVar")) + + method make_new_variable var = + let index = var#getIndex in + if index = exception_var_index + || index = num_return_var_index + || index = sym_return_var_index then + var + else + ssa_vars#make_new_variable var + + method add_to_alias_sets v w = + let index = v#getIndex in + if index = num_return_var_index || index = sym_return_var_index then + () + else + alias_sets#add v w + + val in_branch = ref 10 + val in_branch_var = ref (make_variable "branch_dummy" NUM_VAR_TYPE) + + method !transformCmd cmd = + match cmd with + | CFG (name, _cfg) -> + let _ = self#transformState phi_cfg method_entry_sym in + let _ = + try + let _ = phi_cfg#getState exceptional_exit_sym in + (* taken out by the dominance functions *) + self#transformState phi_cfg exceptional_exit_sym + with _ -> () in + let _ = + if !transformed_normal_exit then + () + else (* The method never terminates *) + let _ = self#transformState phi_cfg normal_exit_sym in + let _ = self#transformState phi_cfg method_exit_sym in + () in + let newCFG = F.mkCFG_s method_entry_sym method_exit_sym in + let addState state = + let is_reachable s = + List.exists (fun st -> + st#getLabel#getBaseName = s#getBaseName) !new_states in + let new_edges = List.filter is_reachable state#getIncomingEdges in + let new_state = F.mkState state#getLabel state#getCode in + let _ = + List.iter new_state#addIncomingEdge new_edges in + let _ = + List.iter new_state#addOutgoingEdge state#getOutgoingEdges in + newCFG#addState new_state in + List.iter addState !new_states; + CFG (name, newCFG) + | CODE (str, code) -> + if str#getBaseName = "enter_final_state" && code#length > 0 + then ( + self#set_write_vars (code#getCmdAt (code#length - 1)); + self#transformCode code; + CODE (enter_state_sym, code)) + else + super#transformCmd cmd + | TRANSACTION (str, code, _copde_opt) -> + if str#getBaseName = "OpNewArray" then + match code#getCmdAt 0 with + | ASSIGN_NUM (length, _) -> + let elements_field = new symbol_t "elements" in + let elements_path = + List.rev (elements_field :: (List.tl (List.rev length#getPath))) in + let array_elements = + new variable_t + length#getName + ~suffix: length#getSuffix + ~path: elements_path + NUM_ARRAY_TYPE in + let _ = self#make_new_variable array_elements in + super#transformCmd cmd + | _ -> + super#transformCmd cmd + else if code#length = 0 then + super#transformCmd cmd + else + begin + match code#getCmdAt 0 with + (* this is taken as one source of information so one variable *) + | BRANCH [c1; c0; c_1] -> + in_branch := 1; + super#transformCode c1; + in_branch := 0; + super#transformCode c0; + super#transformCode c_1; + in_branch := 10; + TRANSACTION (str, F.mkCode [BRANCH [c1; c0; c_1]], None) + | _ -> + super#transformCmd cmd + end + | ABSTRACT_VARS l -> + ABSTRACT_VARS (List.map self#make_new_variable l) + | ASSIGN_NUM (v, NUM_VAR v') -> + let new_v' = self#transformVar v' in + let new_v = self#make_new_variable v in + self#add_to_alias_sets new_v new_v'; + ASSIGN_NUM (new_v, NUM_VAR new_v') + | ASSIGN_NUM (v, NUM c) -> + let new_v = + if !in_branch = 1 then + let v0 = self#make_new_variable v in + in_branch_var := v0; + v0 + else if !in_branch = 0 then + !in_branch_var + else ( + let v0 = self#make_new_variable v in + alias_sets#add_const v0 c; + v0) in + ASSIGN_NUM (new_v, NUM c) + | ASSIGN_NUM (v,e) -> + ASSIGN_NUM (self#make_new_variable v, self#transformNumExp e) + | INCREMENT (v, num) -> + let new_temp = ssa_vars#make_new_temp v in + alias_sets#add_const new_temp num; + let newCode = + [ASSIGN_NUM (new_temp, NUM num); + ASSIGN_NUM (self#make_new_variable v, + PLUS (self#transformVar v, new_temp))] in + TRANSACTION (new symbol_t "increment", self#mk_code newCode, None) + | ASSIGN_SYM (v,SYM_VAR v') -> + let new_v' = self#transformVar v' in + let new_v = self#make_new_variable v in + self#add_to_alias_sets new_v new_v'; + ASSIGN_SYM (new_v, SYM_VAR new_v') + | ASSIGN_SYM (v,e) -> + let new_e = self#transformSymExp e in + let new_v = self#make_new_variable v in + ASSIGN_SYM (new_v, new_e) + | ASSIGN_ARRAY (v, v') -> + let new_v' = self#transformVar v' in + let new_v = self#make_new_variable v in + self#add_to_alias_sets new_v new_v'; + ASSIGN_ARRAY (new_v, new_v') + | ASSIGN_STRUCT (v,v') -> + let new_v' = self#transformVar v' in + let new_v = self#make_new_variable v in + self#add_to_alias_sets new_v new_v'; + ASSIGN_STRUCT (new_v, new_v') + | READ_NUM_ELT (x, a, i) -> + let new_a = self#transformVar a in + let new_i = self#transformVar i in + let new_x = self#make_new_variable x in + READ_NUM_ELT (new_x, new_a, new_i) + | READ_SYM_ELT (x, a, i) -> + let new_a = self#transformVar a in + let new_i = self#transformVar i in + let new_x = self#make_new_variable x in + READ_SYM_ELT (new_x, new_a, new_i) + | OPERATION op -> self#transformOperation op + | _ -> super#transformCmd cmd + + method !transformProcedure (procedure: procedure_int) = + let bindings = procedure#getBindings in + let signature = procedure#getSignature in + let scope = procedure#getScope in + let _ = ssa_vars#set_stacks stacks in + let _ = ssa_vars#set_scope scope in + let mkOpArg (sym,v) = + try + let (_,_,m) = + List.find (fun (s,_,_) -> + sym#getBaseName = s#getBaseName) signature in + (sym#getBaseName, v, m) + with + | Not_found -> + raise + (JCH_failure + (LBLOCK [STR "op arg "; sym#toPretty; STR " not found in "; + STR "JCHSSA.transformProcedure"])) in + let op_args = List.map mkOpArg bindings in + let _ = + init_cmd := OPERATION {op_name = initialize_sym; op_args = op_args } in + let _ = + final_cmd := OPERATION {op_name = finalize_sym; op_args = op_args } in + let body = procedure#getBody#clone () in + let _ = self#transformCode body in + F.mkProcedure + procedure#getName + ~signature: signature + ~bindings: bindings + ~scope: scope + ~body: body + +end + +let make_ssa procedure cfg dominance_info = + let proc_name = procedure#getName in + let phi_cfg = + (new ssa_phi_t + ~procedure + ~cfg + ~dominance:dominance_info + ~nr_states:dominance_info#get_nr_states)#mkPhi_cfg in + let ssa_transformer = + new ssa_transformer_t + ~proc_name + ~phi_cfg + ~dominance:dominance_info in + let new_proc = ssa_transformer#transformProcedure procedure in + let alias_sets = ssa_transformer#get_alias_sets in + let rvar_to_pc_to_versions = ssa_transformer#get_rvar_to_pc_to_versions in + (new_proc, alias_sets, rvar_to_pc_to_versions) diff --git a/CodeHawk/CHJ/jchsys/jCHSSA.mli b/CodeHawk/CHJ/jchsys/jCHSSA.mli index efd8fee1..a1349e93 100644 --- a/CodeHawk/CHJ/jchsys/jCHSSA.mli +++ b/CodeHawk/CHJ/jchsys/jCHSSA.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -35,5 +36,4 @@ val make_ssa : -> JCHDominance.dominance_info_t -> procedure_int * JCHTransformUtils.alias_sets_t - * VariableCollections.set_t IntCollections.table_t VariableCollections.table_t - + * VariableCollections.set_t IntCollections.table_t VariableCollections.table_t diff --git a/CodeHawk/CHJ/jchsys/jCHSplitArray.ml b/CodeHawk/CHJ/jchsys/jCHSplitArray.ml index c9b859f9..fb8a573b 100644 --- a/CodeHawk/CHJ/jchsys/jCHSplitArray.ml +++ b/CodeHawk/CHJ/jchsys/jCHSplitArray.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHSplitArray.mli b/CodeHawk/CHJ/jchsys/jCHSplitArray.mli index 758ff710..b35d8bdc 100644 --- a/CodeHawk/CHJ/jchsys/jCHSplitArray.mli +++ b/CodeHawk/CHJ/jchsys/jCHSplitArray.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHSystem.ml b/CodeHawk/CHJ/jchsys/jCHSystem.ml index 535cc94a..7630d4a8 100644 --- a/CodeHawk/CHJ/jchsys/jCHSystem.ml +++ b/CodeHawk/CHJ/jchsys/jCHSystem.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -142,7 +142,6 @@ class jsystem_t = system proc_name ; let jproc_info = JCHProcInfo.make_jproc_info - ~chif:new_system ~proc_name ~proc:tr_proc ~wto:proc_wto @@ -159,7 +158,6 @@ class jsystem_t = tr_proc jproc_info#get_jvar_infos ; let jproc_info = JCHProcInfo.make_jproc_info - ~chif:new_system ~proc_name ~proc:tr_proc ~wto:proc_wto diff --git a/CodeHawk/CHJ/jchsys/jCHSystem.mli b/CodeHawk/CHJ/jchsys/jCHSystem.mli index 786cc474..d93d18d8 100644 --- a/CodeHawk/CHJ/jchsys/jCHSystem.mli +++ b/CodeHawk/CHJ/jchsys/jCHSystem.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -31,7 +31,7 @@ open CHLanguage open CHPretty open CHUtils -class jsystem_t : +class jsystem_t : object method add_stats : string -> pretty_t -> unit method get_call_graph_manager : JCHCallGraph.call_graph_manager_t @@ -42,13 +42,13 @@ class jsystem_t : method get_number_procs : int method get_original_chif : system_int method get_procedures : symbol_t list - method get_stats : string -> pretty_t option + method get_stats : string -> pretty_t option method get_transformed_chif : system_int method not_analyzed_bad : int -> bool method not_analyzed : int -> bool method set : system_int -> unit - method stats_to_pretty : pretty_t + method stats_to_pretty : pretty_t method toPretty : pretty_t end -val jsystem : jsystem_t +val jsystem : jsystem_t diff --git a/CodeHawk/CHJ/jchsys/jCHSystemUtils.ml b/CodeHawk/CHJ/jchsys/jCHSystemUtils.ml index b81b5587..370c1382 100755 --- a/CodeHawk/CHJ/jchsys/jCHSystemUtils.ml +++ b/CodeHawk/CHJ/jchsys/jCHSystemUtils.ml @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny B. Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHSystemUtils.mli b/CodeHawk/CHJ/jchsys/jCHSystemUtils.mli index b5daa138..919b2fb5 100644 --- a/CodeHawk/CHJ/jchsys/jCHSystemUtils.mli +++ b/CodeHawk/CHJ/jchsys/jCHSystemUtils.mli @@ -5,7 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2024 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHTransformUtils.ml b/CodeHawk/CHJ/jchsys/jCHTransformUtils.ml old mode 100755 new mode 100644 index 2505170c..92ec5e6b --- a/CodeHawk/CHJ/jchsys/jCHTransformUtils.ml +++ b/CodeHawk/CHJ/jchsys/jCHTransformUtils.ml @@ -1,589 +1,585 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -open Big_int_Z - -(* chlib *) -open CHLanguage -open CHNumerical -open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil - -(* jchlib *) -open JCHBasicTypes -open JCHBasicTypesAPI -open JCHDictionary - -(* jchpre *) -open JCHApplication -open JCHBytecodeLocation -open JCHPreAPI - -(* jchsys *) -open JCHPrintUtils -open JCHGlobals - -module F = CHOnlineCodeSet.LanguageFactory - -let dbg = ref false - -(* Makes a new state with all the fields of oldState but with new_cmds *) -let mk_state (oldState:state_int) (new_cmds:code_int):state_int = - let new_state = F.mkState oldState#getLabel new_cmds in - let preds = oldState#getIncomingEdges in - let succs = oldState#getOutgoingEdges in - List.iter new_state#addIncomingEdge preds ; - List.iter new_state#addOutgoingEdge succs ; - new_state - -class proc_checker_t proc_name proc = - object (self: _) - - inherit code_walker_t as super - - val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) - - method private check_invoke - (cn:class_name_int) - (ms:method_signature_int) - (iInfo:instruction_info_int) = - match cn#name with - | "java.lang.Integer" - | "java.lang.Short" - | "java.lang.Character" - | "java.lang.Byte" - | "java.lang.Long" - | "java.lang.Float" - | "java.lang.Double" - | "java.math.BigInteger" - | "java.math.BigDecimal" - - (* found the last one in com.ibm.icu.impl.data.LocaleElements_fa *) - | "com.ibm.icu.impl.ICUListResourceBundle$ResourceBinary" - - (* found in com.ibm.icu.impl.data.LocaleElements *) - | "com.ibm.icu.impl.ICUListResourceBundle$ResourceString" - - (* found in com.ibm.icu.impl.data.LocaleElements_sr *) - | "com.ibm.icu.impl.ICUListResourceBundle$Alias" - - (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) - | "com.google.javascript.jscomp.regex.CaseCanonicalize$DeltaSet" - - (* found in xmlbeans-2.6.0/build/lib/saxon.jar *) - | "net.sf.saxon.charcode.GB2312CharacterSet" - - | "java.util.HashMap" - - (* found in fop *) - | "org.apache.batik.gvt.text.GVTAttributedCharacterIterator$TextAttribute" -> - if ms#name <> "" then - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - - (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) - | "com.google.javascript.jscomp.regex.CharRanges" -> - let name = ms#name in - if name <> "withRanges" && name <> "inclusive" && name <> "withMembers"then - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - - (* found in com.google.common.net.TldPatterns. *) - | "com.google.common.collect.ImmutableList" - - (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) - | "com.google.common.collect.ImmutableSet" -> - if ms#name <> "of" then - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - - | "java.util.Collections" -> (* found in fop *) - if ms#name <> "synchronizedMap" then - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - - | _ -> - let cms = make_cms cn ms in - let mInfo = app#get_method cms in - if mInfo#get_analysis_exclusions = [] then - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | OPERATION op -> - - begin - match op.op_name#getBaseName with - | "i" - | "ii" -> - let bcloc = get_bytecode_location - proc_name#getSeqNumber op.op_name#getSeqNumber in - let iInfo = app#get_instruction bcloc in - begin - match mInfo#get_opcode op.op_name#getSeqNumber with - | OpInvokeStatic (cn, ms) - | OpInvokeSpecial (cn, ms) - | OpInvokeInterface (cn, ms) -> - self#check_invoke cn ms iInfo - - | OpInvokeVirtual _ - | OpGetStatic _ - | OpGetField _ -> - raise - (JCH_failure - (LBLOCK [ STR "JCHTransformUtils:proc_checker:walkCmd: complicated" ; - STR "not safe at: " ; iInfo#toPretty ])) - | _ -> () - end - | _ -> super#walkCmd cmd - end - | _ -> super#walkCmd cmd - - method does_not_need_to_be_analyzed = - let args = JCHSystemUtils.get_signature_read_vars proc in - let ret_opt = JCHSystemUtils.get_return_var proc in - match args with - | [] -> - begin - try - self#walkCode proc#getBody ; - Option.is_none ret_opt - with - | _ -> - if mInfo#get_instruction_count > 100 then - pr__debug [STR "possible large safe method: "; - proc_name#toPretty; STR " "; - proc_name_pp proc_name; NL] ; - false - end - | _ -> false - end - -(* Note: this function is not called anywhere *) -let does_not_need_to_be_analyzed proc_name proc = - let proc_checker = new proc_checker_t proc_name proc in - proc_checker#does_not_need_to_be_analyzed - - -(* A var collector of variables modified when running the program. - * Some variables are writes in ASSERTs and flow control ops - * but they are not modifed when running the program *) -class read_write_var_collector_t (proc_name:symbol_t) = - object (self: _) - - inherit var_collector_t - - val read_vars = new VariableCollections.set_t - val write_vars = new VariableCollections.set_t - val read_write_vars = new VariableCollections.set_t - - method getReadVars = read_vars - method getWriteVars = write_vars - method getReadWriteVars = read_write_vars - - - method walkCmd (cmd: (code_int, cfg_int) command_t) = - match cmd with - | CODE (_, code) -> - self#walkCode code - | CFG (_, cfg) -> - let states = cfg#getStates in - List.iter (fun s -> self#walkCode (cfg#getState s)#getCode) states - | RELATION code -> - self#walkCode code - | TRANSACTION (_, code, post_code) -> - begin - self#walkCode code; - match post_code with - | None -> () - | Some code -> self#walkCode code - end - | ABSTRACT_VARS l -> - write_vars#addList l - | ASSIGN_SYM (v, SYM _) - | ASSIGN_NUM (v, NUM _) -> - write_vars#add v - | ASSIGN_NUM (v, PLUS (y,z)) - | ASSIGN_NUM (v, MINUS (y,z)) - | ASSIGN_NUM (v, MULT (y,z)) - | ASSIGN_NUM (v, DIV (y,z)) -> - write_vars#add v ; - read_vars#addList [y; z] - | INCREMENT (v, _) -> - read_write_vars#add v ; - | ASSIGN_NUM (v, NUM_VAR w) - | ASSIGN_STRUCT (v, w) - | ASSIGN_ARRAY (v, w) - | ASSIGN_SYM (v, SYM_VAR w) -> - write_vars#add v ; - read_vars#add w ; - | READ_NUM_ELT (v, a, i) -> - (* Arrays are introduced only for arrays of numbers *) - write_vars#add v ; - read_vars#addList [a ; i] - | ASSIGN_NUM_ELT (a, i, v) -> - read_write_vars#add a ; - read_vars#addList [i; v] - | SHIFT_ARRAY (tgt, src, n) -> - (* Only for arrays of numbers *) - write_vars#add tgt ; - read_vars#add src - | BLIT_ARRAYS (tgt, tgt_o, src, src_o, n) -> - (* Only for arrays of numbers *) - write_vars#add tgt ; - read_vars#addList [tgt; tgt_o; src; src_o; n] - | SET_ARRAY_ELTS (a, s, n, v) -> - (* Only for arrays of numbers *) - write_vars#add a ; - read_vars#addList [a; s; n; v] - | OPERATION {op_name = opname; op_args = args} -> - if opname#getBaseName = "phi" - || opname#getBaseName = "final_phi" then - () - else - let addArg (s, v, mode) = - match mode with - | READ -> - read_vars#add v - | WRITE -> - write_vars#add v - | _ -> - read_write_vars#add v in - List.iter addArg args - | DOMAIN_OPERATION (_, {op_name = opnm; op_args = args}) -> - let addArg (_, v, mode) = - match mode with - | READ -> - read_vars#add v - | WRITE -> - write_vars#add v - | _ -> - read_write_vars#add v in - List.iter addArg args - | _ -> () - - method get_vars_in_code code = - self#walkCode code ; - (read_vars, write_vars, read_write_vars) - - method get_vars_in_cmd cmd = - self#walkCmd cmd ; - (read_vars, write_vars, read_write_vars) - - - end - -let get_vars_in_code proc_name code = - let collector = new read_write_var_collector_t proc_name in - collector#get_vars_in_code code - -let get_vars_in_cmd proc_name cmd = - let collector = new read_write_var_collector_t proc_name in - collector#get_vars_in_cmd cmd - -(* A stack with a toPretty method *) -class ['a] pretty_stack_t = - object - - inherit ['a] CHStack.stack_t - - method toPretty = - pretty_print_list stack (fun s -> s#toPretty) "{" ", " "}" - end - -(* A class to manage stacks of versions of variables *) -class vv_stacks_t = - object (self:_) - - val stacks : variable_t pretty_stack_t VariableCollections.table_t = - new VariableCollections.table_t - - val number_assignments : pretty_int_t VariableCollections.table_t ref = - ref (new VariableCollections.table_t) - - method get_tops = - let table = new VariableCollections.table_t in - let add_top var stack = - try table#set var stack#top with _ -> () in - stacks#iter add_top ; - table - - - method increase_assignments (var:variable_t) = - match !number_assignments#get var with - | Some num_p -> - let num = num_p#int in - !number_assignments#set var (new pretty_int_t (num + 1)) - | None -> - !number_assignments#set var (new pretty_int_t (1)) - - method push (var:variable_t) (new_var:variable_t) = - let _ = - match stacks#get var with - | Some stack -> - stack#push new_var - | None -> - let new_stack = new pretty_stack_t in - let _ = new_stack#push new_var in - stacks#set var new_stack in - self#increase_assignments var - - method pop (num_assignments: pretty_int_t VariableCollections.table_t) = - let pop_stack_var var = - let stack = Option.get (stacks#get var) in - let num = (Option.get (num_assignments#get var))#int in - for i = 0 to num - 1 do - let _ = stack#pop in - () - done in - let vars = num_assignments#listOfKeys in - List.iter pop_stack_var vars - - method get (var:variable_t) = stacks#get var - - method get_top (var:variable_t) = - (Option.get (stacks#get var))#top - - method reset_num_assignments = - number_assignments := new VariableCollections.table_t - - method num_assignments = - !number_assignments - - method toPretty = - LBLOCK [STR "stacks:"; NL; stacks#toPretty; NL; - STR "num_assignments:"; NL; !number_assignments#toPretty; NL] - end - -(* A class for equivalence classes of variables *) -class alias_sets_t = - object (self:_) - - val representative : variable_t VariableCollections.table_t = - new VariableCollections.table_t - - val constants : numerical_t VariableCollections.table_t = - new VariableCollections.table_t - - method private change_rep (old_rep:variable_t) (new_rep:variable_t) = - let change (var:variable_t) (rep:variable_t) = - if rep#getIndex = old_rep#getIndex then - representative#set var new_rep in - representative#iter change - - method add (var1: variable_t) (var2: variable_t) = - let get_rep var = - match representative#get var with - | Some rep -> rep - | None -> - begin - representative#set var var ; - var - end in - let rep1 = get_rep var1 in - let rep2 = get_rep var2 in - if self#better rep1 rep2 then - self#change_rep rep2 rep1 - else self#change_rep rep1 rep2 - - method add_const (var: variable_t) (c: numerical_t) = - let first = var#getName#getBaseName.[0] in - if first = 's' || first = 't' then - let const_var = - make_variable ("cN" ^ (string_of_big_int c#getNum)) NUM_VAR_TYPE in - constants#set const_var c ; - self#add var const_var - else () - - method private isRegister (v:variable_t) = - let str = v#getName#getBaseName in - str.[0] = 'r' && str.[1] <> 'e' - - method private better (var1: variable_t) (var2: variable_t) = - let isConstVar (v:variable_t) = - v#getName#getBaseName.[0] = 'c' in - let var1_index = var1#getIndex in - let var2_index = var2#getIndex in - if self#isRegister var1 then - true - else if self#isRegister var2 then - false - else if isConstVar var1 then - true - else if isConstVar var2 then - false - else if var1_index = exception_var_index then - true - else if var2_index = exception_var_index then - false - else if var2#isTmp then - true - else if var1#isTmp then - false - else if var1_index = num_return_var_index - || var1_index = sym_return_var_index then - true - else if var2_index = num_return_var_index - || var2_index = sym_return_var_index then - false - else - var1#getName#getSeqNumber <= var2#getName#getSeqNumber - - (* set1 and set2 are singleton sets. They are used here to as a - * reference to one variable *) - method private set_to_better - (set1: VariableCollections.set_t) - (set2: VariableCollections.set_t) = - let var1 = Option.get set1#choose in - let var2 = Option.get set2#choose in - if self#better var1 var2 then - begin - set2#remove var2 ; - set2#add var1 - end - else - begin - set1#remove var1 ; - set1#add var2 - end - - method change_representative - (subst: variable_t VariableCollections.table_t) = - let change_rep (var:variable_t) (rep:variable_t) = - match subst#get rep with - | Some new_rep -> - representative#set var new_rep - | _ -> () in - representative#iter change_rep ; - let add_new (old_rep:variable_t) (rep:variable_t) = - representative#set old_rep rep ; - representative#set rep rep in - subst#iter add_new - - method get_representative (var:variable_t) = - representative#get var - - method get_representatives = - representative - - method find_aliased_locals = - let aliased = ref [] in - let add_alias (var:variable_t) (rep:variable_t) = - if var#getIndex != rep#getIndex - && self#isRegister var - && self#isRegister rep then - aliased := (var, rep) :: !aliased - else - () in - representative#iter add_alias ; - !aliased - - method toPretty = - LBLOCK[ STR "representative: "; NL; representative#toPretty; - STR "constants: "; NL; constants#toPretty; NL] - - end - - -(* A class to manage versions of variables as well as - * temporary variables needed when transforming a CHIF to - * SSA form for cmds such as INCREMENT or any operations with - * READ_WRITE variables *) -class ssa_variable_t = - object (self: _) - - val versions : pretty_int_t VariableCollections.table_t = - new VariableCollections.table_t - - val stacks = ref (new vv_stacks_t) - val scope = ref (F.mkScope ()) - - method set_stacks (sts: vv_stacks_t) = - stacks := sts - - method set_scope (sc:scope_int) = - scope := sc - - method get_scope:scope_int = !scope - - method make_new_variable var = - let increase_version num = - versions#set var (new pretty_int_t num) in - let vname = var#getName in - let new_name = - match versions#get var with - | Some num_p -> - let num = num_p#int in - increase_version (num + 1) ; - new symbol_t - ~atts: vname#getAttributes - ~seqnr: num - vname#getBaseName - | None -> - begin - versions#set var (new pretty_int_t 1) ; - new symbol_t - ~atts: vname#getAttributes - ~seqnr: 0 - vname#getBaseName - end in - let new_var = - new variable_t - new_name - ~suffix:var#getSuffix - ~register:var#isRegister - ~path:var#getPath - var#getType in - (!stacks)#push var new_var ; - (!scope)#removeVariable var ; - (!scope)#addVariable new_var ; - new_var - - val temp_counter = ref (-1) - - method make_new_temp (var: variable_t) = - let temp_name = - incr temp_counter ; - new symbol_t ("$temp" ^ (string_of_int !temp_counter)) in - new variable_t temp_name var#getType - - end - +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +open Big_int_Z + +(* chlib *) +open CHLanguage +open CHNumerical +open CHPretty +open CHUtils + +(* jchlib *) +open JCHBasicTypes +open JCHBasicTypesAPI +open JCHDictionary + +(* jchpre *) +open JCHApplication +open JCHBytecodeLocation +open JCHPreAPI + +(* jchsys *) +open JCHPrintUtils +open JCHGlobals + +module F = CHOnlineCodeSet.LanguageFactory + + +(* Makes a new state with all the fields of oldState but with new_cmds *) +let mk_state (oldState:state_int) (new_cmds:code_int):state_int = + let new_state = F.mkState oldState#getLabel new_cmds in + let preds = oldState#getIncomingEdges in + let succs = oldState#getOutgoingEdges in + List.iter new_state#addIncomingEdge preds; + List.iter new_state#addOutgoingEdge succs; + new_state + +class proc_checker_t proc_name proc = + object (self: _) + + inherit code_walker_t as super + + val mInfo = app#get_method (retrieve_cms proc_name#getSeqNumber) + + method private check_invoke + (cn:class_name_int) + (ms:method_signature_int) + (iInfo:instruction_info_int) = + match cn#name with + | "java.lang.Integer" + | "java.lang.Short" + | "java.lang.Character" + | "java.lang.Byte" + | "java.lang.Long" + | "java.lang.Float" + | "java.lang.Double" + | "java.math.BigInteger" + | "java.math.BigDecimal" + + (* found the last one in com.ibm.icu.impl.data.LocaleElements_fa *) + | "com.ibm.icu.impl.ICUListResourceBundle$ResourceBinary" + + (* found in com.ibm.icu.impl.data.LocaleElements *) + | "com.ibm.icu.impl.ICUListResourceBundle$ResourceString" + + (* found in com.ibm.icu.impl.data.LocaleElements_sr *) + | "com.ibm.icu.impl.ICUListResourceBundle$Alias" + + (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) + | "com.google.javascript.jscomp.regex.CaseCanonicalize$DeltaSet" + + (* found in xmlbeans-2.6.0/build/lib/saxon.jar *) + | "net.sf.saxon.charcode.GB2312CharacterSet" + + | "java.util.HashMap" + + (* found in fop *) + | "org.apache.batik.gvt.text.GVTAttributedCharacterIterator$TextAttribute" -> + if ms#name <> "" then + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + + (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) + | "com.google.javascript.jscomp.regex.CharRanges" -> + let name = ms#name in + if name <> "withRanges" && name <> "inclusive" && name <> "withMembers"then + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + + (* found in com.google.common.net.TldPatterns. *) + | "com.google.common.collect.ImmutableList" + + (* found in com.google.javascript.jscomp.regex.CaseCanonicalize. *) + | "com.google.common.collect.ImmutableSet" -> + if ms#name <> "of" then + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + + | "java.util.Collections" -> (* found in fop *) + if ms#name <> "synchronizedMap" then + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + + | _ -> + let cms = make_cms cn ms in + let mInfo = app#get_method cms in + if mInfo#get_analysis_exclusions = [] then + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:check_invoke: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | OPERATION op -> + + begin + match op.op_name#getBaseName with + | "i" + | "ii" -> + let bcloc = get_bytecode_location + proc_name#getSeqNumber op.op_name#getSeqNumber in + let iInfo = app#get_instruction bcloc in + begin + match mInfo#get_opcode op.op_name#getSeqNumber with + | OpInvokeStatic (cn, ms) + | OpInvokeSpecial (cn, ms) + | OpInvokeInterface (cn, ms) -> + self#check_invoke cn ms iInfo + + | OpInvokeVirtual _ + | OpGetStatic _ + | OpGetField _ -> + raise + (JCH_failure + (LBLOCK [ STR "JCHTransformUtils:proc_checker:walkCmd: complicated"; + STR "not safe at: "; iInfo#toPretty ])) + | _ -> () + end + | _ -> super#walkCmd cmd + end + | _ -> super#walkCmd cmd + + method does_not_need_to_be_analyzed = + let args = JCHSystemUtils.get_signature_read_vars proc in + let ret_opt = JCHSystemUtils.get_return_var proc in + match args with + | [] -> + begin + try + self#walkCode proc#getBody; + Option.is_none ret_opt + with + | _ -> + if mInfo#get_instruction_count > 100 then + pr__debug [STR "possible large safe method: "; + proc_name#toPretty; STR " "; + proc_name_pp proc_name; NL]; + false + end + | _ -> false + end + +(* Note: this function is not called anywhere *) +let does_not_need_to_be_analyzed proc_name proc = + let proc_checker = new proc_checker_t proc_name proc in + proc_checker#does_not_need_to_be_analyzed + + +(* A var collector of variables modified when running the program. + * Some variables are writes in ASSERTs and flow control ops + * but they are not modifed when running the program *) +class read_write_var_collector_t (_proc_name:symbol_t) = + object (self: _) + + inherit var_collector_t + + val read_vars = new VariableCollections.set_t + val write_vars = new VariableCollections.set_t + val read_write_vars = new VariableCollections.set_t + + method getReadVars = read_vars + method getWriteVars = write_vars + method getReadWriteVars = read_write_vars + + + method !walkCmd (cmd: (code_int, cfg_int) command_t) = + match cmd with + | CODE (_, code) -> + self#walkCode code + | CFG (_, cfg) -> + let states = cfg#getStates in + List.iter (fun s -> self#walkCode (cfg#getState s)#getCode) states + | RELATION code -> + self#walkCode code + | TRANSACTION (_, code, post_code) -> + begin + self#walkCode code; + match post_code with + | None -> () + | Some code -> self#walkCode code + end + | ABSTRACT_VARS l -> + write_vars#addList l + | ASSIGN_SYM (v, SYM _) + | ASSIGN_NUM (v, NUM _) -> + write_vars#add v + | ASSIGN_NUM (v, PLUS (y,z)) + | ASSIGN_NUM (v, MINUS (y,z)) + | ASSIGN_NUM (v, MULT (y,z)) + | ASSIGN_NUM (v, DIV (y,z)) -> + write_vars#add v; + read_vars#addList [y; z] + | INCREMENT (v, _) -> + read_write_vars#add v; + | ASSIGN_NUM (v, NUM_VAR w) + | ASSIGN_STRUCT (v, w) + | ASSIGN_ARRAY (v, w) + | ASSIGN_SYM (v, SYM_VAR w) -> + write_vars#add v; + read_vars#add w; + | READ_NUM_ELT (v, a, i) -> + (* Arrays are introduced only for arrays of numbers *) + write_vars#add v; + read_vars#addList [a; i] + | ASSIGN_NUM_ELT (a, i, v) -> + read_write_vars#add a; + read_vars#addList [i; v] + | SHIFT_ARRAY (tgt, src, _n) -> + (* Only for arrays of numbers *) + write_vars#add tgt; + read_vars#add src + | BLIT_ARRAYS (tgt, tgt_o, src, src_o, n) -> + (* Only for arrays of numbers *) + write_vars#add tgt; + read_vars#addList [tgt; tgt_o; src; src_o; n] + | SET_ARRAY_ELTS (a, s, n, v) -> + (* Only for arrays of numbers *) + write_vars#add a; + read_vars#addList [a; s; n; v] + | OPERATION {op_name = opname; op_args = args} -> + if opname#getBaseName = "phi" + || opname#getBaseName = "final_phi" then + () + else + let addArg (_s, v, mode) = + match mode with + | READ -> + read_vars#add v + | WRITE -> + write_vars#add v + | _ -> + read_write_vars#add v in + List.iter addArg args + | DOMAIN_OPERATION (_, {op_name = _opnm; op_args = args}) -> + let addArg (_, v, mode) = + match mode with + | READ -> + read_vars#add v + | WRITE -> + write_vars#add v + | _ -> + read_write_vars#add v in + List.iter addArg args + | _ -> () + + method get_vars_in_code code = + self#walkCode code; + (read_vars, write_vars, read_write_vars) + + method get_vars_in_cmd cmd = + self#walkCmd cmd; + (read_vars, write_vars, read_write_vars) + + + end + +let get_vars_in_code proc_name code = + let collector = new read_write_var_collector_t proc_name in + collector#get_vars_in_code code + +let get_vars_in_cmd proc_name cmd = + let collector = new read_write_var_collector_t proc_name in + collector#get_vars_in_cmd cmd + +(* A stack with a toPretty method *) +class ['a] pretty_stack_t = + object + + inherit ['a] CHStack.stack_t + + method toPretty = + pretty_print_list stack (fun s -> s#toPretty) "{" ", " "}" + end + +(* A class to manage stacks of versions of variables *) +class vv_stacks_t = + object (self:_) + + val stacks : variable_t pretty_stack_t VariableCollections.table_t = + new VariableCollections.table_t + + val number_assignments : pretty_int_t VariableCollections.table_t ref = + ref (new VariableCollections.table_t) + + method get_tops = + let table = new VariableCollections.table_t in + let add_top var stack = + try table#set var stack#top with _ -> () in + stacks#iter add_top; + table + + + method increase_assignments (var:variable_t) = + match !number_assignments#get var with + | Some num_p -> + let num = num_p#int in + !number_assignments#set var (new pretty_int_t (num + 1)) + | None -> + !number_assignments#set var (new pretty_int_t (1)) + + method push (var:variable_t) (new_var:variable_t) = + let _ = + match stacks#get var with + | Some stack -> + stack#push new_var + | None -> + let new_stack = new pretty_stack_t in + let _ = new_stack#push new_var in + stacks#set var new_stack in + self#increase_assignments var + + method pop (num_assignments: pretty_int_t VariableCollections.table_t) = + let pop_stack_var var = + let stack = Option.get (stacks#get var) in + let num = (Option.get (num_assignments#get var))#int in + for _i = 0 to num - 1 do + let _ = stack#pop in + () + done in + let vars = num_assignments#listOfKeys in + List.iter pop_stack_var vars + + method get (var:variable_t) = stacks#get var + + method get_top (var:variable_t) = + (Option.get (stacks#get var))#top + + method reset_num_assignments = + number_assignments := new VariableCollections.table_t + + method num_assignments = + !number_assignments + + method toPretty = + LBLOCK [STR "stacks:"; NL; stacks#toPretty; NL; + STR "num_assignments:"; NL; !number_assignments#toPretty; NL] + end + +(* A class for equivalence classes of variables *) +class alias_sets_t = + object (self:_) + + val representative : variable_t VariableCollections.table_t = + new VariableCollections.table_t + + val constants : numerical_t VariableCollections.table_t = + new VariableCollections.table_t + + method private change_rep (old_rep:variable_t) (new_rep:variable_t) = + let change (var:variable_t) (rep:variable_t) = + if rep#getIndex = old_rep#getIndex then + representative#set var new_rep in + representative#iter change + + method add (var1: variable_t) (var2: variable_t) = + let get_rep var = + match representative#get var with + | Some rep -> rep + | None -> + begin + representative#set var var; + var + end in + let rep1 = get_rep var1 in + let rep2 = get_rep var2 in + if self#better rep1 rep2 then + self#change_rep rep2 rep1 + else self#change_rep rep1 rep2 + + method add_const (var: variable_t) (c: numerical_t) = + let first = var#getName#getBaseName.[0] in + if first = 's' || first = 't' then + let const_var = + make_variable ("cN" ^ (string_of_big_int c#getNum)) NUM_VAR_TYPE in + constants#set const_var c; + self#add var const_var + else () + + method private isRegister (v:variable_t) = + let str = v#getName#getBaseName in + str.[0] = 'r' && str.[1] <> 'e' + + method private better (var1: variable_t) (var2: variable_t) = + let isConstVar (v:variable_t) = + v#getName#getBaseName.[0] = 'c' in + let var1_index = var1#getIndex in + let var2_index = var2#getIndex in + if self#isRegister var1 then + true + else if self#isRegister var2 then + false + else if isConstVar var1 then + true + else if isConstVar var2 then + false + else if var1_index = exception_var_index then + true + else if var2_index = exception_var_index then + false + else if var2#isTmp then + true + else if var1#isTmp then + false + else if var1_index = num_return_var_index + || var1_index = sym_return_var_index then + true + else if var2_index = num_return_var_index + || var2_index = sym_return_var_index then + false + else + var1#getName#getSeqNumber <= var2#getName#getSeqNumber + + (* set1 and set2 are singleton sets. They are used here to as a + * reference to one variable *) + method private set_to_better + (set1: VariableCollections.set_t) + (set2: VariableCollections.set_t) = + let var1 = Option.get set1#choose in + let var2 = Option.get set2#choose in + if self#better var1 var2 then + begin + set2#remove var2; + set2#add var1 + end + else + begin + set1#remove var1; + set1#add var2 + end + + method change_representative + (subst: variable_t VariableCollections.table_t) = + let change_rep (var:variable_t) (rep:variable_t) = + match subst#get rep with + | Some new_rep -> + representative#set var new_rep + | _ -> () in + representative#iter change_rep; + let add_new (old_rep:variable_t) (rep:variable_t) = + representative#set old_rep rep; + representative#set rep rep in + subst#iter add_new + + method get_representative (var:variable_t) = + representative#get var + + method get_representatives = + representative + + method find_aliased_locals = + let aliased = ref [] in + let add_alias (var:variable_t) (rep:variable_t) = + if var#getIndex != rep#getIndex + && self#isRegister var + && self#isRegister rep then + aliased := (var, rep) :: !aliased + else + () in + representative#iter add_alias; + !aliased + + method toPretty = + LBLOCK[ STR "representative: "; NL; representative#toPretty; + STR "constants: "; NL; constants#toPretty; NL] + + end + + +(* A class to manage versions of variables as well as + * temporary variables needed when transforming a CHIF to + * SSA form for cmds such as INCREMENT or any operations with + * READ_WRITE variables *) +class ssa_variable_t = + object + + val versions : pretty_int_t VariableCollections.table_t = + new VariableCollections.table_t + + val stacks = ref (new vv_stacks_t) + val scope = ref (F.mkScope ()) + + method set_stacks (sts: vv_stacks_t) = + stacks := sts + + method set_scope (sc:scope_int) = + scope := sc + + method get_scope:scope_int = !scope + + method make_new_variable var = + let increase_version num = + versions#set var (new pretty_int_t num) in + let vname = var#getName in + let new_name = + match versions#get var with + | Some num_p -> + let num = num_p#int in + increase_version (num + 1); + new symbol_t + ~atts: vname#getAttributes + ~seqnr: num + vname#getBaseName + | None -> + begin + versions#set var (new pretty_int_t 1); + new symbol_t + ~atts: vname#getAttributes + ~seqnr: 0 + vname#getBaseName + end in + let new_var = + new variable_t + new_name + ~suffix:var#getSuffix + ~register:var#isRegister + ~path:var#getPath + var#getType in + (!stacks)#push var new_var; + (!scope)#removeVariable var; + (!scope)#addVariable new_var; + new_var + + val temp_counter = ref (-1) + + method make_new_temp (var: variable_t) = + let temp_name = + incr temp_counter; + new symbol_t ("$temp" ^ (string_of_int !temp_counter)) in + new variable_t temp_name var#getType + + end diff --git a/CodeHawk/CHJ/jchsys/jCHTransformUtils.mli b/CodeHawk/CHJ/jchsys/jCHTransformUtils.mli index 6b581f6d..3874cb31 100644 --- a/CodeHawk/CHJ/jchsys/jCHTransformUtils.mli +++ b/CodeHawk/CHJ/jchsys/jCHTransformUtils.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -28,22 +29,22 @@ (* chlib *) open CHLanguage open CHNumerical -open CHPretty +open CHPretty open CHUtils val does_not_need_to_be_analyzed : symbol_t -> procedure_int -> bool val mk_state : state_int -> code_int -> state_int -val get_vars_in_code : +val get_vars_in_code : symbol_t -> code_int -> VariableCollections.set_t * VariableCollections.set_t * VariableCollections.set_t - -val get_vars_in_cmd : - symbol_t + +val get_vars_in_cmd : + symbol_t -> (code_int, cfg_int) command_t -> VariableCollections.set_t * VariableCollections.set_t @@ -67,7 +68,7 @@ class vv_stacks_t : object ('a) method get : variable_t -> variable_t pretty_stack_t option method get_top : variable_t -> variable_t - method get_tops : variable_t VariableCollections.table_t + method get_tops : variable_t VariableCollections.table_t method increase_assignments : variable_t -> unit method num_assignments : JCHPrintUtils.pretty_int_t VariableCollections.table_t @@ -85,7 +86,7 @@ class alias_sets_t : method change_representative : variable_t VariableCollections.table_t -> unit method find_aliased_locals : (variable_t * variable_t) list method get_representative : variable_t -> variable_t option - method get_representatives : variable_t VariableCollections.table_t + method get_representatives : variable_t VariableCollections.table_t method toPretty : pretty_t end diff --git a/CodeHawk/CHJ/jchsys/jCHTypeUtils.ml b/CodeHawk/CHJ/jchsys/jCHTypeUtils.ml index 9edcf32d..bdbb0ec3 100755 --- a/CodeHawk/CHJ/jchsys/jCHTypeUtils.ml +++ b/CodeHawk/CHJ/jchsys/jCHTypeUtils.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -36,7 +37,6 @@ open CHUtils (* chutil *) open CHLogger -open CHPrettyUtil (* jchlib *) open JCHBasicTypes @@ -49,55 +49,53 @@ open JCHPreAPI (* jchsys *) open JCHGlobals -open JCHPrintUtils -let dbg = ref false let get_object_vt () = TObject (TClass (make_cn "java.lang.Object")) let get_string_vt () = TObject (TClass (make_cn "java.lang.String" )) let get_throwable_vt () = TObject (TClass (make_cn "java.lang.Throwable")) -let bool_interval = +let bool_interval = let min = numerical_zero in let max = numerical_one in mkInterval min max -let byte_interval = +let byte_interval = let min = new numerical_t (big_int_of_int (-128)) in let max = new numerical_t (big_int_of_int 127) in mkInterval min max - -let short_interval = + +let short_interval = let min = new numerical_t (big_int_of_int (-32768)) in let max = new numerical_t (big_int_of_int 32767) in mkInterval min max - -let char_interval = + +let char_interval = let min = numerical_zero in let max = new numerical_t (big_int_of_int 65535) in mkInterval min max - -let integer_interval = + +let integer_interval = let min = new numerical_t (big_int_of_int (-2147483648)) in let max = new numerical_t (big_int_of_int 2147483647) in mkInterval min max - -let long_interval = + +let long_interval = let min = new numerical_t (big_int_of_string "-9223372036854775808") in let max = new numerical_t (big_int_of_string "9223372036854775807") in mkInterval min max -let length_interval = +let length_interval = let min = numerical_zero in let max = new numerical_t (big_int_of_int 2147483647) in mkInterval min max -let loop_counter_interval = - let min = CHBounds.bound_of_num numerical_zero in +let loop_counter_interval = + let min = CHBounds.bound_of_num numerical_zero in new interval_t min CHBounds.plus_inf_bound - -let get_interval_from_basic_type bt = - match bt with + +let get_interval_from_basic_type bt = + match bt with | Bool -> bool_interval | ByteBool | Byte -> byte_interval @@ -108,7 +106,7 @@ let get_interval_from_basic_type bt = | Long -> long_interval | _ -> topInterval -let get_interval_from_class_name (cname:string) = +let get_interval_from_class_name (cname:string) = if cname = "java.lang.Byte" then byte_interval else if cname = "java.lang.Short" then short_interval else if cname = "java.lang.Character" then char_interval @@ -116,59 +114,59 @@ let get_interval_from_class_name (cname:string) = else if cname = "java.lang.Long" then long_interval else topInterval -let rec get_interval_from_vtype (vt:value_type_t) = - match vt with +let rec get_interval_from_vtype (vt:value_type_t) = + match vt with | TBasic bt -> get_interval_from_basic_type bt - | TObject TArray et -> get_interval_from_vtype et + | TObject TArray et -> get_interval_from_vtype et | TObject TClass cn -> get_interval_from_class_name cn#name -let get_interval_from_type (topt: value_type_t option) = - match topt with +let get_interval_from_type (topt: value_type_t option) = + match topt with | Some vt -> get_interval_from_vtype vt | _ -> topInterval -let get_var_interval_from_type v (topt: value_type_t option) = +let get_var_interval_from_type v (topt: value_type_t option) = if JCHSystemUtils.is_length v then length_interval else if JCHSystemUtils.is_loop_counter v then loop_counter_interval - else - match topt with + else + match topt with | Some vt -> get_interval_from_vtype vt | _ -> topInterval -let is_java_basic_type_primitive (jbt:java_basic_type_t) = - match jbt with - | Object - | Void -> false +let is_java_basic_type_primitive (jbt:java_basic_type_t) = + match jbt with + | Object + | Void -> false | _ -> true -let rec is_object_type_primitive (ot:object_type_t) = - match ot with - | TClass cn -> false - | TArray vt -> is_primitive vt +let rec is_object_type_primitive (ot:object_type_t) = + match ot with + | TClass _ -> false + | TArray vt -> is_primitive vt -and is_primitive (vt:value_type_t) = - match vt with +and is_primitive (vt:value_type_t) = + match vt with | TBasic jbt -> is_java_basic_type_primitive jbt | TObject ot -> is_object_type_primitive ot -let is_primitive_not_bool_opt (vt_opt:value_type_t option) = - match vt_opt with - | None -> false - | Some (TBasic Bool) -> false +let is_primitive_not_bool_opt (vt_opt:value_type_t option) = + match vt_opt with + | None -> false + | Some (TBasic Bool) -> false | Some vt -> is_primitive vt -let is_primitive_not_bool (vt:value_type_t) = - match vt with - | TBasic Bool -> false +let is_primitive_not_bool (vt:value_type_t) = + match vt with + | TBasic Bool -> false | _ -> is_primitive vt -let get_array_dim (vt:value_type_t) = - let rec get_dim depth vt = +let get_array_dim (vt:value_type_t) = + let rec get_dim depth vt = match vt with | TObject TArray vt' -> get_dim (succ depth) vt' - | TObject TClass cn -> + | TObject TClass cn -> if cn#name = "java.lang.Object" then Some 0 else None | TBasic Object @@ -176,9 +174,9 @@ let get_array_dim (vt:value_type_t) = | TBasic _ -> Some depth in get_dim 0 vt -let get_numeric_type (cn:class_name_int) = +let get_numeric_type (cn:class_name_int) = match cn#name with - | "java.lang.Integer" -> Some Int + | "java.lang.Integer" -> Some Int | "java.lang.Short" -> Some Short | "java.lang.Character" -> Some Char | "java.lang.Byte" -> Some Byte @@ -187,129 +185,129 @@ let get_numeric_type (cn:class_name_int) = | "java.lang.Double" -> Some Double | _ -> None -let is_collection_class (cn:class_name_int) = - if app#has_class cn then +let is_collection_class (cn:class_name_int) = + if app#has_class cn then let cInfo = app#get_class cn in - cInfo#is_collection_class || cInfo#is_map_class + cInfo#is_collection_class || cInfo#is_map_class else false - -let is_collection_type (vtype:value_type_t) = - match vtype with + +let is_collection_type (vtype:value_type_t) = + match vtype with | TObject TClass cn -> is_collection_class cn | TObject TArray _ -> true - | _ -> false + | _ -> false -let can_be_collection (vtypes:value_type_t list) = - if vtypes = [] then false - else List.for_all is_collection_type vtypes +let can_be_collection (vtypes:value_type_t list) = + if vtypes = [] then false + else List.for_all is_collection_type vtypes -let merge_types (vtypes1:value_type_t list) (vtypes2:value_type_t list) = +let merge_types (vtypes1:value_type_t list) (vtypes2:value_type_t list) = if vtypes1 = [] then vtypes2 else if vtypes2 = [] then vtypes1 - else + else begin - let add_type (vtypes:value_type_t list) (vtype:value_type_t) = + let add_type (vtypes:value_type_t list) (vtype:value_type_t) = if List.exists (fun t -> compare_value_types vtype t = 0) vtypes then - vtypes + vtypes else vtype :: vtypes in - List.fold_left add_type vtypes1 vtypes2 + List.fold_left add_type vtypes1 vtypes2 end -let rec make_type_list (vtype:value_type_t) = - match vtype with +let rec make_type_list (vtype:value_type_t) = + match vtype with | TBasic Int2Bool -> - [ TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int ] - | TBasic ByteBool -> [ TBasic Bool; TBasic Byte ] - | TBasic Object -> [ get_object_vt () ] - | TObject (TArray vt) -> + [TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int] + | TBasic ByteBool -> [TBasic Bool; TBasic Byte] + | TBasic Object -> [get_object_vt ()] + | TObject (TArray vt) -> let types = make_type_list vt in List.map (fun t -> TObject (TArray t)) types - | _ -> [ vtype ] + | _ -> [vtype] -let rec make_int_type_list (vtype:value_type_t) = - match vtype with - | TBasic Int2Bool +let make_int_type_list (vtype:value_type_t) = + match vtype with + | TBasic Int2Bool | TBasic ByteBool | TBasic Bool - | TBasic Char + | TBasic Char | TBasic Int | TBasic Byte | TBasic Short -> - [ TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int ] - | TBasic Object -> [ get_object_vt () ] - | _ -> [ vtype ] + [TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int] + | TBasic Object -> [get_object_vt ()] + | _ -> [vtype] -let get_compact_type (vtypes:value_type_t list) = - if List.length vtypes > 1 then +let get_compact_type (vtypes:value_type_t list) = + if List.length vtypes > 1 then let has_type vt = List.exists (fun t -> t = vt) vtypes in let is_not_in_types vts vt = List.for_all (fun vt' -> vt' <> vt) vts in - if (has_type (TBasic Bool)) && (has_type (TBasic Byte)) then + if (has_type (TBasic Bool)) && (has_type (TBasic Byte)) then if (has_type (TBasic Short)) && (has_type (TBasic Char)) - && (has_type (TBasic Int)) then + && (has_type (TBasic Int)) then (TBasic Int2Bool) :: (List.filter (is_not_in_types - [ TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int ]) - vtypes) + [TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int]) + vtypes) else (TBasic ByteBool) :: (List.filter (is_not_in_types [TBasic Bool; TBasic Byte]) vtypes) else - vtypes + vtypes else vtypes - + let equal_value_type_lists - (vtypes1:value_type_t list) (vtypes2:value_type_t list) = - if List.length vtypes1 = List.length vtypes2 then + (vtypes1:value_type_t list) (vtypes2:value_type_t list) = + if List.length vtypes1 = List.length vtypes2 then List.for_all (fun t1 -> List.exists (fun t2 -> compare_value_types t1 t2 = 0) vtypes2) vtypes1 else false -let is_float_type (t:value_type_t) = +let is_float_type (t:value_type_t) = match t with | TBasic Float | TBasic Double -> true | _ -> false -let can_be_float (vtypes:value_type_t list) = +let can_be_float (vtypes:value_type_t list) = if vtypes = [] then - true + true else - List.for_all is_float_type vtypes + List.for_all is_float_type vtypes -let exception_type = TObject (TClass (make_cn "java.lang.Throwable")) +let _exception_type = TObject (TClass (make_cn "java.lang.Throwable")) -let is_enum (cn:class_name_int) = - if app#has_class cn then - let cInfo = app#get_class cn in - if cInfo#has_super_class then - cInfo#get_super_class#name = "java.lang.Enum" +let is_enum (cn:class_name_int) = + if app#has_class cn then + let cInfo = app#get_class cn in + if cInfo#has_super_class then + cInfo#get_super_class#name = "java.lang.Enum" else - false + false else - false + false (* This does not include the Enum classes *) (* Note: can this be moved to the summaries? *) -let is_immutable_class (cn:class_name_int) = +let is_immutable_class (cn:class_name_int) = let name = cn#name in let ls = Str.split (Str.regexp "\\.") name in let package = String.concat "." (List.rev (List.tl (List.rev ls))) in let class_name = List.hd (List.rev ls) in - match package with - | "java.lang" -> + match package with + | "java.lang" -> begin class_name = "String" || - class_name = "Integer" || + class_name = "Integer" || class_name = "Byte" || class_name = "Character" || class_name = "Boolean" || @@ -317,21 +315,21 @@ let is_immutable_class (cn:class_name_int) = class_name = "Long" || class_name = "Double" || class_name = "Float" || - class_name = "StackTraceElement" + class_name = "StackTraceElement" end - | "java.lang.invoke" -> + | "java.lang.invoke" -> class_name = "MethodType" - | "java.math" -> + | "java.math" -> begin - class_name = "BigInteger" || + class_name = "BigInteger" || class_name = "BigDecimal" || - class_name = "MathContext" + class_name = "MathContext" end - | "java.security" -> + | "java.security" -> class_name = "CodeSigner" || class_name = "Timestamp" || - class_name = "Permission" - | "java.security.spec" -> + class_name = "Permission" + | "java.security.spec" -> begin class_name = "ECFieldF2m" || class_name = "ECFieldFp" || @@ -340,22 +338,22 @@ let is_immutable_class (cn:class_name_int) = class_name = "ECPoint" || class_name = "ECPrivateKeySpec" || class_name = "ECPublicKeySpec" || - class_name = "EllipticCurve" + class_name = "EllipticCurve" end - | "java.security.cert" -> + | "java.security.cert" -> begin class_name = "CertPath" || - class_name = "PolicyQualifierInfo" + class_name = "PolicyQualifierInfo" end | "java.security.Provider" -> class_name = "Service" - | "java.util" -> - class_name = "java.util.UUID" - | "java.util.regexp" -> - class_name = "Pattern" - | "java.util.AbstractMap" -> - class_name = "SimpleImmutableEntry" - | "java.awt" -> + | "java.util" -> + class_name = "java.util.UUID" + | "java.util.regexp" -> + class_name = "Pattern" + | "java.util.AbstractMap" -> + class_name = "SimpleImmutableEntry" + | "java.awt" -> begin class_name = "TextLayout" || class_name = "TransformAttribute" || @@ -363,24 +361,24 @@ let is_immutable_class (cn:class_name_int) = class_name = "BasicStroke" || class_name = "Color" || class_name = "AlphaComposite" - end + end | "java.awt.font" -> begin class_name = "ImageGraphicAttribute" || class_name = "ShapeGraphicAttribute" end - | "java.awt.RenderingHints" -> + | "java.awt.RenderingHints" -> class_name = "Key" - | "java.io" -> + | "java.io" -> class_name = "File" - | "java.nio.file.attribute" -> + | "java.nio.file.attribute" -> class_name = "FileTime" - | "java.net" -> - begin + | "java.net" -> + begin class_name = "URI" || class_name = "InetSocketAddress" end - | "javax.management" -> + | "javax.management" -> begin class_name = "ImmutableDescriptor" || class_name = "MBeanFeatureInfo" || @@ -392,112 +390,112 @@ let is_immutable_class (cn:class_name_int) = class_name = "ObjectName" || class_name = "OpenMBeanOperationInfoSupport" end - | "javax.swing.text" -> + | "javax.swing.text" -> begin class_name = "TabSet" || class_name = "TabStop" end - | "javax.lang.model.element" -> + | "javax.lang.model.element" -> begin - class_name = "Name" + class_name = "Name" end - | "javax.swing.plaf.synth" -> - class_name = "SynthContext" - | "javax.swing.text.AbstractDocument" -> + | "javax.swing.plaf.synth" -> + class_name = "SynthContext" + | "javax.swing.text.AbstractDocument" -> class_name = "AbstractElement" - | "javax.xml.datatype" -> + | "javax.xml.datatype" -> class_name = "Duration" - | "javax.xml.validation" -> - class_name = "javax.xml.validation.Schema" + | "javax.xml.validation" -> + class_name = "javax.xml.validation.Schema" | _ -> false - -let is_immutable_t (vt:value_type_t) = - match vt with + +let is_immutable_t (vt:value_type_t) = + match vt with | TBasic Object-> false - | TBasic _ -> true - | TObject (TClass cn) -> + | TBasic _ -> true + | TObject (TClass cn) -> is_enum cn || is_immutable_class cn - | _ -> false + | _ -> false -let is_immutable_type (vtypes:value_type_t list) = +let is_immutable_type (vtypes:value_type_t list) = List.for_all is_immutable_t vtypes -let get_class_info (cn:class_name_int) = +let get_class_info (cn:class_name_int) = if app#has_class cn then app#get_class cn - else + else begin ch_error_log#add "class info not found" cn#toPretty ; - raise (JCH_failure (STR "missing class")) + raise (JCH_failure (STR "missing class")) end -let get_class_info_opt (cn:class_name_int) = +let get_class_info_opt (cn:class_name_int) = if app#has_class cn then Some (app#get_class cn) - else + else begin ch_error_log#add "class info not found" cn#toPretty ; None end let get_all_supra_interfaces (cInfo:class_info_int) = - let rec add_interfaces res cni = + let rec add_interfaces res cni = let new_res = if cni#is_interface then cni :: res else res in let interfaces = cni#get_interfaces in let cnis = List.map get_class_info interfaces in List.fold_left add_interfaces new_res cnis in add_interfaces [] cInfo -let have_common_supra_interface (cInfo1:class_info_int) (cInfo2:class_info_int) = +let _have_common_supra_interface (cInfo1:class_info_int) (cInfo2:class_info_int) = let sup1 = get_all_supra_interfaces cInfo1 in let sup2 = get_all_supra_interfaces cInfo2 in List.exists (fun i1 -> List.exists (fun i2 -> i1#get_index = i2#get_index) sup2) sup1 -let rec has_interface (cInfo: class_info_int) (cni:class_name_int) = +let rec has_interface (cInfo: class_info_int) (cni:class_name_int) = let interfaces = cInfo#get_interfaces in let cnix = cni#index in if List.exists (fun i -> i#index = cnix) interfaces then true - else - let is_sub i = + else + let is_sub i = let i_info = get_class_info i in has_interface i_info cni in - List.exists is_sub interfaces + List.exists is_sub interfaces -let rec implements_interface (cinfo:class_info_int) (cni: class_name_int) = - if has_interface cinfo cni then true - else if cinfo#has_super_class then +let rec implements_interface (cinfo:class_info_int) (cni: class_name_int) = + if has_interface cinfo cni then true + else if cinfo#has_super_class then let cn = cinfo#get_super_class in - match get_class_info_opt cn with + match get_class_info_opt cn with | Some cn_info -> implements_interface cn_info cni (* RESTORE *) - | _ -> false - else false + | _ -> false + else false -let is_subclass (cn1:class_name_int) (cn2:class_name_int) = +let is_subclass (cn1:class_name_int) (cn2:class_name_int) = if cn1#name = cn2#name then - true + true else if cn2#name = "java.lang.Object" then true else if cn1#name = "java.lang.Object" then - cn2#name = "java.lang.Object" - else - match get_class_info_opt cn1 with - | Some cInfo1 -> + cn2#name = "java.lang.Object" + else + match get_class_info_opt cn1 with + | Some cInfo1 -> cn1#index = cn2#index || app#is_descendant cn1 cn2 || implements_interface cInfo1 cn2 - || (cInfo1#is_interface && has_interface cInfo1 cn2) - | _ -> false + || (cInfo1#is_interface && has_interface cInfo1 cn2) + | _ -> false (* one is a subclass of the other or they implement the same interface *) (* Note: ambiguous precedence in expression? *) -let is_compatible (cn1:class_name_int) (cn2:class_name_int) = +let is_compatible (cn1:class_name_int) (cn2:class_name_int) = if is_subclass cn1 cn2 || is_subclass cn2 cn1 then true else - match (get_class_info_opt cn1, get_class_info_opt cn2) with + match (get_class_info_opt cn1, get_class_info_opt cn2) with | (Some cInfo1, Some cInfo2) -> cInfo1#is_interface && (implements_interface cInfo2 cn1) @@ -505,131 +503,131 @@ let is_compatible (cn1:class_name_int) (cn2:class_name_int) = && (implements_interface cInfo1 cn2) | _ -> true -let rec is_subtype (vtype1:value_type_t) (vtype2:value_type_t) = - match (vtype1, vtype2) with +let rec is_subtype (vtype1:value_type_t) (vtype2:value_type_t) = + match (vtype1, vtype2) with | (TBasic t1, TBasic t2) -> t1 = t2 | (TObject _, TBasic Object) -> true | (TObject (TArray t1), TObject (TArray t2)) -> is_subtype t1 t2 - | (TBasic Object, TObject (TClass cn)) - | (TObject (TArray _), TObject (TClass cn)) -> cn#name = "java.lang.Object" - | (TObject (TClass cn1), TObject (TClass cn2)) -> is_subclass cn1 cn2 + | (TBasic Object, TObject (TClass cn)) + | (TObject (TArray _), TObject (TClass cn)) -> cn#name = "java.lang.Object" + | (TObject (TClass cn1), TObject (TClass cn2)) -> is_subclass cn1 cn2 | _ -> false -let is_strict_subtype (vtype1:value_type_t) (vtype2:value_type_t) = - let is_object (vt:value_type_t) = - match vt with +let is_strict_subtype (vtype1:value_type_t) (vtype2:value_type_t) = + let is_object (vt:value_type_t) = + match vt with | TBasic Object -> true - | TObject TClass cn -> cn#name = "java.lang.Object" + | TObject TClass cn -> cn#name = "java.lang.Object" | _ -> false in if compare_value_types vtype1 vtype2 = 0 then - false + false else if is_object vtype1 && is_object vtype2 then - false + false else is_subtype vtype1 vtype2 -let is_int_subtype (t1:value_type_t) (t2:value_type_t) = - match (t1, t2) with +let is_int_subtype (t1:value_type_t) (t2:value_type_t) = + match (t1, t2) with | (TBasic Bool, _) -> true | (TBasic Byte, TBasic Bool) -> false | (TBasic Byte, _) -> true - | (TBasic Short, TBasic Bool) + | (TBasic Short, TBasic Bool) | (TBasic Short, TBasic Byte) | (TBasic Short, TBasic Char) -> false | (TBasic Short, _) -> true - | (TBasic Char, TBasic Bool) - | (TBasic Char, TBasic Byte) + | (TBasic Char, TBasic Bool) + | (TBasic Char, TBasic Byte) | (TBasic Char, TBasic Short) -> false | (TBasic Char, _) -> true | (TBasic Int, TBasic Int) -> true - | _ -> false + | _ -> false -let is_bool (t:value_type_t) = - match t with +let is_bool (t:value_type_t) = + match t with | TBasic Bool -> true - | _ -> false + | _ -> false -let is_byte (t:value_type_t) = - match t with +let is_byte (t:value_type_t) = + match t with | TBasic Byte -> true - | _ -> false + | _ -> false -let is_short (t:value_type_t) = - match t with +let is_short (t:value_type_t) = + match t with | TBasic Short -> true - | _ -> false + | _ -> false -let is_char (t:value_type_t) = - match t with +let is_char (t:value_type_t) = + match t with | TBasic Char -> true - | _ -> false + | _ -> false -let is_int (t:value_type_t) = - match t with +let is_int (t:value_type_t) = + match t with | TBasic Int -> true - | _ -> false + | _ -> false -let is_long (t:value_type_t) = - match t with +let is_long (t:value_type_t) = + match t with | TBasic Long -> true - | _ -> false + | _ -> false -let is_array (t:value_type_t) = - match t with +let is_array (t:value_type_t) = + match t with | TObject (TArray _) -> true | _ -> false let set_to_var_to_types (var_to_types:JCHTypeSets.type_set_t VariableCollections.table_t) (v:variable_t) - (t:JCHTypeSets.type_set_t) = + (t:JCHTypeSets.type_set_t) = var_to_types#set v t let get_types_from_sig (var_to_types:JCHTypeSets.type_set_t VariableCollections.table_t) (proc_name:symbol_t) - (sig_vars:variable_t list) = - let set_type (t:value_type_t) (v:variable_t) = - let rec make_type_list (t:value_type_t) = - match t with + (sig_vars:variable_t list) = + let set_type (t:value_type_t) (v:variable_t) = + let rec make_type_list (t:value_type_t) = + match t with | TBasic Int2Bool -> - [ TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int ] - | TBasic ByteBool -> [ TBasic Bool; TBasic Byte ] - | TBasic Object -> [ get_object_vt () ] - | TObject (TArray vt) -> + [TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int] + | TBasic ByteBool -> [TBasic Bool; TBasic Byte] + | TBasic Object -> [get_object_vt ()] + | TObject (TArray vt) -> let types = make_type_list vt in List.map (fun t -> TObject (TArray t)) types | _ -> [t] in let vtypes = JCHTypeSets.mk_type_set (make_type_list t) in - match var_to_types#get v with - | Some old_vtypes -> + match var_to_types#get v with + | Some old_vtypes -> set_to_var_to_types var_to_types v (old_vtypes#meet vtypes) | _ -> set_to_var_to_types var_to_types v vtypes in let cms = retrieve_cms proc_name#getSeqNumber in let mInfo = app#get_method cms in - let args = + let args = List.filter JCHSystemUtils.is_not_exception_or_return sig_vars in let descr = cms#method_signature#descriptor in - let arg_types = + let arg_types = let param_types = descr#arguments in if mInfo#is_static then - param_types - else + param_types + else let class_type = TObject (TClass cms#class_name) in class_type :: param_types in begin List.iter2 set_type arg_types args ; - (match descr#return_value with - | Some vt -> + (match descr#return_value with + | Some vt -> begin try let return = List.find JCHSystemUtils.is_return sig_vars in - set_type vt return + set_type vt return with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "return value not found in " ; - STR "JCHTypeUtils.get_types_from_sig" ])) + (LBLOCK [STR "return value not found in " ; + STR "JCHTypeUtils.get_types_from_sig"])) end | None -> () ) ; set_type (get_throwable_vt ()) exception_var @@ -646,9 +644,9 @@ let is_class_with_length (cn:class_name_int) = false in aux cn -let is_type_with_length (vtype:value_type_t) = - match vtype with - | TObject (TArray vt) -> true +let is_type_with_length (vtype:value_type_t) = + match vtype with + | TObject (TArray _) -> true | TObject (TClass cn) -> is_class_with_length cn | _ -> false @@ -658,7 +656,7 @@ let is_type_with_length (vtype:value_type_t) = let get_types_from_stack_info (proc_name:symbol_t) (proc:procedure_int) - (phi_to_vars:VariableCollections.set_t VariableCollections.table_t) : + (phi_to_vars:VariableCollections.set_t VariableCollections.table_t) : (int * (value_type_t list * bool)) list = let cms = retrieve_cms proc_name#getSeqNumber in let mInfo = app#get_method cms in @@ -667,68 +665,68 @@ let get_types_from_stack_info let pc_to_stack_layout = new IntCollections.table_t in let _ = List.iter (fun (pc,s) -> pc_to_stack_layout#set pc s) stack_layouts in let var_to_types = new VariableCollections.table_t in - (* variables that could have a length; covers the case when a variable is - * initialized as a null object, then used as an argument *) - let vars_with_lengths = new VariableCollections.set_t in + (* variables that could have a length; covers the case when a variable is + * initialized as a null object, then used as an argument *) + let vars_with_lengths = new VariableCollections.set_t in let add_to_var_to_types (new_set:JCHTypeSets.type_set_t) (var:variable_t) = - (match var_to_types#get var with - | Some set -> - if JCHTypeSets.get_type_list set = [] then + (match var_to_types#get var with + | Some set -> + if JCHTypeSets.get_type_list set = [] then set_to_var_to_types var_to_types var new_set - else - if JCHTypeSets.is_num_type_set set then - begin + else + if JCHTypeSets.is_num_type_set set then + begin if new_set#leq set then set_to_var_to_types var_to_types var new_set - else if set#leq new_set then + else if set#leq new_set then () else - (* If there are contradictory types than the smallest type + (* If there are contradictory types than the smallest type * should be still correct *) let meet_set = set#meet new_set in let list = ref (JCHTypeSets.get_type_list meet_set) in - let add_min_type l1 l2 t = + let add_min_type l1 l2 t = if List.mem t l1 && List.mem t l2 then - false - else if List.mem t l1 || List.mem t l2 then - begin + false + else if List.mem t l1 || List.mem t l2 then + begin list := t :: !list ; - false + false end else true in - let smallest set1 set2 = + let smallest set1 set2 = let l1 = JCHTypeSets.get_type_list set1 in let l2 = JCHTypeSets.get_type_list set2 in begin - (if add_min_type l1 l2 (TBasic Bool) then - if add_min_type l1 l2 (TBasic Byte) then - if add_min_type l1 l2 (TBasic Short) then - if add_min_type l1 l2 (TBasic Char) then + (if add_min_type l1 l2 (TBasic Bool) then + if add_min_type l1 l2 (TBasic Byte) then + if add_min_type l1 l2 (TBasic Short) then + if add_min_type l1 l2 (TBasic Char) then let _ = add_min_type l1 l2 (TBasic Int) in ()) ; JCHTypeSets.mk_type_set !list end in set_to_var_to_types var_to_types var (smallest set new_set) ; end - else + else let join_set = set#join new_set in set_to_var_to_types var_to_types var join_set | None -> set_to_var_to_types var_to_types var new_set ) in (* get type from stack info *) - let add_slot (pc: int) (stack:op_stack_layout_int) = - if stack#get_size > 0 then + let add_slot (_pc: int) (stack: op_stack_layout_int) = + if stack#get_size > 0 then try (* it's possible that the variable is unreachable *) let top_slot = stack#get_top_slot in let var = top_slot#get_transformed_variable in - let make_type_list (vtype:value_type_t) = - match vtype with + let make_type_list (vtype:value_type_t) = + match vtype with | TBasic Int2Bool -> - [ TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int ] - | TBasic ByteBool -> [ TBasic Bool; TBasic Byte ] - | TBasic Object -> [ get_object_vt () ] + [TBasic Bool; TBasic Byte; TBasic Short; TBasic Char; TBasic Int] + | TBasic ByteBool -> [TBasic Bool; TBasic Byte] + | TBasic Object -> [get_object_vt ()] | TObject (TArray vt) -> begin vars_with_lengths#add var ; @@ -738,9 +736,9 @@ let get_types_from_stack_info | TObject (TClass cn) -> begin (if is_class_with_length cn then vars_with_lengths#add var) ; - [ vtype ] + [vtype] end - | _ -> [ vtype ] in + | _ -> [vtype]in let vtypes = List.concat (List.map make_type_list top_slot#get_type) in add_to_var_to_types (JCHTypeSets.mk_type_set vtypes) var with _ -> () in @@ -751,18 +749,18 @@ let get_types_from_stack_info let p2v = new VariableCollections.table_t in let add_phi (phi:variable_t) (vars:VariableCollections.set_t) = p2v#set phi vars#clone ; - let add v = + let add v = match v2p#get v with | Some set -> set#add phi - | None -> v2p#set v (VariableCollections.set_of_list [ phi ]) in + | None -> v2p#set v (VariableCollections.set_of_list [phi]) in vars#iter add in phi_to_vars#iter add_phi ; (v2p, p2v) in (* Add types for variables from the phi variables *) - let add_type_from_phi (phi: variable_t) (vars: VariableCollections.set_t) = - match var_to_types#get phi with - | Some types -> + let add_type_from_phi (phi: variable_t) (vars: VariableCollections.set_t) = + match var_to_types#get phi with + | Some types -> vars#iter (fun v -> set_to_var_to_types var_to_types v types) | _ -> () in new_phi_to_vars#iter add_type_from_phi ; @@ -770,106 +768,106 @@ let get_types_from_stack_info (* Add types for local variables that were incremented * As there was no change on the stack this is not covered by the previous *) let incremented_locals = ref [] in - let sig_vars = + let sig_vars = let bindings = proc#getBindings in - let get_internal_var (s,_,_) = + let get_internal_var (s,_,_) = try - snd (List.find (fun (s', v') -> s#equal s') bindings) + snd (List.find (fun (s', _v') -> s#equal s') bindings) with | Not_found -> raise (JCH_failure - (LBLOCK [ STR "internal var not found for " ; s#toPretty ; - STR " in JCHTypeUtils.get_types_from_stackinfo" ])) in + (LBLOCK [STR "internal var not found for " ; s#toPretty ; + STR " in JCHTypeUtils.get_types_from_stackinfo"])) in List.map get_internal_var proc#getSignature in - let not_phis = + let not_phis = let not_phis = VariableCollections.set_of_list var_to_phi#listOfKeys in - not_phis#removeList (phi_to_vars#listOfKeys) ; + not_phis#removeList (phi_to_vars#listOfKeys) ; not_phis in let not_phis' = not_phis#clone in - not_phis'#removeList sig_vars ; - let add_iinc_var var = - match var_to_types#get var with + not_phis'#removeList sig_vars ; + let add_iinc_var var = + match var_to_types#get var with | Some _ -> () - | None -> + | None -> incremented_locals := var#getIndex :: !incremented_locals ; set_to_var_to_types var_to_types var (JCHTypeSets.mk_type_set [TBasic Int]) in - not_phis'#iter add_iinc_var; - + not_phis'#iter add_iinc_var; + get_types_from_sig var_to_types proc_name sig_vars ; - (* set types for phi vars *) - let set_phi_type (phi:variable_t) (vars:VariableCollections.set_t) = + (* set types for phi vars *) + let set_phi_type (phi:variable_t) (vars:VariableCollections.set_t) = let set = ref JCHTypeSets.bottom_type_set in - let add v = + let add v = let t = Option.get (var_to_types#get v) in set := !set#join t in vars#iter add ; set_to_var_to_types var_to_types phi !set in let done_vars = new VariableCollections.set_t in - let rec work (vars:variable_t list) = - match vars with - | var :: rest_vars -> + let rec work (vars:variable_t list) = + match vars with + | var :: rest_vars -> (* var has already a type. We have to check the dependent phis *) if done_vars#has var then work rest_vars - else + else begin done_vars#add var ; - match var_to_phi#get var with - | Some phis -> - let process_phi res phi = - match var_to_types#get phi with + match var_to_phi#get var with + | Some phis -> + let process_phi res phi = + match var_to_types#get phi with | Some _ -> phi :: res - | None -> + | None -> begin let get_vars phi = Option.get (phi_to_vars#get phi) in - match new_phi_to_vars#get phi with + match new_phi_to_vars#get phi with | Some set -> set#remove var ; - if set#isEmpty then + if set#isEmpty then begin set_phi_type phi (get_vars phi) ; phi :: res end else res - | None -> + | None -> set_phi_type phi (get_vars phi) ; phi :: res end in let work_phis = List.fold_left process_phi [] phis#toList in - work (work_phis @ rest_vars) + work (work_phis @ rest_vars) | None -> work rest_vars end - | _ -> () in + | _ -> () in work not_phis#toList ; - (* set types for phi vars in a dependency loop with other phi vars *) - let rec work_loop (phis:variable_t list) = - match phis with - | phi :: rest_phis -> + (* set types for phi vars in a dependency loop with other phi vars *) + let rec work_loop (phis:variable_t list) = + match phis with + | phi :: rest_phis -> begin - match var_to_types#get phi with - | Some _ -> work_loop rest_phis - | None -> + match var_to_types#get phi with + | Some _ -> work_loop rest_phis + | None -> let vars = Option.get (phi_to_vars#get phi) in let vars_with_types = vars#filter (fun v -> Option.is_some (var_to_types#get v)) in if vars_with_types#isEmpty then work_loop (rest_phis @ [phi]) (* postpone work on phi *) - else + else begin set_phi_type phi vars_with_types ; - work_loop rest_phis + work_loop rest_phis end end | _ -> () in work_loop new_phi_to_vars#listOfKeys ; - + let var_to_type_list = ref [] in - let add var set = + let add var set = let type_list = JCHTypeSets.get_type_list set in let has_length = List.exists is_type_with_length type_list in @@ -881,7 +879,7 @@ let get_types_from_stack_info let get_invocation_object_type (mInfo:method_info_int) (iInfo:instruction_info_int) - (num_args:int) = + (num_args:int) = let location = iInfo#get_location in let pc = location#get_pc in let pc_stack_layouts = mInfo#get_method_stack_layout#get_pc_stack_layouts in @@ -892,15 +890,15 @@ let get_invocation_object_type slot#get_type -let get_basic_type (vtypes:value_type_t list) = - let get_basic (t:value_type_t) = - match t with +let get_basic_type (vtypes:value_type_t list) = + let get_basic (t:value_type_t) = + match t with | TBasic Void -> (None, false) | TBasic Object -> (None, true) | TBasic _ -> (Some t, true) - | TObject TClass cn -> + | TObject TClass cn -> begin - match cn#name with + match cn#name with | "java.lang.Integer" -> (Some (TBasic Int) ,true) | "java.lang.Short" -> (Some (TBasic Short), true) | "java.lang.Character" -> (Some (TBasic Char), true) @@ -911,17 +909,17 @@ let get_basic_type (vtypes:value_type_t list) = | "java.math.BigInteger" -> (None, true) | "java.math.BigDecimal" -> (None, true) | _ -> (None, false) - end + end | _ -> (None, false) in - - let get_basic_t (t:value_type_t) = - match t with - | TBasic _ -> get_basic t + + let get_basic_t (t:value_type_t) = + match t with + | TBasic _ -> get_basic t | TObject TArray vt -> get_basic vt (* We do not want arrays of collections, etc *) - | TObject TClass cn -> + | TObject TClass cn -> begin - match cn#name with + match cn#name with | "java.lang.Integer" -> (Some (TBasic Int) ,true) | "java.lang.Short" -> (Some (TBasic Short), true) | "java.lang.Character" -> (Some (TBasic Char), true) @@ -930,41 +928,41 @@ let get_basic_type (vtypes:value_type_t list) = | "java.lang.Float" -> (Some (TBasic Float), true) | "java.lang.Double" -> (Some (TBasic Double), true) | "java.lang.Object" -> (None, true) - | _ -> + | _ -> if is_collection_class cn then (None, true) else (None, false) end in let add_basic_type ((basic_type_opt, is_numeric):(value_type_t option * bool)) - (vtype:value_type_t) = - let (basic_type_opt', is_numeric') = get_basic_t vtype in - let res_basic_type_opt = - match (basic_type_opt, basic_type_opt') with + (vtype:value_type_t) = + let (basic_type_opt', _is_numeric') = get_basic_t vtype in + let res_basic_type_opt = + match (basic_type_opt, basic_type_opt') with | (Some (TBasic Bool), _) -> basic_type_opt' | (Some (TBasic Byte), Some (TBasic Bool)) -> basic_type_opt | (Some (TBasic Byte), _ ) -> basic_type_opt' - | (Some (TBasic Char), Some (TBasic Bool)) + | (Some (TBasic Char), Some (TBasic Bool)) | (Some (TBasic Char), Some (TBasic Byte)) -> basic_type_opt | (Some (TBasic Char), Some (TBasic Short)) -> Some (TBasic Int) | (Some (TBasic Char), _ ) -> basic_type_opt' - | (Some (TBasic Short), Some (TBasic Bool)) + | (Some (TBasic Short), Some (TBasic Bool)) | (Some (TBasic Short), Some (TBasic Byte)) -> basic_type_opt | (Some (TBasic Short), Some (TBasic Char)) -> Some (TBasic Int) | (Some (TBasic Short), _ ) -> basic_type_opt' | (Some (TBasic Int), _) -> basic_type_opt - | (Some bt1, Some bt2) -> + | (Some bt1, Some bt2) -> if bt1 = bt2 then - Some bt1 + Some bt1 else - None - | _ -> None in - (res_basic_type_opt, is_numeric) in + None + | _ -> None in + (res_basic_type_opt, is_numeric) in - match vtypes with - | vtype :: rest_vtypes -> - List.fold_left add_basic_type (get_basic_t vtype) rest_vtypes - | [] -> (None, false) + match vtypes with + | vtype :: rest_vtypes -> + List.fold_left add_basic_type (get_basic_t vtype) rest_vtypes + | [] -> (None, false) let sub_value_type_lists (vtypes1:value_type_t list) (vtypes2:value_type_t list) = @@ -981,4 +979,3 @@ let sub_value_type_lists (fun vt2 -> List.exists (fun vt1 -> is_strict_subtype vt1 vt2) obj_vtypes1) obj_vtypes2) - diff --git a/CodeHawk/CHJ/jchsys/jCHTypeUtils.mli b/CodeHawk/CHJ/jchsys/jCHTypeUtils.mli index 92ec62ac..ab04ae86 100644 --- a/CodeHawk/CHJ/jchsys/jCHTypeUtils.mli +++ b/CodeHawk/CHJ/jchsys/jCHTypeUtils.mli @@ -5,6 +5,7 @@ The MIT License (MIT) Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/CodeHawk/CHJ/jchsys/jCHVarInfo.ml b/CodeHawk/CHJ/jchsys/jCHVarInfo.ml index b02b1a26..8e61352e 100644 --- a/CodeHawk/CHJ/jchsys/jCHVarInfo.ml +++ b/CodeHawk/CHJ/jchsys/jCHVarInfo.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -39,113 +40,111 @@ open CHPrettyUtil open JCHBasicTypes open JCHBasicTypesAPI -(* jchpre*) -open JCHPreAPI - (* jchsys *) open JCHGlobals open JCHPrintUtils -class jvar_info_t - ~(variable: variable_t) - ~(param_index: int) +class jvar_info_t + ~(variable: variable_t) + ~(param_index: int) ~(is_phi: bool) ~(origins: int list) ~(pc_in_scope: int) - ~(basic_num_vtype: value_type_t option) + ~(basic_num_vtype: value_type_t option) ~(vtypes: value_type_t list) ~(const: numerical_t option) - ~(is_numeric: bool) - ~(has_length: bool) + ~(is_numeric: bool) + ~(has_length: bool) ~(first_state: symbol_t) - ~(last_states: symbol_t list) + ~(last_states: symbol_t list) ~(read_states: symbol_t list) - ~(read_vars: variable_t list) - ~(return_pc_to_rvar : variable_t IntCollections.table_t option) - ~(origin_operations : operation_t list) + ~(read_vars: variable_t list) + ~(return_pc_to_rvar : variable_t IntCollections.table_t option) + ~(origin_operations : operation_t list) ~(local_indices : int list) = - object (self: 'a) - + object (self: 'a) + method get_variable = variable - (* first state in which the variable appears *) + (* first state in which the variable appears *) method get_first_state = first_state - - (* states after which the variable is not used anymore, so it is safe to abstract *) + + (* states after which the variable is not used anymore, so it is safe to + abstract *) method get_last_states = last_states - (* states where the variable is read *) + (* states where the variable is read *) method get_read_states = read_states - (* origin pcs sorted from large to small *) + (* origin pcs sorted from large to small *) method get_origins = origins - (* a pc where the variable is read *) + (* a pc where the variable is read *) method get_pc_in_scope = pc_in_scope - - (* the basic numeric type of arrays elements or collection elements *) + + (* the basic numeric type of arrays elements or collection elements *) method get_basic_num_type = basic_num_vtype - (* list of all possible types *) + (* list of all possible types *) method get_types = vtypes - (* if this variable is a constant it returns that constant *) + (* if this variable is a constant it returns that constant *) method get_constant = const - (* vars the variable is directly dependent on *) + (* vars the variable is directly dependent on *) method get_read_vars = read_vars - (* if the variable is a return variable, the pcs of the return and the - * rvars for that return. The return variable is only one *) + (* if the variable is a return variable, the pcs of the return and the + * rvars for that return. The return variable is only one *) method get_return_pc_to_rvar = Option.get (return_pc_to_rvar) - + method get_origin_operations = origin_operations - + method is_phi = is_phi - (* the index of the program local variables that are represented by this - * variable; a local variable can represent several local variables if - * they are the same constant or they one local variable was assigned - * another *) + (* the index of the program local variables that are represented by this + * variable; a local variable can represent several local variables if + * they are the same constant or they one local variable was assigned + * another *) method get_local_indices = local_indices - + method is_numeric = is_numeric - + val has_length = ref has_length - + method set_has_length b = has_length := b - + method has_length = !has_length - method is_parameter = + method is_parameter = param_index > -1 - method is_local_var = + method is_local_var = let name = variable#getName#getBaseName in name.[0] = 'r' && name.[1] <> 'e' && param_index = -1 - method get_param_index = + method get_param_index = if param_index > -1 then Some param_index else None method is_return = Option.is_some return_pc_to_rvar - method is_length = + method is_length = variable#getName#getBaseName = "length" val corresp_var = ref None - method set_corresp_var var = + method set_corresp_var var = corresp_var := Some var - method get_variable_from_length = - if self#is_length then - match !corresp_var with + method get_variable_from_length = + if self#is_length then + match !corresp_var with | Some var -> (Some var, true) | None -> begin let name = variable#getName in - match name#getAttributes with - | "v" :: var_name :: atts -> + match name#getAttributes with + | "v" :: var_name :: atts -> let var_name_sym = new symbol_t ~atts:atts @@ -164,15 +163,15 @@ class jvar_info_t else (None, false) val corresp_length = ref None - - method set_corresp_length (length:variable_t) = + + method set_corresp_length (length:variable_t) = corresp_length := Some length - method get_length = + method get_length = if self#has_length then match !corresp_length with | Some len -> (Some len, true) - | None -> + | None -> begin let name = variable#getName in let length_name = @@ -190,49 +189,48 @@ class jvar_info_t end else (None, false) - - method toPretty = + method toPretty = let flag_pps = ref [] in - let add_local_index i = + let add_local_index i = flag_pps := LBLOCK [STR ": local "; INT i] :: !flag_pps in - List.iter add_local_index local_indices ; - let return_pp = - match return_pc_to_rvar with - | Some table -> + List.iter add_local_index local_indices; + let return_pp = + match return_pc_to_rvar with + | Some table -> LBLOCK [STR "return offsets and the read var: "; NL; table#toPretty] - | None -> - if param_index > -1 then + | None -> + if param_index > -1 then begin - flag_pps := (STR ": parameter ") :: !flag_pps; + flag_pps := (STR ": parameter ") :: !flag_pps; STR "" end - else if is_phi then + else if is_phi then begin flag_pps := (STR ": phi variable ") :: !flag_pps; STR "" end else STR "" in - let pp_basic_num_type = + let pp_basic_num_type = if JCHSystemUtils.is_loop_counter variable then - STR "loop counter" - else + STR "loop counter" + else match basic_num_vtype with | Some t -> value_type_to_pretty t | None -> STR "unknown" in - let pp_types = + let pp_types = pretty_print_list vtypes value_type_to_pretty "{" ", " "}" in - let pp_ops = + let pp_ops = pretty_print_list origin_operations operation_to_pretty "" " " "" in - LBLOCK [NL; + LBLOCK [NL; INDENT (2, LBLOCK [variable#toPretty; - STR "(" ; INT variable#getIndex; STR ")"; + STR "("; INT variable#getIndex; STR ")"; LBLOCK !flag_pps; NL; - STR "origins: "; pp_list_int origins; NL; - STR "pc_in_scope: "; INT pc_in_scope; NL; + STR "origins: "; pp_list_int origins; NL; + STR "pc_in_scope: "; INT pc_in_scope; NL; STR "type: "; pp_types; NL; - STR "basic numeric type: "; pp_basic_num_type; NL; + STR "basic numeric type: "; pp_basic_num_type; NL; STR "constant: "; (match const with Some c -> c#toPretty | _ -> STR "no"); NL; @@ -245,193 +243,203 @@ class jvar_info_t STR "origin operations "; pp_ops; NL; STR "has_length: "; pp_bool !has_length; (if origin_operations == [] then NL else STR ""); - return_pp; NL])] - + return_pp; NL])] + end -let add_states var_to_var_to_eqs (cfg:cfg_int) = +let add_states var_to_var_to_eqs (cfg:cfg_int) = let add_states_vars - (var1:variable_t) (var2:variable_t) (states:SymbolCollections.set_t) = + (_var1: variable_t) (_var2: variable_t) (states:SymbolCollections.set_t) = let reachables = new SymbolCollections.set_t in - let rec add_to_reach (state_name:symbol_t) = + let rec add_to_reach (state_name:symbol_t) = if reachables#has state_name then () - else + else begin - reachables#add state_name ; + reachables#add state_name; let state = cfg#getState state_name in let out = state#getOutgoingEdges in List.iter add_to_reach out end in - states#iter add_to_reach ; + states#iter add_to_reach; let removed = new SymbolCollections.set_t in - let rec add_to_remove (check:bool) (state_name:symbol_t) = - let remove (state:state_int) = - removed#add state_name ; + let rec add_to_remove (check:bool) (state_name:symbol_t) = + let remove (state:state_int) = + removed#add state_name; let out = state#getOutgoingEdges in List.iter (add_to_remove false) out in if removed#has state_name || states#has state_name then () - else + else let state = cfg#getState state_name in - if check then - let incoming = state#getIncomingEdges in + if check then + let incoming = state#getIncomingEdges in if List.exists - (fun s -> not (reachables#has s) || removed#has s) incoming then + (fun s -> not (reachables#has s) || removed#has s) incoming then remove state else remove state in - reachables#iter (add_to_remove true) ; - removed#iter reachables#remove ; + reachables#iter (add_to_remove true); + removed#iter reachables#remove; states#addSet reachables in - let add_states_var (var1:variable_t) table = + let add_states_var (var1:variable_t) table = table#iter (add_states_vars var1) in - var_to_var_to_eqs#iter add_states_var ; - var_to_var_to_eqs + var_to_var_to_eqs#iter add_states_var; + var_to_var_to_eqs (* Finds all the information needed to make jvar_info_t * for all the variables of the transformed CHIF *) -(* Note: chif is not used *) let make_jvar_infos - ~(chif:system_int) ~(meth:method_int) ~(proc:procedure_int) ~(cfg:cfg_int) - ~(opcodes:opcodes_int) ~(lc_to_pc:(variable_t * int) list) ~(wto:CHSCC.wto_component_t list) ~(dom_info:JCHDominance.dominance_info_t) - ~(aliases:JCHTransformUtils.alias_sets_t) - ~(extra_assert_vars: SymbolCollections.set_t VariableCollections.table_t) = + ~(aliases:JCHTransformUtils.alias_sets_t) + ~(extra_assert_vars: SymbolCollections.set_t VariableCollections.table_t) = let proc_name = proc#getName in let all_vars = proc#getScope#getVariables in - let (origin_states, var_to_states, var_to_read_states, var_to_origins, - phi_to_vars, var_to_rvars, return_pc_to_rvar, var_ops, var_to_var_to_eqs, var_to_var_to_ineqs, - var_to_const, var_to_pcs, var_to_read_pc, local_var_index_to_pc_to_var) = + let (origin_states, + var_to_states, + var_to_read_states, + var_to_origins, + phi_to_vars, + var_to_rvars, + return_pc_to_rvar, + var_ops, + var_to_var_to_eqs, + var_to_var_to_ineqs, + var_to_const, + _var_to_pcs, + var_to_read_pc, + local_var_index_to_pc_to_var) = JCHVarInfoCollectors.collect_var_info proc meth in - let var_to_type_list = JCHTypeUtils.get_types_from_stack_info proc_name proc phi_to_vars in - let rev_dominance_info = new JCHRevDominance.rev_dominance_info_t proc_name cfg wto in + let var_to_type_list = + JCHTypeUtils.get_types_from_stack_info proc_name proc phi_to_vars in + let rev_dominance_info = + new JCHRevDominance.rev_dominance_info_t proc_name cfg wto in let var_to_first = new VariableCollections.table_t in - let set_first v = - let f = - if JCHSystemUtils.is_constant v then + let set_first v = + let f = + if JCHSystemUtils.is_constant v then method_entry_sym - else - match origin_states#get v with - | Some states_set -> + else + match origin_states#get v with + | Some states_set -> begin let states = states_set#toList in - match dom_info#find_common_dominator states with - | [state] -> - if state#getBaseName = "pc=0" then + match dom_info#find_common_dominator states with + | [state] -> + if state#getBaseName = "pc=0" then method_entry_sym - else + else state - | _ -> + | _ -> method_entry_sym end - | None -> + | None -> method_entry_sym in var_to_first#set v f in let _ = List.iter set_first all_vars in - let get_first_state (var:variable_t) = + let get_first_state (var:variable_t) = Option.get (var_to_first#get var) in - let var_to_last = new VariableCollections.table_t in + let var_to_last = new VariableCollections.table_t in let entry_state_sym = cfg#getEntry#getLabel in - let set_last v = - let l = - if JCHSystemUtils.is_constant v then + let set_last v = + let l = + if JCHSystemUtils.is_constant v then SymbolCollections.set_of_list [method_exit_sym] - else - let all_states = + else + let all_states = match (var_to_states#get v, extra_assert_vars#get v) with - | (Some states_set, Some extra_states) -> - states_set#addSet extra_states ; + | (Some states_set, Some extra_states) -> + states_set#addSet extra_states; Some states_set - | (Some states_set, _) -> Some states_set + | (Some states_set, _) -> Some states_set | (_, Some extra_states) -> Some extra_states | _ -> None in - match all_states with - | Some set -> + match all_states with + | Some set -> begin - set#remove entry_state_sym ; - set#add (get_first_state v) ; + set#remove entry_state_sym; + set#add (get_first_state v); let last_states = rev_dominance_info#find_rev_common_dominator set#toList in SymbolCollections.set_of_list last_states - end - | None -> - SymbolCollections.set_of_list [method_exit_sym] in + end + | None -> + SymbolCollections.set_of_list [method_exit_sym] in var_to_last#set v l in let _ = List.iter set_last all_vars in - let get_last_states (var:variable_t) = - match var_to_last#get var with + let get_last_states (var:variable_t) = + match var_to_last#get var with | Some states -> states#toList | None -> [method_exit_sym] in - let get_read_states (var:variable_t) = - match var_to_read_states#get var with + let get_read_states (var:variable_t) = + match var_to_read_states#get var with | Some states -> states#toList | _ -> [] in - let get_origins (var:variable_t) = - match var_to_origins#get var with + let get_origins (var:variable_t) = + match var_to_origins#get var with | Some set -> List.sort (fun l1 l2 -> compare l2 l1) set#toList | None -> [0] in - let get_read_pc (var:variable_t) = - match var_to_read_pc#get var with + let get_read_pc (var:variable_t) = + match var_to_read_pc#get var with | Some set -> if set#isEmpty then 0 else Option.get set#choose | _ -> 0 in let aliased_locals = aliases#find_aliased_locals in - let get_local_indices (var:variable_t) = + let get_local_indices (var:variable_t) = let inds = new IntCollections.set_t in - let add_index (var:variable_t) = + let add_index (var:variable_t) = let name = var#getName#getBaseName in - if name.[0] = 'r' && name.[1] <> 'e' then + if name.[0] = 'r' && name.[1] <> 'e' then inds#add (int_of_string (Str.string_after name 1)) else () in - add_index var ; + add_index var; let others = List.filter (fun (_,r) -> var#getIndex = r#getIndex) aliased_locals in let other_locals = List.map fst others in - List.iter add_index other_locals ; + List.iter add_index other_locals; List.sort compare inds#toList in - let get_types (var:variable_t) = - if List.mem_assoc var#getIndex var_to_type_list then + let get_types (var:variable_t) = + if List.mem_assoc var#getIndex var_to_type_list then List.assoc var#getIndex var_to_type_list - else - let type_list = + else + let type_list = if JCHSystemUtils.is_constant var then (* The contants are numeric *) - (TBasic Long) :: (JCHTypeUtils.make_type_list (TBasic Int2Bool)) + (TBasic Long) :: (JCHTypeUtils.make_type_list (TBasic Int2Bool)) else if JCHSystemUtils.is_temp var then (* The only temporary vars used are integers *) (JCHTypeUtils.make_type_list (TBasic Int2Bool)) - else if JCHSystemUtils.is_number var then + else if JCHSystemUtils.is_number var then (TBasic Long) :: (JCHTypeUtils.make_type_list (TBasic Int2Bool)) else [JCHTypeUtils.get_object_vt ()] in (type_list, false) in let numeric_vars = ref 0 in - (* variables that could carry numeric info such as int, long, ..., + (* variables that could carry numeric info such as int, long, ..., * java.lang.Integer, ..., java.util.Collections, ..., java.lang.Object *) let number_vars = ref 0 in (* variables that have _num suffix *) let get_basic_type vtypes = let get_basic t = - match t with + match t with | TBasic Void -> (None, false) | TBasic Object -> (None, true) | TBasic _ -> (Some t, true) - | TObject TClass cn -> + | TObject TClass cn -> begin - match cn#name with + match cn#name with | "java.lang.Integer" -> (Some (TBasic Int) ,true) | "java.lang.Short" -> (Some (TBasic Short), true) | "java.lang.Character" -> (Some (TBasic Char), true) @@ -442,17 +450,17 @@ let make_jvar_infos | "java.math.BigInteger" -> (None, true) | "java.math.BigDecimal" -> (None, true) | _ -> (None, false) - end + end | _ -> (None, false) in - + let get_basic_t t = - match t with - | TBasic _ -> get_basic t + match t with + | TBasic _ -> get_basic t | TObject TArray vt -> get_basic vt (* We do not want arrays of collections, etc *) - | TObject TClass cn -> + | TObject TClass cn -> begin - match cn#name with + match cn#name with | "java.lang.Integer" -> (Some (TBasic Int) ,true) | "java.lang.Short" -> (Some (TBasic Short), true) | "java.lang.Character" -> (Some (TBasic Char), true) @@ -461,142 +469,145 @@ let make_jvar_infos | "java.lang.Float" -> (Some (TBasic Float), true) | "java.lang.Double" -> (Some (TBasic Double), true) | "java.lang.Object" -> (None, true) - | _ -> + | _ -> if JCHTypeUtils.is_collection_class cn then (None, true) else (None, false) end in let add_basic_type (basic_type_opt, is_numeric) vtype = - let (basic_type_opt', is_numeric') = get_basic_t vtype in - let res_basic_type_opt = + let (basic_type_opt', _is_numeric') = get_basic_t vtype in + let res_basic_type_opt = match (basic_type_opt, basic_type_opt') with | (Some (TBasic Bool), _) -> basic_type_opt' | (Some (TBasic Byte), Some (TBasic Bool)) -> basic_type_opt | (Some (TBasic Byte), _ ) -> basic_type_opt' - | (Some (TBasic Char), Some (TBasic Bool)) + | (Some (TBasic Char), Some (TBasic Bool)) | (Some (TBasic Char), Some (TBasic Byte)) -> basic_type_opt | (Some (TBasic Char), Some (TBasic Short)) -> Some (TBasic Int) | (Some (TBasic Char), _ ) -> basic_type_opt' - | (Some (TBasic Short), Some (TBasic Bool)) + | (Some (TBasic Short), Some (TBasic Bool)) | (Some (TBasic Short), Some (TBasic Byte)) -> basic_type_opt | (Some (TBasic Short), Some (TBasic Char)) -> Some (TBasic Int) | (Some (TBasic Short), _ ) -> basic_type_opt' - | (Some (TBasic Int), Some (TBasic Bool)) - | (Some (TBasic Int), Some (TBasic Byte)) + | (Some (TBasic Int), Some (TBasic Bool)) + | (Some (TBasic Int), Some (TBasic Byte)) | (Some (TBasic Int), Some (TBasic Char)) -> basic_type_opt | (Some (TBasic Int), _) -> basic_type_opt' - | (Some (TBasic Long), Some (TBasic Bool)) - | (Some (TBasic Long), Some (TBasic Byte)) - | (Some (TBasic Long), Some (TBasic Char)) + | (Some (TBasic Long), Some (TBasic Bool)) + | (Some (TBasic Long), Some (TBasic Byte)) + | (Some (TBasic Long), Some (TBasic Char)) | (Some (TBasic Long), Some (TBasic Int)) -> basic_type_opt | (Some (TBasic Long), _) -> basic_type_opt' | (Some (TBasic Float), Some (TBasic Double)) -> basic_type_opt' | (Some (TBasic Float), _) -> basic_type_opt | (Some (TBasic Double), _) -> basic_type_opt - | (Some bt1, Some bt2) -> - if bt1 = bt2 then Some bt1 + | (Some bt1, Some bt2) -> + if bt1 = bt2 then Some bt1 else None | _ -> None in - (res_basic_type_opt, is_numeric) in + (res_basic_type_opt, is_numeric) in - match vtypes with - | vtype :: rest_vtypes -> - List.fold_left add_basic_type (get_basic_t vtype) rest_vtypes + match vtypes with + | vtype :: rest_vtypes -> + List.fold_left add_basic_type (get_basic_t vtype) rest_vtypes | [] -> (None, false) in let get_const var = var_to_const#get var in - (* This will work for phi variables because the other variables are - * processed first, so the var_to_types will be set for the phi variable + (* This will work for phi variables because the other variables are + * processed first, so the var_to_types will be set for the phi variable * before those types are needed *) let get_all_types (var:variable_t) = - let (vtypes, has_length) = get_types var in - if vtypes = [] then + let (vtypes, has_length) = get_types var in + if vtypes = [] then ch_error_log#add "Variables with no type " (LBLOCK [proc_name_pp proc_name; STR " no types found for "; - var#toPretty]) ; - - match var_to_const#get var with - | Some c -> + var#toPretty]); + + match var_to_const#get var with + | Some c -> if JCHTypeUtils.integer_interval#contains c then - (vtypes, Some (TBasic Int), true, false) + (vtypes, Some (TBasic Int), true, false) else (vtypes, Some (TBasic Long), true, false) - | _ -> + | _ -> begin let (basic_type_opt, is_numeric) = get_basic_type vtypes in if JCHSystemUtils.is_number var && Option.is_none (get_const var) - && Option.is_none basic_type_opt then + && Option.is_none basic_type_opt then begin - pr_debug [proc_name#toPretty; STR " numeric var without a basic type "; - var#toPretty; NL; - meth#toPretty; NL; proc#toPretty; NL] ; - raise (JCH_failure (STR "basic type expected")) - end ; - if is_numeric then incr numeric_vars ; - if JCHSystemUtils.is_number var then incr number_vars ; - if JCHSystemUtils.is_number var && not is_numeric then + pr_debug [ + proc_name#toPretty; + STR " numeric var without a basic type "; + var#toPretty; NL; + meth#toPretty; NL; + proc#toPretty; NL]; + raise (JCH_failure (STR "basic type expected")) + end; + if is_numeric then incr numeric_vars; + if JCHSystemUtils.is_number var then incr number_vars; + if JCHSystemUtils.is_number var && not is_numeric then ch_error_log#add "Numeric variable with wrong type" (LBLOCK [proc_name_pp proc_name; STR " wrong vtypes found for "; - var#toPretty]) ; + var#toPretty]); (vtypes, basic_type_opt, is_numeric, has_length) end in - let get_read_vars (var:variable_t) = - match var_to_rvars#get var with + let get_read_vars (var:variable_t) = + match var_to_rvars#get var with | Some pretty_list -> pretty_list#vars | None -> [] in let get_pc op = op.op_name#getSeqNumber in - let get_ops (var:variable_t) = + let get_ops (var:variable_t) = try let ops = List.assoc var#getIndex var_ops in let compare_op op1 op2 = compare (get_pc op1) (get_pc op2) in - List.sort compare_op ops + List.sort compare_op ops with _ -> [] in let phi_vars = phi_to_vars#listOfKeys in let phi_var_to_primary_deps = new VariableCollections.table_t in - let process_phi_var (var:variable_t) = + let process_phi_var (var:variable_t) = let vars_seen = new VariableCollections.set_t in - let primary_deps = new VariableCollections.set_t in - let rec add_deps v = + let primary_deps = new VariableCollections.set_t in + let rec add_deps v = if vars_seen#has v then () - else + else begin - vars_seen#add v ; - match phi_to_vars#get v with - | Some set -> - set#iter add_deps - | None -> - primary_deps#add v + vars_seen#add v; + match phi_to_vars#get v with + | Some set -> + set#iter add_deps + | None -> + primary_deps#add v end in - add_deps var ; + add_deps var; phi_var_to_primary_deps#set var primary_deps in - List.iter process_phi_var phi_vars ; + List.iter process_phi_var phi_vars; let var_infos = new VariableCollections.table_t in - let sig_vars = JCHSystemUtils.get_signature_vars proc in + let sig_vars = JCHSystemUtils.get_signature_vars proc in - let _ = (* parameters *) - let mk_sig_infos (i:int) (var:variable_t) = + let _ = (* parameters *) + let mk_sig_infos (i:int) (var:variable_t) = let index = var#getIndex in if index = num_return_var_index || index = sym_return_var_index then let (vtypes, basic_type_opt, is_numeric, has_length) = get_all_types var in - let info = + let info = new jvar_info_t ~variable:var ~param_index:(-1) - ~is_phi:false + ~is_phi:false ~origins:(get_origins var) - ~pc_in_scope:(get_read_pc var) + ~pc_in_scope:(get_read_pc var) ~basic_num_vtype:basic_type_opt ~vtypes ~const:(get_const var) @@ -605,20 +616,20 @@ let make_jvar_infos ~first_state:method_entry_sym ~last_states:[method_exit_sym] ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:(Some return_pc_to_rvar) - ~origin_operations:(get_ops var) + ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in begin - var_infos#set var info ; - i + var_infos#set var info; + i end - else if index = exception_var_index then - let info = + else if index = exception_var_index then + let info = new jvar_info_t ~variable:var ~param_index:(-1) - ~is_phi:false + ~is_phi:false ~origins:[0] ~pc_in_scope:0 ~basic_num_vtype:None @@ -629,21 +640,21 @@ let make_jvar_infos ~first_state:method_entry_sym ~last_states:[method_exit_sym] ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:None - ~origin_operations:(get_ops var) + ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in begin - var_infos#set var info ; + var_infos#set var info; i end - else + else let (vtypes, basic_type_opt, is_numeric, has_length) = get_all_types var in - let info = + let info = new jvar_info_t ~variable:var ~param_index:i - ~is_phi:false + ~is_phi:false ~origins:[0] ~pc_in_scope:0 ~basic_num_vtype:basic_type_opt @@ -654,28 +665,28 @@ let make_jvar_infos ~first_state:method_entry_sym ~last_states:[method_exit_sym] ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:None ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in begin - var_infos#set var info ; - succ i ; + var_infos#set var info; + succ i; end in List.fold_left mk_sig_infos 0 sig_vars in let _ = (* SSA variables *) - let mk_info var = + let mk_info var = if Option.is_some (phi_to_vars#get var) then () (* The non-phi variables need to be processed first for type info *) else if List.mem var sig_vars then - () - else if JCHSystemUtils.is_loop_counter var then - let info = + () + else if JCHSystemUtils.is_loop_counter var then + let info = new jvar_info_t ~variable:var ~param_index:(-1) - ~is_phi:false + ~is_phi:false ~origins:(get_origins var) ~pc_in_scope:(List.assoc var lc_to_pc) (* None for basic type so that is not wrapped when overflow *) @@ -683,46 +694,46 @@ let make_jvar_infos ~vtypes:[TBasic Int] ~const:None ~is_numeric:true - ~has_length:false + ~has_length:false ~first_state:(get_first_state var) ~last_states:(get_last_states var) ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:None ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in - var_infos#set var info - else if JCHSystemUtils.is_length var then - let info = + var_infos#set var info + else if JCHSystemUtils.is_length var then + let info = new jvar_info_t ~variable:var ~param_index:(-1) - ~is_phi:false + ~is_phi:false ~origins:(get_origins var) - ~pc_in_scope:(get_read_pc var) + ~pc_in_scope:(get_read_pc var) ~basic_num_vtype:(Some (TBasic Int)) ~vtypes:[TBasic Int] ~const:None ~is_numeric:true - ~has_length:false + ~has_length:false ~first_state:(get_first_state var) ~last_states:(get_last_states var) ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:None ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in - var_infos#set var info - else + var_infos#set var info + else let (vtypes, basic_type_opt, is_numeric, has_length) = get_all_types var in - let info = + let info = new jvar_info_t ~variable:var ~param_index:(-1) - ~is_phi:false + ~is_phi:false ~origins:(get_origins var) - ~pc_in_scope:(get_read_pc var) + ~pc_in_scope:(get_read_pc var) ~basic_num_vtype:basic_type_opt ~vtypes ~const:(get_const var) @@ -731,7 +742,7 @@ let make_jvar_infos ~first_state:(get_first_state var) ~last_states:(get_last_states var) ~read_states:(get_read_states var) - ~read_vars:(get_read_vars var) + ~read_vars:(get_read_vars var) ~return_pc_to_rvar:None ~origin_operations:(get_ops var) ~local_indices:(get_local_indices var) in @@ -739,21 +750,21 @@ let make_jvar_infos List.iter mk_info all_vars in let _ = (* phi variables *) - let mk_info phi_var = + let mk_info phi_var = let index = phi_var#getIndex in if index = num_return_var_index || index = sym_return_var_index - || index = exception_var_index then () - else + || index = exception_var_index then () + else let (vtypes, basic_num_type, is_numeric, has_length) = get_all_types phi_var in - let info = + let info = new jvar_info_t ~variable:phi_var ~param_index:(-1) ~is_phi:true ~origins:(get_origins phi_var) - ~pc_in_scope:(get_read_pc phi_var) + ~pc_in_scope:(get_read_pc phi_var) ~basic_num_vtype:basic_num_type ~vtypes ~const:None @@ -776,7 +787,7 @@ let make_jvar_infos info#is_phi && info#has_length) var_infos#listOfValues) in let rec work (phi_infos:jvar_info_t list) = match phi_infos with - | phi_info :: rest_phi_infos -> + | phi_info :: rest_phi_infos -> let read_vars = phi_info#get_read_vars in let new_phi_infos = ref rest_phi_infos in let check var = @@ -784,17 +795,17 @@ let make_jvar_infos | Some info -> if not info#has_length then begin - info#set_has_length true ; - if info#is_phi then new_phi_infos := info :: !new_phi_infos - end + info#set_has_length true; + if info#is_phi then new_phi_infos := info :: !new_phi_infos + end | _ -> () in begin - List.iter check read_vars ; + List.iter check read_vars; work !new_phi_infos end | [] -> () in work !phis_to_check in - + (var_infos, add_states var_to_var_to_eqs cfg, add_states var_to_var_to_ineqs cfg, @@ -806,20 +817,20 @@ let make_jvar_infos * symbolic, constants and loop_counter are not considered, and lengths * loop_counters are added / removed separately *) let make_state_to_done_num_vars - (var_infos: jvar_info_t VariableCollections.table_t) = - let state_to_vars = new SymbolCollections.table_t in - let add_var var_info = + (var_infos: jvar_info_t VariableCollections.table_t) = + let state_to_vars = new SymbolCollections.table_t in + let add_var var_info = let var = var_info#get_variable in - let add_state (state:symbol_t) = + let add_state (state:symbol_t) = if not (state = normal_exit_sym || state = method_exit_sym) then - let vars = - if var_info#has_length then - [var; Option.get (fst var_info#get_length)] + let vars = + if var_info#has_length then + [var; Option.get (fst var_info#get_length)] else [var] in match state_to_vars#get state with - | Some set -> + | Some set -> set#addList vars - | None -> + | None -> let set = VariableCollections.set_of_list vars in state_to_vars#set state set in let read_states = var_info#get_read_states in @@ -827,37 +838,37 @@ let make_state_to_done_num_vars || JCHSystemUtils.is_loop_counter var || JCHSystemUtils.is_length var || JCHSystemUtils.is_return var then - () + () else if not (var_info#is_local_var || var_info#is_parameter) && List.length read_states = 1 then add_state (List.hd read_states) else List.iter add_state (var_info#get_last_states) in begin - List.iter add_var (var_infos#listOfValues) ; + List.iter add_var (var_infos#listOfValues); state_to_vars end - + (* state -> vars that are introduced in that state *) let make_state_to_start_num_vars - (var_infos:jvar_info_t VariableCollections.table_t) = - let state_to_vars = new SymbolCollections.table_t in - let add_var var_info = + (var_infos:jvar_info_t VariableCollections.table_t) = + let state_to_vars = new SymbolCollections.table_t in + let add_var var_info = let var = var_info#get_variable in - let state = var_info#get_first_state in + let state = var_info#get_first_state in if not var_info#is_numeric || JCHSystemUtils.is_constant var || JCHSystemUtils.is_loop_counter var - || var_info#is_parameter then - () - else + || var_info#is_parameter then + () + else match state_to_vars#get state with - | Some set -> + | Some set -> set#add var - | None -> + | None -> let set = VariableCollections.set_of_list [var] in state_to_vars#set state set in begin - List.iter add_var (var_infos#listOfValues) ; + List.iter add_var (var_infos#listOfValues); state_to_vars end diff --git a/CodeHawk/CHJ/jchsys/jCHVarInfo.mli b/CodeHawk/CHJ/jchsys/jCHVarInfo.mli index 7f47d408..0e2520d8 100644 --- a/CodeHawk/CHJ/jchsys/jCHVarInfo.mli +++ b/CodeHawk/CHJ/jchsys/jCHVarInfo.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -34,8 +35,6 @@ open CHUtils (* jchlib *) open JCHBasicTypesAPI -(* jchpre *) -open JCHPreAPI class jvar_info_t : variable:variable_t @@ -45,16 +44,16 @@ class jvar_info_t : -> pc_in_scope:int -> basic_num_vtype:value_type_t option -> vtypes:value_type_t list - -> const:numerical_t option + -> const:numerical_t option -> is_numeric:bool -> has_length:bool -> first_state:symbol_t -> last_states:symbol_t list -> read_states:symbol_t list -> read_vars:variable_t list - -> return_pc_to_rvar:variable_t IntCollections.table_t option + -> return_pc_to_rvar:variable_t IntCollections.table_t option -> origin_operations:operation_t list - -> local_indices:int list + -> local_indices:int list -> object method get_variable_from_length : variable_t option * bool method get_basic_num_type : value_type_t option @@ -74,10 +73,10 @@ class jvar_info_t : method get_variable : variable_t method has_length : bool method is_length : bool - method is_local_var : bool - method is_numeric : bool - method is_parameter : bool - method is_phi : bool + method is_local_var : bool + method is_numeric : bool + method is_parameter : bool + method is_phi : bool method is_return : bool method set_has_length : bool -> unit method set_corresp_var : variable_t -> unit @@ -85,12 +84,10 @@ class jvar_info_t : method toPretty : pretty_t end -val make_jvar_infos : - chif:system_int - -> meth:method_int +val make_jvar_infos : + meth:method_int -> proc:procedure_int -> cfg:cfg_int - -> opcodes:opcodes_int -> lc_to_pc:(variable_t * int) list -> wto:CHSCC.wto_component_t list -> dom_info:JCHDominance.dominance_info_t @@ -104,7 +101,7 @@ val make_jvar_infos : * variable_t IntCollections.table_t IntCollections.table_t val make_state_to_start_num_vars : - jvar_info_t VariableCollections.table_t + jvar_info_t VariableCollections.table_t -> VariableCollections.set_t SymbolCollections.table_t val make_state_to_done_num_vars : diff --git a/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.ml b/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.ml index 430daed5..c45294d6 100644 --- a/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.ml +++ b/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.ml @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -28,12 +29,8 @@ (* chlib *) open CHLanguage open CHNumerical -open CHPretty open CHUtils -(* chutil *) -open CHPrettyUtil - (* jchlib *) open JCHBasicTypesAPI open JCHDictionary @@ -45,24 +42,23 @@ open JCHApplication open JCHGlobals open JCHPrintUtils -let dbg = ref false class pretty_op_t o = object method op = o method toPretty = operation_to_pretty o - end + end module OperationCollections = CHCollections.Make - (struct + (struct type t = operation_t let compare op1 op2 = compare op1.op_name op2.op_name - let toPretty op = operation_to_pretty op + let toPretty op = operation_to_pretty op end) -class var_info_collector_t proc meth = - object (self: _) - inherit var_collector_t as super +class var_info_collector_t proc _meth = + object (self: _) + inherit var_collector_t as super val proc_name = proc#getName val mInfo = app#get_method (retrieve_cms proc#getName#getSeqNumber) @@ -71,72 +67,72 @@ class var_info_collector_t proc meth = val var_to_states = new VariableCollections.table_t val var_to_read_states = new VariableCollections.table_t - (* for the case v1 = v2 and we do not know the type of v2 *) + (* for the case v1 = v2 and we do not know the type of v2 *) val var_to_assigned_vars : VariableCollections.set_t VariableCollections.table_t = new VariableCollections.table_t - (* var -> variables it depends on *) + (* var -> variables it depends on *) val var_to_rvars = new VariableCollections.table_t - (* return -> offset of instruction where it is set -> read var *) + (* return -> offset of instruction where it is set -> read var *) val return_pc_to_rvar = new IntCollections.table_t - (* var -> ops of origin *) + (* var -> ops of origin *) val var_to_origin_ops = new VariableCollections.table_t - (* x -> y -> ASSERT (x = y) state . Used for transmition of taint *) + (* x -> y -> ASSERT (x = y) state . Used for transmition of taint *) val var_to_var_to_eqs = new VariableCollections.table_t - (* x -> y -> ASSERT (x < y or x <= y) state . Used for transmition of taint *) + (* x -> y -> ASSERT (x < y or x <= y) state . Used for transmition of taint *) val var_to_var_to_ineqs = new VariableCollections.table_t - (* var to OpIfEq / OpIfNeq op *) + (* var to OpIfEq / OpIfNeq op *) val var_to_if_eq_op = new VariableCollections.table_t - (* var to state of OpIfEq / OpIfNe op *) + (* var to state of OpIfEq / OpIfNe op *) val var_to_if_eq_state = new VariableCollections.table_t - (* var to OpIfEq / OpIfNeq op *) + (* var to OpIfEq / OpIfNeq op *) val var_to_if_ineq_op = new VariableCollections.table_t - (* var to state of OpIfEq / OpIfNe op *) + (* var to state of OpIfEq / OpIfNe op *) val var_to_if_ineq_state = new VariableCollections.table_t - (* phi -> immediate var dependents *) + (* phi -> immediate var dependents *) val phi_to_vars = new VariableCollections.table_t - (* var to constant value *) + (* var to constant value *) val var_to_const = new VariableCollections.table_t - (* variables that are in var_to_const that are not constant *) + (* variables that are in var_to_const that are not constant *) val not_constant = new VariableCollections.set_t - (* var to pcs whete it appears *) + (* var to pcs whete it appears *) val var_to_pcs = new VariableCollections.table_t - (* var to one pc where it is read, a load if there is one *) + (* var to one pc where it is read, a load if there is one *) val var_to_read_pc = new VariableCollections.table_t - (* local variable index to load, store and iinc pcs *) - val local_var_index_to_pc_to_var = new IntCollections.table_t + (* local variable index to load, store and iinc pcs *) + val local_var_index_to_pc_to_var = new IntCollections.table_t - method get_info = + method get_info = let restr_var_to_const = new VariableCollections.table_t in - let add (var: variable_t) (const:numerical_t) = + let add (var: variable_t) (const:numerical_t) = if not (not_constant#has var) then restr_var_to_const#set var const in - var_to_const#iter add ; - let get_const name = + var_to_const#iter add; + let get_const name = let sub = Str.string_after name 2 in mkNumericalFromString sub in - let add_cNs var = + let add_cNs var = let name = var#getName#getBaseName in - if name.[0] = 'c' then + if name.[0] = 'c' then restr_var_to_const#set var (get_const name) in - List.iter add_cNs proc#getScope#getVariables ; + List.iter add_cNs proc#getScope#getVariables; let var_origin_ops = ref [] in - let add_var_origin_ops var ops = + let add_var_origin_ops var ops = var_origin_ops := (var#getIndex, ops#toList) :: !var_origin_ops in - var_to_origin_ops#iter add_var_origin_ops ; + var_to_origin_ops#iter add_var_origin_ops; (origin_states, var_to_states, var_to_read_states, @@ -146,131 +142,131 @@ class var_info_collector_t proc meth = !var_origin_ops, var_to_var_to_eqs, var_to_var_to_ineqs, - restr_var_to_const, + restr_var_to_const, var_to_pcs, var_to_read_pc, local_var_index_to_pc_to_var) val var_set = ref (new VariableCollections.set_t) val read_var_set = ref (new VariableCollections.set_t) - val cfg_opt = ref None - val current_pc = ref (-1) + val cfg_opt = ref None + val current_pc = ref (-1) val current_state = ref state_name_sym - (* used to find the type of element from the type of the array *) + (* used to find the type of element from the type of the array *) val array_to_elements = new VariableCollections.table_t - + (* used to find the type of collections from the type of its elements *) - val element_to_arrays = new VariableCollections.table_t + val element_to_arrays = new VariableCollections.table_t method private set_origin_state (v:variable_t) = - match origin_states#get v with - | Some set -> + match origin_states#get v with + | Some set -> set#add !current_state - | None -> + | None -> origin_states#set v (SymbolCollections.set_of_list [!current_state]) - method private set_origin (v:variable_t) = - self#set_origin_state v ; - if !current_pc = -1 then - current_pc := JCHSystemUtils.sym_to_pc !current_state - else () ; - match origins#get v with - | Some set -> + method private set_origin (v:variable_t) = + self#set_origin_state v; + if !current_pc = -1 then + current_pc := JCHSystemUtils.sym_to_pc !current_state + else (); + match origins#get v with + | Some set -> set#add !current_pc - | None -> + | None -> origins#set v (IntCollections.set_of_list [!current_pc]) - method private set_var_to_op (op:operation_t) (var:variable_t) = - match var_to_origin_ops#get var with - | Some set -> + method private set_var_to_op (op:operation_t) (var:variable_t) = + match var_to_origin_ops#get var with + | Some set -> set#add op | None -> - var_to_origin_ops#set var (OperationCollections.set_of_list [op]) + var_to_origin_ops#set var (OperationCollections.set_of_list [op]) - method private set_array_to_elements (array:variable_t) (element:variable_t) = - match array_to_elements#get array with + method private set_array_to_elements (array:variable_t) (element:variable_t) = + match array_to_elements#get array with | Some set -> set#add element | None -> array_to_elements#set array (VariableCollections.set_of_list [element]) - method add_phi_info (phi:variable_t) (var:variable_t) = - (match phi_to_vars#get phi with - | Some vars -> vars#add var - | None -> phi_to_vars#set phi (VariableCollections.set_of_list [var])) + method add_phi_info (phi:variable_t) (var:variable_t) = + (match phi_to_vars#get phi with + | Some vars -> vars#add var + | None -> phi_to_vars#set phi (VariableCollections.set_of_list [var])) - method private add_rvars (var:variable_t) (rvars:variable_t list) = + method private add_rvars (var:variable_t) (rvars:variable_t list) = let index = var#getIndex in - if index = num_return_var_index || index = sym_return_var_index then + if index = num_return_var_index || index = sym_return_var_index then return_pc_to_rvar#set !current_pc (List.hd rvars) - else + else let new_list = - match var_to_rvars#get var with - | Some pretty_old_list -> + match var_to_rvars#get var with + | Some pretty_old_list -> let old_list = pretty_old_list#vars in let red_rvars = List.filter (fun v -> not (List.mem v old_list)) rvars in - old_list @ red_rvars + old_list @ red_rvars | None -> rvars in var_to_rvars#set var (new pretty_var_list_t new_list) - method private add_var_to_pc (is_read:bool) (var:variable_t) = - (match var_to_pcs#get var with + method private add_var_to_pc (is_read:bool) (var:variable_t) = + (match var_to_pcs#get var with | Some pcs -> pcs#add !current_pc - | _ -> var_to_pcs#set var (IntCollections.set_of_list [!current_pc])) ; - if is_read then + | _ -> var_to_pcs#set var (IntCollections.set_of_list [!current_pc])); + if is_read then begin - match var_to_read_pc#get var with - | Some _ -> () + match var_to_read_pc#get var with + | Some _ -> () | _ -> var_to_read_pc#set var (IntCollections.set_of_list [!current_pc]) end - method private add_load_var (var:variable_t) = + method private add_load_var (var:variable_t) = var_to_read_pc#set var (IntCollections.set_of_list [!current_pc]) - method walkState (cfg:cfg_int) (state:symbol_t) = + method walkState (cfg:cfg_int) (state:symbol_t) = let name = state#getBaseName in if not (name = "normal-exit" || name = "exceptional-exit" || name = "method-exit" - || name = "loop_counter_init") then + || name = "loop_counter_init") then begin - var_set := new VariableCollections.set_t ; - read_var_set := new VariableCollections.set_t ; - current_state := state ; - current_pc := + var_set := new VariableCollections.set_t; + read_var_set := new VariableCollections.set_t; + current_state := state; + current_pc := if name = "method-initialization" then - 0 + 0 else - JCHSystemUtils.sym_to_pc state ; - super#walkCode (cfg#getState state)#getCode ; - let set_state (is_read:bool) (v:variable_t) = + JCHSystemUtils.sym_to_pc state; + super#walkCode (cfg#getState state)#getCode; + let set_state (is_read:bool) (v:variable_t) = let table = if is_read then var_to_read_states else var_to_states in - match table#get v with - | Some set -> + match table#get v with + | Some set -> set#add state - | None -> + | None -> table#set v (SymbolCollections.set_of_list [state]) in - !var_set#iter (set_state false) ; + !var_set#iter (set_state false); !read_var_set#iter (set_state true) end - + method private add_to_eq_table - (v1:variable_t) (v2:variable_t) (state_name:symbol_t) = - match var_to_var_to_eqs#get v1 with - | Some table -> + (v1:variable_t) (v2:variable_t) (state_name:symbol_t) = + match var_to_var_to_eqs#get v1 with + | Some table -> begin - match table#get v2 with + match table#get v2 with | Some set -> set#add state_name | None -> table#set v2 (SymbolCollections.set_of_list [state_name]) end - | None -> + | None -> begin let table = new VariableCollections.table_t in - table#set v2 (SymbolCollections.set_of_list [state_name]) ; - var_to_var_to_eqs#set v1 table - end + table#set v2 (SymbolCollections.set_of_list [state_name]); + var_to_var_to_eqs#set v1 table + end method private add_eq (is_eq:bool) @@ -278,11 +274,11 @@ class var_info_collector_t proc meth = (args:(string * variable_t * arg_mode_t) list) (state_name:symbol_t) = let opname_str = opname#getBaseName in - if is_eq = (opname_str = "i") then + if is_eq = (opname_str = "i") then begin let src1 = JCHSystemUtils.get_arg_var "src1" args in let src2 = JCHSystemUtils.get_arg_var "src2" args in - self#add_to_eq_table src1 src2 state_name ; + self#add_to_eq_table src1 src2 state_name; self#add_to_eq_table src2 src1 state_name end else () @@ -292,34 +288,34 @@ class var_info_collector_t proc meth = (op:operation_t) (opname:symbol_t) (args:(string * variable_t * arg_mode_t) list) - (state_name:symbol_t) = + (state_name:symbol_t) = let src = JCHSystemUtils.get_arg_var "src1" args in - match var_to_origin_ops#get src with - | Some set -> + match var_to_origin_ops#get src with + | Some set -> let ops = set#toList in - if List.length ops = 1 then + if List.length ops = 1 then begin let op = List.hd ops in match mInfo#get_opcode op.op_name#getSeqNumber with - | OpCmpL + | OpCmpL | OpCmpFL | OpCmpFG | OpCmpDL | OpCmpDG -> self#add_eq is_eq opname op.op_args state_name - | _ -> () + | _ -> () end - else () - | None -> + else () + | None -> begin - var_to_if_eq_op#set src (new pretty_op_t op) ; + var_to_if_eq_op#set src (new pretty_op_t op); (* CHANGE: there could be more than one OpIfEq with the same source ? *) - var_to_if_eq_state#set src (state_name) + var_to_if_eq_state#set src (state_name) end - method private add_cmp (iop:operation_t) (var:variable_t) = + method private add_cmp (_iop: operation_t) (var: variable_t) = (* Note: iop is not used *) (match var_to_if_eq_op#get var with - | Some pp_if_op -> + | Some pp_if_op -> let if_op = pp_if_op#op in let if_opname = if_op.op_name in let state_name = Option.get (var_to_if_eq_state#get var) in @@ -328,65 +324,65 @@ class var_info_collector_t proc meth = | OpIfEq _ -> self#add_eq2 true if_op if_opname if_op.op_args state_name | _ -> self#add_eq2 false if_op if_opname if_op.op_args state_name end - | None -> ()) ; - (match var_to_if_ineq_op#get var with - | Some pp_if_op -> + | None -> ()); + (match var_to_if_ineq_op#get var with + | Some pp_if_op -> let if_op = pp_if_op#op in let if_opname = if_op.op_name in let state_name = Option.get (var_to_if_ineq_state#get var) in begin match mInfo#get_opcode if_opname#getSeqNumber with - | OpIfLt _ + | OpIfLt _ | OpIfLe _ -> self#add_ineq2 true if_op if_opname if_op.op_args state_name | _ -> self#add_ineq2 false if_op if_opname if_op.op_args state_name end - | None -> ()) - + | None -> ()) + - method add_switch () = + method add_switch () = let cfg = Option.get (!cfg_opt) in let state = cfg#getState !current_state in - let add_state state_name = + let add_state state_name = let state : state_int = cfg#getState state_name in - let add_eq x y = - self#add_to_eq_table x y state_name ; + let add_eq x y = + self#add_to_eq_table x y state_name; self#add_to_eq_table y x state_name in - let code = state#getCode in - let rec check_cmd code i = - if i = code#length then false (* table with just default ? *) - else - begin - match code#getCmdAt i with - | ASSERT (EQ (x, y)) -> - add_eq x y ; - true - | ASSERT _ -> + let code = state#getCode in + let rec check_cmd code i = + if i = code#length then false (* table with just default ? *) + else + begin + match code#getCmdAt i with + | ASSERT (EQ (x, y)) -> + add_eq x y; + true + | ASSERT _ -> true - | TRANSACTION (_, tcode, None) -> + | TRANSACTION (_, tcode, None) -> let found = check_cmd tcode 0 in if found then true - else check_cmd code (succ i) - | _ -> check_cmd code (succ i) + else check_cmd code (succ i) + | _ -> check_cmd code (succ i) end in - let _ = check_cmd code 0 in + let _ = check_cmd code 0 in () in List.iter add_state state#getOutgoingEdges method private add_to_ineq_table - (v1:variable_t) (v2:variable_t) (state_name:symbol_t) = - match var_to_var_to_eqs#get v1 with - | Some table -> + (v1:variable_t) (v2:variable_t) (state_name:symbol_t) = + match var_to_var_to_eqs#get v1 with + | Some table -> begin - match table#get v2 with + match table#get v2 with | Some set -> set#add state_name | None -> table#set v2 (SymbolCollections.set_of_list [state_name]) end - | None -> + | None -> begin let table = new VariableCollections.table_t in - table#set v2 (SymbolCollections.set_of_list [state_name]) ; - var_to_var_to_ineqs#set v1 table - end + table#set v2 (SymbolCollections.set_of_list [state_name]); + var_to_var_to_ineqs#set v1 table + end method private add_ineq (is_lt_or_le:bool) @@ -394,11 +390,11 @@ class var_info_collector_t proc meth = (args:(string * variable_t * arg_mode_t) list) (state_name:symbol_t) = let opname_str = opname#getBaseName in - if is_lt_or_le = (opname_str = "i") then + if is_lt_or_le = (opname_str = "i") then begin let src1 = JCHSystemUtils.get_arg_var "src1" args in let src2 = JCHSystemUtils.get_arg_var "src2" args in - self#add_to_ineq_table src1 src2 state_name ; + self#add_to_ineq_table src1 src2 state_name; self#add_to_ineq_table src2 src1 state_name end else () @@ -408,205 +404,204 @@ class var_info_collector_t proc meth = (op:operation_t) (opname:symbol_t) (args:(string * variable_t * arg_mode_t) list) - (state_name:symbol_t) = + (state_name:symbol_t) = let src = JCHSystemUtils.get_arg_var "src1" args in - match var_to_origin_ops#get src with - | Some set -> + match var_to_origin_ops#get src with + | Some set -> let ops = set#toList in - if List.length ops = 1 then + if List.length ops = 1 then begin let op = List.hd ops in match mInfo#get_opcode op.op_name#getSeqNumber with - | OpCmpL + | OpCmpL | OpCmpFL | OpCmpFG | OpCmpDL | OpCmpDG -> self#add_ineq is_lt_or_le opname op.op_args state_name - | _ -> () + | _ -> () end - else () - | None -> + else () + | None -> begin - var_to_if_ineq_op#set src (new pretty_op_t op) ; + var_to_if_ineq_op#set src (new pretty_op_t op); (* CHANGE: there could be more than one OpIfEq with the same source ? *) - var_to_if_ineq_state#set src (state_name) + var_to_if_ineq_state#set src (state_name) end - val increment = ref false + val increment = ref false - method walkCmd (cmd: (code_int, cfg_int) command_t) = + method !walkCmd (cmd: (code_int, cfg_int) command_t) = match cmd with - | CFG (name, cfg) -> - cfg_opt := Some cfg ; - List.iter (self#walkState cfg) cfg#getStates - | TRANSACTION (s, _, _) -> - if s#getBaseName = "increment" then increment := true ; + | CFG (_name, cfg) -> + cfg_opt := Some cfg; + List.iter (self#walkState cfg) cfg#getStates + | TRANSACTION (s, _, _) -> + if s#getBaseName = "increment" then increment := true; super#walkCmd cmd - | ASSIGN_STRUCT (v, w) - | ASSIGN_ARRAY (v, w) - | ASSIGN_NUM (v, NUM_VAR w) -> - !var_set#addList [v; w] ; + | ASSIGN_STRUCT (v, w) + | ASSIGN_ARRAY (v, w) + | ASSIGN_NUM (v, NUM_VAR w) -> + !var_set#addList [v; w]; !read_var_set#add w; if not (JCHSystemUtils.is_length v || JCHSystemUtils.is_length w) then - self#set_origin v ; - self#add_rvars v [w] ; - self#add_var_to_pc false v ; - self#add_var_to_pc true w ; + self#set_origin v; + self#add_rvars v [w]; + self#add_var_to_pc false v; + self#add_var_to_pc true w; if not (JCHSystemUtils.is_length v || JCHSystemUtils.is_length w) then self#add_phi_info v w | ASSIGN_SYM (v, SYM_VAR w) -> - !var_set#addList [v; w] ; + !var_set#addList [v; w]; !read_var_set#add w; if w#getIndex <> exception_var_index then - self#set_origin v ; - self#add_rvars v [w] ; - self#add_var_to_pc false v ; - self#add_var_to_pc true w ; + self#set_origin v; + self#add_rvars v [w]; + self#add_var_to_pc false v; + self#add_var_to_pc true w; if w#getIndex <> exception_var_index then self#add_phi_info v w - | ASSIGN_NUM (v, NUM c) -> + | ASSIGN_NUM (v, NUM c) -> begin - !var_set#addList [v] ; - self#set_origin v ; + !var_set#addList [v]; + self#set_origin v; self#add_var_to_pc false v; - match var_to_const#get v with - | Some c' -> + match var_to_const#get v with + | Some c' -> if not (c#equal c') then not_constant#add v (* This could happen for a branching instruction *) - | _ -> var_to_const#set v c + | _ -> var_to_const#set v c end - | ASSIGN_NUM (v, PLUS (x, y)) -> - if !increment then + | ASSIGN_NUM (v, PLUS (x, y)) -> + if !increment then begin - self#add_phi_info v x ; - increment := false - end ; - !var_set#addList [v; x; y] ; + self#add_phi_info v x; + increment := false + end; + !var_set#addList [v; x; y]; !read_var_set#addList [x; y]; - self#set_origin v ; - self#add_rvars v [x; y] ; + self#set_origin v; + self#add_rvars v [x; y]; self#add_var_to_pc false v; - List.iter (self#add_var_to_pc true) [x; y] ; - | ASSIGN_NUM (v, _) + List.iter (self#add_var_to_pc true) [x; y]; + | ASSIGN_NUM (v, _) | ASSIGN_SYM (v, _) -> let vars = vars_in_cmd cmd in - !var_set#addList vars ; + !var_set#addList vars; let read_vars = List.filter (fun v' -> not (v'#equal v)) vars in !read_var_set#addList read_vars; - self#set_origin v ; + self#set_origin v; let rvars = List.filter (fun var -> var#getIndex <> v#getIndex) vars in - self#add_rvars v rvars ; + self#add_rvars v rvars; List.iter - (self#add_var_to_pc true) (List.filter (fun v' -> v#equal v') vars) ; + (self#add_var_to_pc true) (List.filter (fun v' -> v#equal v') vars); self#add_var_to_pc false v; - | INCREMENT (v, _) -> - !var_set#add v ; - !read_var_set#add v ; - self#set_origin v ; - | OPERATION op -> + | INCREMENT (v, _) -> + !var_set#add v; + !read_var_set#add v; + self#set_origin v; + | OPERATION op -> begin let opname = op.op_name in let args = op.op_args in let base_name = opname#getBaseName in - match base_name with - | "i" - | "ii" -> + match base_name with + | "i" + | "ii" -> begin - let wvars = JCHSystemUtils.get_write_vars args in + let wvars = JCHSystemUtils.get_write_vars args in let rvars = JCHSystemUtils.get_read_vars args in !var_set#addList wvars; !var_set#addList rvars; !read_var_set#addList rvars; - List.iter (self#add_var_to_pc false) wvars ; - List.iter (self#add_var_to_pc true) rvars ; - List.iter self#set_origin wvars ; - List.iter (self#set_var_to_op op) wvars ; - (if wvars = [] then () - else - List.iter (fun v -> self#add_rvars v rvars) wvars ) ; + List.iter (self#add_var_to_pc false) wvars; + List.iter (self#add_var_to_pc true) rvars; + List.iter self#set_origin wvars; + List.iter (self#set_var_to_op op) wvars; + (if wvars = [] then () + else + List.iter (fun v -> self#add_rvars v rvars) wvars ); match mInfo#get_opcode opname#getSeqNumber with - | OpIInc (n, _) -> - begin + | OpIInc (_n, _) -> + begin let var = JCHSystemUtils.get_arg_var "src_dst" args in - self#set_var_to_op op var ; + self#set_var_to_op op var; end - | OpCmpL + | OpCmpL | OpCmpFL | OpCmpFG | OpCmpDL - | OpCmpDG -> + | OpCmpDG -> let var = JCHSystemUtils.get_arg_var "dst1" args in - self#set_var_to_op op var ; - self#add_cmp op var + self#set_var_to_op op var; + self#add_cmp op var | OpAdd _ | OpSub _ | OpMult _ | OpDiv _ - | OpNeg _ -> + | OpNeg _ -> let var = JCHSystemUtils.get_arg_var "dst1" args in - self#set_var_to_op op var + self#set_var_to_op op var | OpIfCmpEq _ -> self#add_eq true opname args !current_state | OpIfCmpNe _ -> self#add_eq false opname args !current_state - | OpIfCmpLt _ + | OpIfCmpLt _ | OpIfCmpLe _ -> self#add_ineq true opname args !current_state - | OpIfCmpGt _ + | OpIfCmpGt _ | OpIfCmpGe _ -> self#add_ineq false opname args !current_state | OpIfEq _ -> self#add_eq2 true op opname args !current_state | OpIfNe _ -> self#add_eq2 false op opname args !current_state - | OpIfLt _ + | OpIfLt _ | OpIfLe _ -> self#add_ineq2 true op opname args !current_state - | OpIfGt _ + | OpIfGt _ | OpIfGe _ -> self#add_ineq2 false op opname args !current_state - | OpTableSwitch _ + | OpTableSwitch _ | OpLookupSwitch _ -> self#add_switch () - | OpLoad (_,n) -> + | OpLoad (_, _n) -> let var = JCHSystemUtils.get_arg_var "src1" args in - self#add_load_var var - | OpStore (_,n) -> + self#add_load_var var + | OpStore (_, n) -> begin let var = JCHSystemUtils.get_arg_var "dst1" args in let pc = opname#getSeqNumber in - match local_var_index_to_pc_to_var#get n with - | Some table -> table#set pc var - | _ -> + match local_var_index_to_pc_to_var#get n with + | Some table -> table#set pc var + | _ -> let table = new IntCollections.table_t in - table#set pc var ; + table#set pc var; local_var_index_to_pc_to_var#set n table end - | _ -> () + | _ -> () end | "v" -> current_pc := opname#getSeqNumber - | "init_params" -> + | "init_params" -> begin - let set_arg var = + let set_arg var = let name = var#getName#getBaseName in let index = int_of_string (Str.string_after name 1) in - match local_var_index_to_pc_to_var#get index with - | Some table -> table#set 0 var - | _ -> + match local_var_index_to_pc_to_var#get index with + | Some table -> table#set 0 var + | _ -> let table = new IntCollections.table_t in - table#set 0 var ; + table#set 0 var; local_var_index_to_pc_to_var#set index table in - List.iter set_arg (JCHSystemUtils.get_write_vars args) ; + List.iter set_arg (JCHSystemUtils.get_write_vars args); end | _ -> () - end - | ASSERT _ -> - !var_set#addList (vars_in_cmd cmd) ; - !read_var_set#addList (vars_in_cmd cmd) ; - | _ -> - super#walkCmd cmd - - method walkProcedure (proc:procedure_int) = + end + | ASSERT _ -> + !var_set#addList (vars_in_cmd cmd); + !read_var_set#addList (vars_in_cmd cmd); + | _ -> + super#walkCmd cmd + + method walkProcedure (proc:procedure_int) = self#walkCode proc#getBody end -let collect_var_info (proc:procedure_int) (meth:method_int) = +let collect_var_info (proc:procedure_int) (meth:method_int) = let collector = new var_info_collector_t proc meth in - collector#walkProcedure proc ; - collector#get_info - + collector#walkProcedure proc; + collector#get_info diff --git a/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.mli b/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.mli index cb4f15af..54b14418 100644 --- a/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.mli +++ b/CodeHawk/CHJ/jchsys/jCHVarInfoCollectors.mli @@ -3,8 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -12,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -38,15 +39,15 @@ val collect_var_info : -> method_int -> SymbolCollections.set_t VariableCollections.table_t * SymbolCollections.set_t VariableCollections.table_t - * SymbolCollections.set_t VariableCollections.table_t - * IntCollections.set_t VariableCollections.table_t + * SymbolCollections.set_t VariableCollections.table_t + * IntCollections.set_t VariableCollections.table_t * VariableCollections.set_t VariableCollections.table_t * JCHPrintUtils.pretty_var_list_t VariableCollections.table_t - * variable_t IntCollections.table_t + * variable_t IntCollections.table_t * (int * operation_t list) list - * SymbolCollections.set_t VariableCollections.table_t VariableCollections.table_t - * SymbolCollections.set_t VariableCollections.table_t VariableCollections.table_t + * SymbolCollections.set_t VariableCollections.table_t VariableCollections.table_t + * SymbolCollections.set_t VariableCollections.table_t VariableCollections.table_t * numerical_t VariableCollections.table_t - * IntCollections.set_t VariableCollections.table_t - * IntCollections.set_t VariableCollections.table_t + * IntCollections.set_t VariableCollections.table_t + * IntCollections.set_t VariableCollections.table_t * variable_t IntCollections.table_t IntCollections.table_t diff --git a/CodeHawk/CHJ/jchsys/jCHVarRepresentative.ml b/CodeHawk/CHJ/jchsys/jCHVarRepresentative.ml old mode 100755 new mode 100644 index 6422a76d..919ebec9 --- a/CodeHawk/CHJ/jchsys/jCHVarRepresentative.ml +++ b/CodeHawk/CHJ/jchsys/jCHVarRepresentative.ml @@ -1,691 +1,684 @@ -(* ============================================================================= - CodeHawk Java Analyzer - Author: Anca Browne - ------------------------------------------------------------------------------ - The MIT License (MIT) - - Copyright (c) 2005-2020 Kestrel Technology LLC - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. - ============================================================================= *) - -(* chlib *) -open CHLanguage -open CHNumerical -open CHPretty -open CHUtils - -(* chutil *) -open CHPrettyUtil - -(* jchlib *) -open JCHBasicTypes -open JCHDictionary - -(* jchpre *) -open JCHIFSystem - -(* jchsys *) -open JCHPrintUtils -open JCHGlobals -open JCHSSA - -module F = CHOnlineCodeSet.LanguageFactory - -let dbg = ref false - -class bad_phi_collector_t system procedure = - object (self: _) - inherit code_walker_t as super - - val proc_name = procedure#getName - val states = - List.map (fun s -> - s#getBaseName) (JCHSystemUtils.get_CFG procedure)#getStates - val bad_vars = new VariableCollections.set_t - val var_to_phis = new VariableCollections.table_t - val phi_to_vars = new VariableCollections.table_t - val vars_read = new VariableCollections.set_t - (* The following catches the phi assignments as well: - * read_vars_in_code procedure#getBody system *) - - method get_vars = bad_vars - - method private add_all_phis (bad_var:variable_t) = - if bad_vars#has bad_var then () - else - begin - bad_vars#add bad_var ; - match var_to_phis#get bad_var with - | Some set -> set#iter self#add_all_phis - | None -> () - end - - method add_phi_info (phi_var:variable_t) (var:variable_t) = - (match var_to_phis#get var with - | Some set -> set#add phi_var - | None -> - var_to_phis#set var (VariableCollections.set_of_list [phi_var])) ; - match phi_to_vars#get phi_var with - | Some set -> set#add var - | None -> - phi_to_vars#set phi_var (VariableCollections.set_of_list [var]) ; - - method private check_phi (phi_var:variable_t) (vars:variable_t list) = - let bad_var v = - JCHSystemUtils.is_exception v - || v#getName#getSeqNumber = -1 - || bad_vars#has v in - if List.exists bad_var vars then - self#add_all_phis phi_var - else - List.iter (self#add_phi_info phi_var) vars - - method walkCmd (cmd:(code_int, cfg_int) command_t) = - match cmd with - | CFG (_, cfg) -> - List.iter (fun s -> - self#walkCode (cfg#getState s)#getCode) cfg#getStates - | CODE (_, code) -> super#walkCode code - | OPERATION op -> - begin match op.op_name#getBaseName with - | "phi" -> - let phi_var = - List.hd (JCHSystemUtils.get_write_vars op.op_args) in - let args_in_cfg = - List.filter (fun (s,_,_) -> List.mem s states) op.op_args in - let vars = JCHSystemUtils.get_read_vars args_in_cfg in - self#check_phi phi_var vars - | _ -> - let read_vars = JCHSystemUtils.get_read_vars op.op_args in - vars_read#addList read_vars ; - super#walkCmd cmd - end - | _ -> - let collector = new read_vars_collector_t system in - collector#walkCmd cmd ; - let read_vars = collector#getVars in - vars_read#addList read_vars ; - super#walkCmd cmd - - method get_unread = - let last_phis = - VariableCollections.set_of_list phi_to_vars#listOfKeys in - last_phis#removeList var_to_phis#listOfKeys ; - let done_vars = new VariableCollections.set_t in - let rec work vars = - match vars with - | var :: rest_vars -> - if done_vars#has var then work rest_vars - else if JCHSystemUtils.is_return var || vars_read#has var then - begin - done_vars#add var ; - work rest_vars - end - else - begin - done_vars#add var ; - let vars = - match phi_to_vars#get var with - | Some vars -> vars#toList - | None -> [] in - if vars = [] then work rest_vars - else - begin - bad_vars#add var ; - let phis = - match var_to_phis#get var with - | Some set -> set#toList - | _ -> [] in - if phis = [] then - let remove_phi res v = - let set = Option.get (var_to_phis#get v) in - set#remove var ; - if set#isEmpty then v :: res - else res in - let new_last_vars = List.fold_left remove_phi [] vars in - work (new_last_vars @ rest_vars) - else work rest_vars - end - end - | _ -> () in - work last_phis#toList - method walkProcedure (proc: procedure_int) = - self#walkCode proc#getBody ; - self#get_unread ; - - end - -(* Substitutes the variables by a representative of the class of aliases. - * Eliminates the assignment between aliased variables - * Eliminates the phi operations that are not completely determined, - * that is have variables that are not assigned on some path. - * (Java does not have unassigned variables) - * It creates subst_tables for the parameters to be used by the - * cleanup transformer *) -class rep_transformer_t - (system:system_int) (aliases:JCHTransformUtils.alias_sets_t) = - object (self: _) - - inherit JCHCodeTransformers.variable_transformer_t as super - - val states = ref ([]: string list) - val new_states = ref ([]: state_int list) - - val init_cmd = ref SKIP - - val variables = new VariableCollections.set_t - - val subst_table = ref (new VariableCollections.table_t) - - val returnVar = ref None - - val cms_opt = ref None - - (* phi variable to vars it depends on before aliasing *) - val orig_phi_vars = new VariableCollections.table_t - - method get_subst_table = !subst_table - method get_return_var = !returnVar - method get_orig_phi_vars = orig_phi_vars - - method transformVar (var:variable_t) = - if JCHSystemUtils.is_exception var then - begin - variables#add exception_var; - exception_var - end - else if JCHSystemUtils.is_return var then - begin - variables#add var ; - var - end - else - let new_v = - match aliases#get_representative var with - | Some v -> v - | None -> var in - variables#add new_v ; - new_v - - method private has_no_rep (var:variable_t) = - if JCHSystemUtils.is_exception var || JCHSystemUtils.is_return var then - true - else - match aliases#get_representative var with - | Some v -> false - | None -> true - - val phi_vars_to_remove = ref (new VariableCollections.set_t) - - method transformOperation (op:operation_t) = - match op.op_name#getBaseName with - | "phi" -> - let (_,phi_var,_) = List.hd op.op_args in - if !phi_vars_to_remove#has phi_var then - SKIP - else - let changeArg (s,v,m) = (s, self#transformVar v, m) in - let reach_args = - List.filter (fun (s,_,m) -> - m = WRITE || List.mem s !states) op.op_args in - orig_phi_vars#set - phi_var - (VariableCollections.set_of_list - (List.map (fun (_,v,_) -> v) reach_args)) ; - let new_args = List.map changeArg reach_args in - OPERATION {op_name = op.op_name; op_args = new_args } - | _ -> - let changeArg (s,v,m) = (s,self#transformVar v, m) in - let new_args = List.map changeArg op.op_args in - OPERATION {op_name = op.op_name; op_args = new_args } - - val visitedStates = new SymbolCollections.set_t - - method transformState (cfg:cfg_int) (state_name:symbol_t) = - if visitedStates#has state_name then - () - else - begin - let state = cfg#getState state_name in - self#transformCode state#getCode ; - let succs = state#getOutgoingEdges in - visitedStates#add state_name; - List.iter (self#transformState cfg) succs - end - - method private add_subst_table ~(is_initial:bool) ~(code:code_int) = - let add_subst_table_cmd cmd = - match cmd with - | ASSIGN_NUM (v1, NUM_VAR v2) - | ASSIGN_SYM (v1, SYM_VAR v2) - | ASSIGN_ARRAY (v1, v2) - | ASSIGN_STRUCT (v1, v2) -> - if is_initial then - !subst_table#set v1 v2 - else - !subst_table#set v2 v1 - | _ -> () in - for i = 0 to code#length - 1 do - add_subst_table_cmd (code#getCmdAt i) - done - - method private mk_code (cmds:(code_int,cfg_int) command_t list) = - chif_system#make_code (Option.get !cms_opt) cmds - - method transformCmd cmd = - match cmd with - | CODE (sym, code) -> - self#transformCode code ; - if sym = initial_assigns_sym then - begin - self#add_subst_table ~is_initial:true ~code ; - cmd - end - else if sym = final_assigns_sym then - begin - self#add_subst_table ~is_initial:false ~code ; - cmd - end - else - cmd - | CFG (s, cfg) -> - states := List.map (fun s -> s#getBaseName) cfg#getStates ; - self#transformState cfg cfg#getEntry#getLabel ; - cmd - | ASSIGN_NUM (v, NUM_VAR v') -> - if (self#has_no_rep v) || (self#has_no_rep v') - then - ASSIGN_NUM (self#transformVar v , - NUM_VAR (self#transformVar v')) - else SKIP - | ASSIGN_NUM (v, NUM c) -> - let rep_v = self#transformVar v in - if rep_v#getName#getBaseName.[0] = 'c' then - SKIP - else - ASSIGN_NUM (rep_v, NUM c) - | ASSIGN_SYM (v,SYM_VAR v') -> - if (self#has_no_rep v) || (self#has_no_rep v') - then - ASSIGN_SYM (self#transformVar v, - SYM_VAR (self#transformVar v')) - else SKIP - | ASSIGN_STRUCT (v,v') -> - if (self#has_no_rep v) || (self#has_no_rep v') - then - ASSIGN_STRUCT (self#transformVar v, - self#transformVar v') - else SKIP - | OPERATION op -> - self#transformOperation op - | _ -> super#transformCmd cmd - - method transformProcedure (procedure: procedure_int) = - subst_table := new VariableCollections.table_t ; - cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber) ; - let scope = F.mkScope () in - let collector = (new bad_phi_collector_t system procedure) in - collector#walkProcedure procedure ; - phi_vars_to_remove := collector#get_vars ; - let body = procedure#getBody in - self#transformCode body ; - scope#addVariables variables#toList ; - returnVar := None ; - let changeBind (s, v) = - if s#getBaseName = "return" then - returnVar := Some v ; - (s, self#transformVar v) in - let bindings = List.map changeBind procedure#getBindings in - let signature = procedure#getSignature in - F.mkProcedure - procedure#getName - ~signature: signature - ~bindings: bindings - ~scope: scope - ~body: body - -end - -(* Transforms the SSA CHIF back to regular CHIF by subtituting phi - * operations with one ASSIGN for each of the previous states - * Also adds unnecessary phi_vars to subst_table *) -class phi_remover_t (subst_table:variable_t VariableCollections.table_t) = - object (self: _) - - (* Symbol and not Symbol because of get, see below *) - val assign_table = new SymbolCollections.table_t - - val cms_opt = ref None - val rev_subst_table = new VariableCollections.table_t - val var_to_phi_vars = new VariableCollections.table_t - val phi_var_to_vars = new VariableCollections.table_t - - method private mk_code (cmds:(code_int,cfg_int) command_t list) = - chif_system#make_code (Option.get !cms_opt) cmds - - method private get_rep (v:variable_t) = - match subst_table#get v with - | Some w -> w - | None -> v - - method private add_redundant_phi (phiv:variable_t) (v:variable_t) = - let check_other_phi (v':variable_t) (phiv':variable_t) = - match phi_var_to_vars#get phiv' with - | Some set -> - let reps = - let vars = new VariableCollections.set_t in - let add_rep v = vars#add (self#get_rep v) in - set#iter add_rep ; - vars in - let rep_list = reps#toList in - if List.length rep_list = 1 then - begin - phi_var_to_vars#remove phiv'; - self#add_redundant_phi phiv' (List.hd rep_list) - end - else () - | None -> () in - let rec add_to_tables (v1:variable_t) (v2:variable_t) = - let change_subst (v1:variable_t) (v2:variable_t) = - subst_table#set v1 v2 ; - (match rev_subst_table#get v2 with - | Some set -> set#add v1 - | None -> - rev_subst_table#set v2 (VariableCollections.set_of_list [v1]) ) ; - match rev_subst_table#get v1 with - | Some set -> - rev_subst_table#remove v1 ; - set#iter (fun w -> add_to_tables w v2) - | None -> () in - match subst_table#get v1 with - | Some x -> - if x#equal v2 then () - else change_subst v1 v2 - | None -> change_subst v1 v2 in - let rep = - match subst_table#get v with - | Some w -> w - | None -> v in - add_to_tables phiv rep ; - (match rev_subst_table#get phiv with - | Some set -> set#iter (fun s -> add_to_tables s rep) - | None -> ()) ; - (match var_to_phi_vars#get phiv with - | Some set -> set#iter (check_other_phi phiv) - | None -> ()) - - - method private find_redundant_phis (cfg: cfg_int) = - let find_redundant_phis_cmd (cmd:(code_int,cfg_int) command_t) = - match cmd with - | OPERATION op -> - if op.op_name#getBaseName = "phi" then - let (_, phiv, _) = List.hd op.op_args in - let read_var_reps = - let vars = new VariableCollections.set_t in - let add_arg (s,v,m) = - let rep_v = self#get_rep v in - vars#add rep_v in - List.iter add_arg (List.tl op.op_args) ; - vars in - let read_var_rep_list = read_var_reps#toList in - if List.length read_var_rep_list = 1 then - self#add_redundant_phi phiv (List.hd read_var_rep_list) - else - let add_var v = - (match var_to_phi_vars#get v with - | Some set -> set#add phiv - | None -> - var_to_phi_vars#set - v (VariableCollections.set_of_list [phiv])) ; - phi_var_to_vars#set phiv read_var_reps in - List.iter add_var read_var_rep_list - else () - | _ -> () in - let find_redundant_phis_state (state_name:symbol_t) = - let state = cfg#getState state_name in - match state#getCode#getCmdAt 0 with - | CODE (_, enter_code) -> - for i = 0 to enter_code#length - 1 do - find_redundant_phis_cmd (enter_code#getCmdAt i) - done - | _ -> raise (JCH_failure (STR "Code enter_state expected")) in - List.iter find_redundant_phis_state cfg#getStates - - method private collect_assigns (cfg: cfg_int) = - let addTable s = - assign_table#set s (new VariableCollections.table_t) in - let _ = List.iter addTable (cfg#getStates) in - let collect_assigns_cmd cmd = - match cmd with - | OPERATION op -> - if op.op_name#getBaseName = "phi" then - let (_, phiv, _) = List.hd op.op_args in - let read_var_reps = - let vars = new VariableCollections.set_t in - let add_arg (s,v,m) = - let rep_v = self#get_rep v in - vars#add rep_v in - List.iter add_arg (List.tl op.op_args) ; - vars#toList in - if List.length read_var_reps = 1 then SKIP - else - begin - let collect_assign_arg (prev, v, _) = - let prev_sym = new symbol_t prev in - match assign_table#get prev_sym with - | Some table -> table#set phiv (self#get_rep v) - (* It's possible that the state is not reachable *) - | None -> () in - List.iter collect_assign_arg (List.tl op.op_args) ; - SKIP - end - else cmd - | _ -> cmd in - let collect_assigns_state (state_name:symbol_t) = - let state = cfg#getState state_name in - match state#getCode#getCmdAt 0 with - | CODE (_, enter_code) -> - for i = 0 to enter_code#length - 1 do - let new_cmd = collect_assigns_cmd (enter_code#getCmdAt i) in - enter_code#setCmdAt i new_cmd - done - | _ -> raise (JCH_failure (STR "Code enter_state expected")) in - List.iter collect_assigns_state cfg#getStates - - method private make_assign (phiv:variable_t) (v:variable_t) = - match v#getType with - | NUM_LOOP_COUNTER_TYPE - | NUM_TMP_VAR_TYPE - | NUM_VAR_TYPE -> - ASSIGN_NUM (phiv, NUM_VAR v) - | SYM_TMP_VAR_TYPE - | SYM_VAR_TYPE -> - ASSIGN_SYM (phiv, SYM_VAR v) - | STRUCT_TYPE _ -> - ASSIGN_STRUCT (phiv, v) - | _ -> raise (JCH_failure (STR "phi removal: var types not covered")) - - method private put_assigns (cfg: cfg_int) = - let exit_cmd = OPERATION ({op_name = exit_sym; op_args = []}) in - let put_assigns_state state_name = - let state_table = Option.get (assign_table#get state_name) in - let state = cfg#getState state_name in - let state_code = state#getCode in - let new_cmds = - ref (if state#getLabel#getBaseName = "normal-exit" then [ - exit_cmd] - else - []) in - match state_code#getCmdAt (state_code#length - 1) with - | CODE (nm, exit_code) -> - let _ = - for i = exit_code#length -1 downto 0 do - new_cmds := (exit_code#getCmdAt i) :: (!new_cmds) - done in - let put_assign_var (phiv:variable_t) = - let v = Option.get (state_table#get phiv) in - new_cmds := (self#make_assign phiv v) :: (!new_cmds) in - List.iter put_assign_var state_table#listOfKeys ; - state_code#setCmdAt (state_code#length - 1) - (CODE (nm, (self#mk_code !new_cmds))) - | _ -> raise (JCH_failure (STR "CODE exit_code expected")) - in - List.iter put_assigns_state cfg#getStates - - method transformProcedure (procedure: procedure_int) = - let cfg = JCHSystemUtils.get_CFG procedure in - cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber) ; - self#find_redundant_phis cfg ; - self#collect_assigns cfg ; - self#put_assigns cfg - end - -(* Substitutes variables for parameters wherever appropriate. - * Eliminates SKIP commands, introduced OPERATIONS that are not - * needed anymore and empty CODE that is not needed *) -class cleanup_transformer_t - ~(transformed_system:system_int) - ~(subst_table:variable_t VariableCollections.table_t) - ~(returnVar:variable_t option) = - object (self: _) - - inherit JCHCodeTransformers.variable_transformer_t as super - - val readVars = ref [] - val cms_opt = ref None - - method transformVar (v:variable_t):variable_t = - match subst_table#get v with - | Some v1 -> v1 - | None -> - if v#getName#getBaseName = "return" then - let returnV = Option.get returnVar in - let _ = subst_table#set v returnV in - returnV - else - v - - method private mk_code (cmds:(code_int,cfg_int) command_t list) = - chif_system#make_code (Option.get !cms_opt) cmds - - method transform_code (code:code_int) = - let new_cmds = ref [] in - for i = 0 to code#length - 1 do - begin - let new_cmd = self#transformCmd (code#getCmdAt i) in - if new_cmd = SKIP - then () - else new_cmds := new_cmd :: (!new_cmds) - end - done ; - self#mk_code (List.rev !new_cmds) - - method transformState (cfg:cfg_int) (state_name:symbol_t) = - let state = cfg#getState state_name in - let new_code = self#transform_code state#getCode in - JCHTransformUtils.mk_state state new_code - - method transformOp - (t:variable_t) - (v1:variable_t) - {op_name = opname; op_args = opargs} = - let transformArg (s,v,m) = - if v = t then (s,v1,m) - else (s,self#transformVar v,m) in - {op_name = opname; op_args = List.map transformArg opargs } - - method transformCmd (cmd:(code_int,cfg_int) command_t) = - match cmd with - | CODE (s, code) -> - begin - match s#getBaseName with - | "initial_assigns" - | "final_assigns" -> - SKIP - | _ -> - CODE (s, self#transform_code code) - end - | CFG (s, cfg) -> - let new_states = List.map (self#transformState cfg) cfg#getStates in - let new_cfg = F.mkCFG cfg#getEntry cfg#getExit in - let _ = new_cfg#addStates new_states in - CFG (s, new_cfg) - | TRANSACTION (s, code, code_opt) -> - let new_code = self#transform_code code in - let new_code_opt = - match code_opt with - | Some c -> Some (self#transform_code c) - | None -> None in - if (Option.is_none new_code_opt) then - if new_code#length = 0 then - SKIP - else if new_code#length = 1 then - begin - new_code#getCmdAt 0 - end - else - TRANSACTION (s, new_code, None) - else - TRANSACTION (s, new_code, new_code_opt) - | RELATION code -> - RELATION (self#transform_code code) - | _ -> - let new_cmd = super#transformCmd cmd in - match new_cmd with - | ASSIGN_NUM (v1, NUM_VAR v2) - | ASSIGN_SYM (v1, SYM_VAR v2) - | ASSIGN_ARRAY (v1, v2) - | ASSIGN_STRUCT (v1, v2) -> - if v1#getIndex = v2#getIndex then - SKIP - else - new_cmd - | _ -> new_cmd - - method transformProcedure (procedure: procedure_int) = - let body = procedure#getBody in - let scope = procedure#getScope in - readVars := read_vars_in_code body transformed_system ; - cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber) ; - self#transformCode body ; - scope#removeVariables subst_table#listOfKeys ; - scope#addVariables subst_table#listOfValues ; - procedure - - end - -let reduce_to_rep - ~(system:system_int) - ~(proc:procedure_int) - ~(aliases: JCHTransformUtils.alias_sets_t) = - let rep_transformer = new rep_transformer_t system aliases in - let new_proc = rep_transformer#transformProcedure proc in - let subst_table = rep_transformer#get_subst_table in - let returnVar = rep_transformer#get_return_var in - (new phi_remover_t subst_table)#transformProcedure new_proc ; - let _ = (* cleanup also added returns to the subst table *) - (new cleanup_transformer_t - ~transformed_system:system - ~subst_table - ~returnVar)#transformProcedure new_proc in - aliases#change_representative subst_table ; - (aliases, rep_transformer#get_orig_phi_vars, new_proc) - +(* ============================================================================= + CodeHawk Java Analyzer + Author: Anca Browne + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2005-2020 Kestrel Technology LLC + Copyright (c) 2020-2025 Henny B. Sipma + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + ============================================================================= *) + +(* chlib *) +open CHLanguage +open CHPretty +open CHUtils + +(* jchlib *) +open JCHBasicTypes +open JCHDictionary + +(* jchpre *) +open JCHIFSystem + +(* jchsys *) +open JCHGlobals + +module F = CHOnlineCodeSet.LanguageFactory + + +class bad_phi_collector_t system procedure = + object (self: _) + inherit code_walker_t as super + + val proc_name = procedure#getName + val states = + List.map (fun s -> + s#getBaseName) (JCHSystemUtils.get_CFG procedure)#getStates + val bad_vars = new VariableCollections.set_t + val var_to_phis = new VariableCollections.table_t + val phi_to_vars = new VariableCollections.table_t + val vars_read = new VariableCollections.set_t + (* The following catches the phi assignments as well: + * read_vars_in_code procedure#getBody system *) + + method get_vars = bad_vars + + method private add_all_phis (bad_var:variable_t) = + if bad_vars#has bad_var then () + else + begin + bad_vars#add bad_var; + match var_to_phis#get bad_var with + | Some set -> set#iter self#add_all_phis + | None -> () + end + + method add_phi_info (phi_var:variable_t) (var:variable_t) = + (match var_to_phis#get var with + | Some set -> set#add phi_var + | None -> + var_to_phis#set var (VariableCollections.set_of_list [phi_var])); + match phi_to_vars#get phi_var with + | Some set -> set#add var + | None -> + phi_to_vars#set phi_var (VariableCollections.set_of_list [var]); + + method private check_phi (phi_var:variable_t) (vars:variable_t list) = + let bad_var v = + JCHSystemUtils.is_exception v + || v#getName#getSeqNumber = -1 + || bad_vars#has v in + if List.exists bad_var vars then + self#add_all_phis phi_var + else + List.iter (self#add_phi_info phi_var) vars + + method !walkCmd (cmd:(code_int, cfg_int) command_t) = + match cmd with + | CFG (_, cfg) -> + List.iter (fun s -> + self#walkCode (cfg#getState s)#getCode) cfg#getStates + | CODE (_, code) -> super#walkCode code + | OPERATION op -> + begin match op.op_name#getBaseName with + | "phi" -> + let phi_var = + List.hd (JCHSystemUtils.get_write_vars op.op_args) in + let args_in_cfg = + List.filter (fun (s,_,_) -> List.mem s states) op.op_args in + let vars = JCHSystemUtils.get_read_vars args_in_cfg in + self#check_phi phi_var vars + | _ -> + let read_vars = JCHSystemUtils.get_read_vars op.op_args in + vars_read#addList read_vars; + super#walkCmd cmd + end + | _ -> + let collector = new read_vars_collector_t system in + collector#walkCmd cmd; + let read_vars = collector#getVars in + vars_read#addList read_vars; + super#walkCmd cmd + + method get_unread = + let last_phis = + VariableCollections.set_of_list phi_to_vars#listOfKeys in + last_phis#removeList var_to_phis#listOfKeys; + let done_vars = new VariableCollections.set_t in + let rec work vars = + match vars with + | var :: rest_vars -> + if done_vars#has var then work rest_vars + else if JCHSystemUtils.is_return var || vars_read#has var then + begin + done_vars#add var; + work rest_vars + end + else + begin + done_vars#add var; + let vars = + match phi_to_vars#get var with + | Some vars -> vars#toList + | None -> [] in + if vars = [] then work rest_vars + else + begin + bad_vars#add var; + let phis = + match var_to_phis#get var with + | Some set -> set#toList + | _ -> [] in + if phis = [] then + let remove_phi res v = + let set = Option.get (var_to_phis#get v) in + set#remove var; + if set#isEmpty then v :: res + else res in + let new_last_vars = List.fold_left remove_phi [] vars in + work (new_last_vars @ rest_vars) + else work rest_vars + end + end + | _ -> () in + work last_phis#toList + method walkProcedure (proc: procedure_int) = + self#walkCode proc#getBody; + self#get_unread; + + end + +(* Substitutes the variables by a representative of the class of aliases. + * Eliminates the assignment between aliased variables + * Eliminates the phi operations that are not completely determined, + * that is have variables that are not assigned on some path. + * (Java does not have unassigned variables) + * It creates subst_tables for the parameters to be used by the + * cleanup transformer *) +class rep_transformer_t + (system:system_int) (aliases:JCHTransformUtils.alias_sets_t) = + object (self: _) + + inherit JCHCodeTransformers.variable_transformer_t as super + + val states = ref ([]: string list) + val new_states = ref ([]: state_int list) + + val init_cmd = ref SKIP + + val variables = new VariableCollections.set_t + + val subst_table = ref (new VariableCollections.table_t) + + val returnVar = ref None + + val cms_opt = ref None + + (* phi variable to vars it depends on before aliasing *) + val orig_phi_vars = new VariableCollections.table_t + + method get_subst_table = !subst_table + method get_return_var = !returnVar + method get_orig_phi_vars = orig_phi_vars + + method !transformVar (var:variable_t) = + if JCHSystemUtils.is_exception var then + begin + variables#add exception_var; + exception_var + end + else if JCHSystemUtils.is_return var then + begin + variables#add var; + var + end + else + let new_v = + match aliases#get_representative var with + | Some v -> v + | None -> var in + variables#add new_v; + new_v + + method private has_no_rep (var:variable_t) = + if JCHSystemUtils.is_exception var || JCHSystemUtils.is_return var then + true + else + match aliases#get_representative var with + | Some _ -> false + | None -> true + + val phi_vars_to_remove = ref (new VariableCollections.set_t) + + method transformOperation (op:operation_t) = + match op.op_name#getBaseName with + | "phi" -> + let (_,phi_var,_) = List.hd op.op_args in + if !phi_vars_to_remove#has phi_var then + SKIP + else + let changeArg (s,v,m) = (s, self#transformVar v, m) in + let reach_args = + List.filter (fun (s,_,m) -> + m = WRITE || List.mem s !states) op.op_args in + orig_phi_vars#set + phi_var + (VariableCollections.set_of_list + (List.map (fun (_,v,_) -> v) reach_args)); + let new_args = List.map changeArg reach_args in + OPERATION {op_name = op.op_name; op_args = new_args } + | _ -> + let changeArg (s,v,m) = (s,self#transformVar v, m) in + let new_args = List.map changeArg op.op_args in + OPERATION {op_name = op.op_name; op_args = new_args } + + val visitedStates = new SymbolCollections.set_t + + method transformState (cfg:cfg_int) (state_name:symbol_t) = + if visitedStates#has state_name then + () + else + begin + let state = cfg#getState state_name in + self#transformCode state#getCode; + let succs = state#getOutgoingEdges in + visitedStates#add state_name; + List.iter (self#transformState cfg) succs + end + + method private add_subst_table ~(is_initial:bool) ~(code:code_int) = + let add_subst_table_cmd cmd = + match cmd with + | ASSIGN_NUM (v1, NUM_VAR v2) + | ASSIGN_SYM (v1, SYM_VAR v2) + | ASSIGN_ARRAY (v1, v2) + | ASSIGN_STRUCT (v1, v2) -> + if is_initial then + !subst_table#set v1 v2 + else + !subst_table#set v2 v1 + | _ -> () in + for i = 0 to code#length - 1 do + add_subst_table_cmd (code#getCmdAt i) + done + + method private mk_code (cmds:(code_int,cfg_int) command_t list) = + chif_system#make_code (Option.get !cms_opt) cmds + + method !transformCmd cmd = + match cmd with + | CODE (sym, code) -> + self#transformCode code; + if sym = initial_assigns_sym then + begin + self#add_subst_table ~is_initial:true ~code; + cmd + end + else if sym = final_assigns_sym then + begin + self#add_subst_table ~is_initial:false ~code; + cmd + end + else + cmd + | CFG (_s, cfg) -> + states := List.map (fun s -> s#getBaseName) cfg#getStates; + self#transformState cfg cfg#getEntry#getLabel; + cmd + | ASSIGN_NUM (v, NUM_VAR v') -> + if (self#has_no_rep v) || (self#has_no_rep v') + then + ASSIGN_NUM (self#transformVar v , + NUM_VAR (self#transformVar v')) + else SKIP + | ASSIGN_NUM (v, NUM c) -> + let rep_v = self#transformVar v in + if rep_v#getName#getBaseName.[0] = 'c' then + SKIP + else + ASSIGN_NUM (rep_v, NUM c) + | ASSIGN_SYM (v,SYM_VAR v') -> + if (self#has_no_rep v) || (self#has_no_rep v') + then + ASSIGN_SYM (self#transformVar v, + SYM_VAR (self#transformVar v')) + else SKIP + | ASSIGN_STRUCT (v,v') -> + if (self#has_no_rep v) || (self#has_no_rep v') + then + ASSIGN_STRUCT (self#transformVar v, + self#transformVar v') + else SKIP + | OPERATION op -> + self#transformOperation op + | _ -> super#transformCmd cmd + + method !transformProcedure (procedure: procedure_int) = + subst_table := new VariableCollections.table_t; + cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber); + let scope = F.mkScope () in + let collector = (new bad_phi_collector_t system procedure) in + collector#walkProcedure procedure; + phi_vars_to_remove := collector#get_vars; + let body = procedure#getBody in + self#transformCode body; + scope#addVariables variables#toList; + returnVar := None; + let changeBind (s, v) = + if s#getBaseName = "return" then + returnVar := Some v; + (s, self#transformVar v) in + let bindings = List.map changeBind procedure#getBindings in + let signature = procedure#getSignature in + F.mkProcedure + procedure#getName + ~signature: signature + ~bindings: bindings + ~scope: scope + ~body: body + +end + +(* Transforms the SSA CHIF back to regular CHIF by subtituting phi + * operations with one ASSIGN for each of the previous states + * Also adds unnecessary phi_vars to subst_table *) +class phi_remover_t (subst_table:variable_t VariableCollections.table_t) = + object (self: _) + + (* Symbol and not Symbol because of get, see below *) + val assign_table = new SymbolCollections.table_t + + val cms_opt = ref None + val rev_subst_table = new VariableCollections.table_t + val var_to_phi_vars = new VariableCollections.table_t + val phi_var_to_vars = new VariableCollections.table_t + + method private mk_code (cmds:(code_int,cfg_int) command_t list) = + chif_system#make_code (Option.get !cms_opt) cmds + + method private get_rep (v:variable_t) = + match subst_table#get v with + | Some w -> w + | None -> v + + method private add_redundant_phi (phiv:variable_t) (v:variable_t) = + let check_other_phi (_v': variable_t) (phiv': variable_t) = + match phi_var_to_vars#get phiv' with + | Some set -> + let reps = + let vars = new VariableCollections.set_t in + let add_rep v = vars#add (self#get_rep v) in + set#iter add_rep; + vars in + let rep_list = reps#toList in + if List.length rep_list = 1 then + begin + phi_var_to_vars#remove phiv'; + self#add_redundant_phi phiv' (List.hd rep_list) + end + else () + | None -> () in + let rec add_to_tables (v1:variable_t) (v2:variable_t) = + let change_subst (v1:variable_t) (v2:variable_t) = + subst_table#set v1 v2; + (match rev_subst_table#get v2 with + | Some set -> set#add v1 + | None -> + rev_subst_table#set v2 (VariableCollections.set_of_list [v1]) ); + match rev_subst_table#get v1 with + | Some set -> + rev_subst_table#remove v1; + set#iter (fun w -> add_to_tables w v2) + | None -> () in + match subst_table#get v1 with + | Some x -> + if x#equal v2 then () + else change_subst v1 v2 + | None -> change_subst v1 v2 in + let rep = + match subst_table#get v with + | Some w -> w + | None -> v in + add_to_tables phiv rep; + (match rev_subst_table#get phiv with + | Some set -> set#iter (fun s -> add_to_tables s rep) + | None -> ()); + (match var_to_phi_vars#get phiv with + | Some set -> set#iter (check_other_phi phiv) + | None -> ()) + + + method private find_redundant_phis (cfg: cfg_int) = + let find_redundant_phis_cmd (cmd:(code_int,cfg_int) command_t) = + match cmd with + | OPERATION op -> + if op.op_name#getBaseName = "phi" then + let (_, phiv, _) = List.hd op.op_args in + let read_var_reps = + let vars = new VariableCollections.set_t in + let add_arg (_s, v, _m) = + let rep_v = self#get_rep v in + vars#add rep_v in + List.iter add_arg (List.tl op.op_args); + vars in + let read_var_rep_list = read_var_reps#toList in + if List.length read_var_rep_list = 1 then + self#add_redundant_phi phiv (List.hd read_var_rep_list) + else + let add_var v = + (match var_to_phi_vars#get v with + | Some set -> set#add phiv + | None -> + var_to_phi_vars#set + v (VariableCollections.set_of_list [phiv])); + phi_var_to_vars#set phiv read_var_reps in + List.iter add_var read_var_rep_list + else () + | _ -> () in + let find_redundant_phis_state (state_name:symbol_t) = + let state = cfg#getState state_name in + match state#getCode#getCmdAt 0 with + | CODE (_, enter_code) -> + for i = 0 to enter_code#length - 1 do + find_redundant_phis_cmd (enter_code#getCmdAt i) + done + | _ -> raise (JCH_failure (STR "Code enter_state expected")) in + List.iter find_redundant_phis_state cfg#getStates + + method private collect_assigns (cfg: cfg_int) = + let addTable s = + assign_table#set s (new VariableCollections.table_t) in + let _ = List.iter addTable (cfg#getStates) in + let collect_assigns_cmd cmd = + match cmd with + | OPERATION op -> + if op.op_name#getBaseName = "phi" then + let (_, phiv, _) = List.hd op.op_args in + let read_var_reps = + let vars = new VariableCollections.set_t in + let add_arg (_s, v, _m) = + let rep_v = self#get_rep v in + vars#add rep_v in + List.iter add_arg (List.tl op.op_args); + vars#toList in + if List.length read_var_reps = 1 then SKIP + else + begin + let collect_assign_arg (prev, v, _) = + let prev_sym = new symbol_t prev in + match assign_table#get prev_sym with + | Some table -> table#set phiv (self#get_rep v) + (* It's possible that the state is not reachable *) + | None -> () in + List.iter collect_assign_arg (List.tl op.op_args); + SKIP + end + else cmd + | _ -> cmd in + let collect_assigns_state (state_name:symbol_t) = + let state = cfg#getState state_name in + match state#getCode#getCmdAt 0 with + | CODE (_, enter_code) -> + for i = 0 to enter_code#length - 1 do + let new_cmd = collect_assigns_cmd (enter_code#getCmdAt i) in + enter_code#setCmdAt i new_cmd + done + | _ -> raise (JCH_failure (STR "Code enter_state expected")) in + List.iter collect_assigns_state cfg#getStates + + method private make_assign (phiv:variable_t) (v:variable_t) = + match v#getType with + | NUM_LOOP_COUNTER_TYPE + | NUM_TMP_VAR_TYPE + | NUM_VAR_TYPE -> + ASSIGN_NUM (phiv, NUM_VAR v) + | SYM_TMP_VAR_TYPE + | SYM_VAR_TYPE -> + ASSIGN_SYM (phiv, SYM_VAR v) + | STRUCT_TYPE _ -> + ASSIGN_STRUCT (phiv, v) + | _ -> raise (JCH_failure (STR "phi removal: var types not covered")) + + method private put_assigns (cfg: cfg_int) = + let exit_cmd = OPERATION ({op_name = exit_sym; op_args = []}) in + let put_assigns_state state_name = + let state_table = Option.get (assign_table#get state_name) in + let state = cfg#getState state_name in + let state_code = state#getCode in + let new_cmds = + ref (if state#getLabel#getBaseName = "normal-exit" then [ + exit_cmd] + else + []) in + match state_code#getCmdAt (state_code#length - 1) with + | CODE (nm, exit_code) -> + let _ = + for i = exit_code#length -1 downto 0 do + new_cmds := (exit_code#getCmdAt i) :: (!new_cmds) + done in + let put_assign_var (phiv:variable_t) = + let v = Option.get (state_table#get phiv) in + new_cmds := (self#make_assign phiv v) :: (!new_cmds) in + List.iter put_assign_var state_table#listOfKeys; + state_code#setCmdAt (state_code#length - 1) + (CODE (nm, (self#mk_code !new_cmds))) + | _ -> raise (JCH_failure (STR "CODE exit_code expected")) + in + List.iter put_assigns_state cfg#getStates + + method transformProcedure (procedure: procedure_int) = + let cfg = JCHSystemUtils.get_CFG procedure in + cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber); + self#find_redundant_phis cfg; + self#collect_assigns cfg; + self#put_assigns cfg + end + +(* Substitutes variables for parameters wherever appropriate. + * Eliminates SKIP commands, introduced OPERATIONS that are not + * needed anymore and empty CODE that is not needed *) +class cleanup_transformer_t + ~(transformed_system:system_int) + ~(subst_table:variable_t VariableCollections.table_t) + ~(returnVar:variable_t option) = + object (self: _) + + inherit JCHCodeTransformers.variable_transformer_t as super + + val readVars = ref [] + val cms_opt = ref None + + method !transformVar (v:variable_t):variable_t = + match subst_table#get v with + | Some v1 -> v1 + | None -> + if v#getName#getBaseName = "return" then + let returnV = Option.get returnVar in + let _ = subst_table#set v returnV in + returnV + else + v + + method private mk_code (cmds:(code_int,cfg_int) command_t list) = + chif_system#make_code (Option.get !cms_opt) cmds + + method transform_code (code:code_int) = + let new_cmds = ref [] in + for i = 0 to code#length - 1 do + begin + let new_cmd = self#transformCmd (code#getCmdAt i) in + if new_cmd = SKIP + then () + else new_cmds := new_cmd :: (!new_cmds) + end + done; + self#mk_code (List.rev !new_cmds) + + method transformState (cfg:cfg_int) (state_name:symbol_t) = + let state = cfg#getState state_name in + let new_code = self#transform_code state#getCode in + JCHTransformUtils.mk_state state new_code + + method transformOp + (t:variable_t) + (v1:variable_t) + {op_name = opname; op_args = opargs} = + let transformArg (s,v,m) = + if v = t then (s,v1,m) + else (s,self#transformVar v,m) in + {op_name = opname; op_args = List.map transformArg opargs } + + method !transformCmd (cmd:(code_int,cfg_int) command_t) = + match cmd with + | CODE (s, code) -> + begin + match s#getBaseName with + | "initial_assigns" + | "final_assigns" -> + SKIP + | _ -> + CODE (s, self#transform_code code) + end + | CFG (s, cfg) -> + let new_states = List.map (self#transformState cfg) cfg#getStates in + let new_cfg = F.mkCFG cfg#getEntry cfg#getExit in + let _ = new_cfg#addStates new_states in + CFG (s, new_cfg) + | TRANSACTION (s, code, code_opt) -> + let new_code = self#transform_code code in + let new_code_opt = + match code_opt with + | Some c -> Some (self#transform_code c) + | None -> None in + if (Option.is_none new_code_opt) then + if new_code#length = 0 then + SKIP + else if new_code#length = 1 then + begin + new_code#getCmdAt 0 + end + else + TRANSACTION (s, new_code, None) + else + TRANSACTION (s, new_code, new_code_opt) + | RELATION code -> + RELATION (self#transform_code code) + | _ -> + let new_cmd = super#transformCmd cmd in + match new_cmd with + | ASSIGN_NUM (v1, NUM_VAR v2) + | ASSIGN_SYM (v1, SYM_VAR v2) + | ASSIGN_ARRAY (v1, v2) + | ASSIGN_STRUCT (v1, v2) -> + if v1#getIndex = v2#getIndex then + SKIP + else + new_cmd + | _ -> new_cmd + + method !transformProcedure (procedure: procedure_int) = + let body = procedure#getBody in + let scope = procedure#getScope in + readVars := read_vars_in_code body transformed_system; + cms_opt := Some (retrieve_cms procedure#getName#getSeqNumber); + self#transformCode body; + scope#removeVariables subst_table#listOfKeys; + scope#addVariables subst_table#listOfValues; + procedure + + end + +let reduce_to_rep + ~(system:system_int) + ~(proc:procedure_int) + ~(aliases: JCHTransformUtils.alias_sets_t) = + let rep_transformer = new rep_transformer_t system aliases in + let new_proc = rep_transformer#transformProcedure proc in + let subst_table = rep_transformer#get_subst_table in + let returnVar = rep_transformer#get_return_var in + (new phi_remover_t subst_table)#transformProcedure new_proc; + let _ = (* cleanup also added returns to the subst table *) + (new cleanup_transformer_t + ~transformed_system:system + ~subst_table + ~returnVar)#transformProcedure new_proc in + aliases#change_representative subst_table; + (aliases, rep_transformer#get_orig_phi_vars, new_proc) diff --git a/CodeHawk/CHJ/jchsys/jCHVarRepresentative.mli b/CodeHawk/CHJ/jchsys/jCHVarRepresentative.mli index 9c1f2bea..3093b83a 100644 --- a/CodeHawk/CHJ/jchsys/jCHVarRepresentative.mli +++ b/CodeHawk/CHJ/jchsys/jCHVarRepresentative.mli @@ -3,9 +3,9 @@ Author: Anca Browne ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC - Copyright (c) 2020-2023 Henny Sipma + Copyright (c) 2020-2025 Henny B. Sipma Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -13,10 +13,10 @@ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -30,11 +30,10 @@ open CHLanguage open CHUtils -val reduce_to_rep : +val reduce_to_rep : system:system_int -> proc:procedure_int - -> aliases:JCHTransformUtils.alias_sets_t + -> aliases:JCHTransformUtils.alias_sets_t -> JCHTransformUtils.alias_sets_t * VariableCollections.set_t VariableCollections.table_t - * procedure_int - + * procedure_int