diff --git a/CodeHawk/CHB/bchanalyze/bCHAnalyzeApp.ml b/CodeHawk/CHB/bchanalyze/bCHAnalyzeApp.ml index fbadfb82..636f45f6 100644 --- a/CodeHawk/CHB/bchanalyze/bCHAnalyzeApp.ml +++ b/CodeHawk/CHB/bchanalyze/bCHAnalyzeApp.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020 Henny Sipma - Copyright (c) 2021-2024 Aarno Labs LLC + Copyright (c) 2021-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 @@ -184,7 +184,12 @@ let analyze starttime = faddr#toPretty; STR ": "; p]); - failedfunctions := faddr :: !failedfunctions + if system_settings#fail_on_function_failure then + raise + (BCH_failure + (LBLOCK [STR "Function failure of "; faddr#toPretty; STR ": "; p])) + else + failedfunctions := faddr :: !failedfunctions end in begin @@ -414,7 +419,12 @@ let analyze_mips starttime = faddr#toPretty; STR ": "; p]); - failedfunctions := faddr :: !failedfunctions + if system_settings#fail_on_function_failure then + raise + (BCH_failure + (LBLOCK [STR "Function failure of "; faddr#toPretty; STR "; "; p])) + else + failedfunctions := faddr :: !failedfunctions end in begin (if (List.length fns_included) > 0 then @@ -566,7 +576,12 @@ let analyze_arm starttime = faddr#toPretty; STR ": "; p]); - failedfunctions := faddr :: !failedfunctions + if system_settings#fail_on_function_failure then + raise + (BCH_failure + (LBLOCK [STR "Function failure of "; faddr#toPretty; STR ": "; p])) + else + failedfunctions := faddr :: !failedfunctions end in begin (if (List.length fns_included) > 0 then @@ -606,9 +621,11 @@ let analyze_arm starttime = pr_interval_timing [STR "functions analyzed: "; INT !count] 60.0 with | Failure s -> functionfailure "Failure" faddr (STR s) - | Invalid_argument s -> functionfailure "Invalid argument" faddr (STR s) + | Invalid_argument s -> + functionfailure "Invalid argument" faddr (STR s) | Internal_error s -> functionfailure "Internal error" faddr (STR s) - | Invocation_error s -> functionfailure "Invocation error" faddr (STR s) + | Invocation_error s -> + functionfailure "Invocation error" faddr (STR s) | CHFailure p -> functionfailure "CHFailure" faddr p | BCH_failure p -> functionfailure "BCHFailure" faddr p)); file_metrics#record_runtime ((Unix.gettimeofday ()) -. starttime) diff --git a/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml b/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml index 51ca4bb9..99bca230 100644 --- a/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml +++ b/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml @@ -119,11 +119,14 @@ let show_chif = ref None let set_chif s = show_chif := Some s let speclist = - [ ("-version", Arg.Unit (fun () -> ()), "show version information and exit") ; + [ ("-version", Arg.Unit (fun () -> ()), "show version information and exit"); ("-gc", Arg.Unit (fun () -> cmd := "gc"), - "show ocaml garbage collector settings and exit") ; + "show ocaml garbage collector settings and exit"); + ("-fail_on_function_failure", + Arg.Unit (fun () -> system_settings#set_fail_on_function_failure), + "fail immediately if analysis of one of the functions fails"); ("-set_vftables",Arg.Unit (fun () -> system_settings#set_vftables), - "declare jumptable targets as funcion entry points") ; + "declare jumptable targets as funcion entry points"); ("-extracthex", Arg.Unit (fun () -> cmd := "extracthex"), "extract executable content from lisphex encoded executable"); ("-ssa", Arg.Unit (fun () -> system_settings#set_ssa), @@ -878,6 +881,7 @@ let main () = (* function annotations in userdata should be loaded after the header files are parsed, so types in the function annotations can be resolved.*) let _ = system_info#initialize_function_annotations in + let _ = pr_timing [STR "function annotations initialized"] in let index = file_metrics#get_index in let logcmd = "analyze_" ^ (string_of_int index) in diff --git a/CodeHawk/CHB/bchlib/bCHFunctionData.ml b/CodeHawk/CHB/bchlib/bCHFunctionData.ml index 5c8fa929..009125c0 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionData.ml +++ b/CodeHawk/CHB/bchlib/bCHFunctionData.ml @@ -738,87 +738,85 @@ let read_xml_function_annotation (node: xml_element_int) = let faddr = get "faddr" in TR.titer ~ok:(fun dw -> - if functions_data#has_function dw then - let fndata = functions_data#get_function dw in - let stackvintros = - if hasc "stackvar-intros" then - let svintros = getc "stackvar-intros" in - List.fold_left - (fun acc n -> - TR.tfold - ~ok:(fun svi -> svi :: acc) - ~error:(fun e -> - begin - log_error_result __FILE__ __LINE__ e; - acc - end) - (read_xml_stackvar_intro n)) - [] - (svintros#getTaggedChildren "vintro") - else - [] in - let regvintros = - if hasc "regvar-intros" then - let rvintros = getc "regvar-intros" in - List.fold_left - (fun acc n -> - TR.tfold - ~ok:(fun rvi -> rvi :: acc) - ~error:(fun e -> - begin - log_error_result __FILE__ __LINE__ e; - acc - end) - (read_xml_regvar_intro n)) - [] - (rvintros#getTaggedChildren "vintro") - else - [] in - let typingrules = - if hasc "typing-rules" then - let trules = getc "typing-rules" in - List.fold_left - (fun acc n -> - TR.tfold - ~ok:(fun tr -> tr :: acc) - ~error:(fun e -> - begin - log_error_result __FILE__ __LINE__ e; - acc - end) - (read_xml_typing_rule n)) - [] - (trules#getTaggedChildren "typingrule") - else - [] in - let rdefspecs = - if hasc "remove-rdefs" then - let rrds = getc "remove-rdefs" in - List.fold_left - (fun acc n -> - TR.tfold - ~ok:(fun rds -> rds :: acc) - ~error:(fun e -> - begin - log_error_result __FILE__ __LINE__ e; - acc - end) - (read_xml_reachingdef_spec n)) - [] - (rrds#getTaggedChildren "remove-var-rdefs") - else - [] in - fndata#set_function_annotation - {regvarintros = regvintros; - stackvarintros = stackvintros; - typingrules = typingrules; - reachingdefspecs = rdefspecs - } - else - log_error_result - ~tag:"function annotation faddr not found" - __FILE__ __LINE__ - ["Function annotation address: " ^ faddr ^ " not known"]) + let fndata = + if functions_data#has_function dw then + functions_data#get_function dw + else + functions_data#add_function dw in + let stackvintros = + if hasc "stackvar-intros" then + let svintros = getc "stackvar-intros" in + List.fold_left + (fun acc n -> + TR.tfold + ~ok:(fun svi -> svi :: acc) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + acc + end) + (read_xml_stackvar_intro n)) + [] + (svintros#getTaggedChildren "vintro") + else + [] in + let regvintros = + if hasc "regvar-intros" then + let rvintros = getc "regvar-intros" in + List.fold_left + (fun acc n -> + TR.tfold + ~ok:(fun rvi -> rvi :: acc) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + acc + end) + (read_xml_regvar_intro n)) + [] + (rvintros#getTaggedChildren "vintro") + else + [] in + let typingrules = + if hasc "typing-rules" then + let trules = getc "typing-rules" in + List.fold_left + (fun acc n -> + TR.tfold + ~ok:(fun tr -> tr :: acc) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + acc + end) + (read_xml_typing_rule n)) + [] + (trules#getTaggedChildren "typingrule") + else + [] in + let rdefspecs = + if hasc "remove-rdefs" then + let rrds = getc "remove-rdefs" in + List.fold_left + (fun acc n -> + TR.tfold + ~ok:(fun rds -> rds :: acc) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + acc + end) + (read_xml_reachingdef_spec n)) + [] + (rrds#getTaggedChildren "remove-var-rdefs") + else + [] in + fndata#set_function_annotation + {regvarintros = regvintros; + stackvarintros = stackvintros; + typingrules = typingrules; + reachingdefspecs = rdefspecs + }) ~error:(fun e -> log_error_result __FILE__ __LINE__ e) (string_to_doubleword faddr) diff --git a/CodeHawk/CHB/bchlib/bCHFunctionStackframe.ml b/CodeHawk/CHB/bchlib/bCHFunctionStackframe.ml index 832918bd..01921aeb 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionStackframe.ml +++ b/CodeHawk/CHB/bchlib/bCHFunctionStackframe.ml @@ -471,7 +471,20 @@ object (self) if (H.find stackslots offset)#is_spill then () else - raise (BCH_failure (LBLOCK [STR "Stackslot already taken"])) + let sslot = H.find stackslots offset in + raise + (BCH_failure + (LBLOCK [ + STR "Add register spill at address "; + STR iaddr; + STR " for register "; + STR (register_to_string reg); + STR " at offset "; + INT offset; + STR " cannot be completed, because another stackslot "; + STR "at this offset, with name: "; + STR sslot#name; + STR " already exists"])) else let ssrec = { sslot_name = (register_to_string reg) ^ "_spill"; @@ -494,7 +507,20 @@ object (self) if (H.find stackslots offset)#is_spill then () else - raise (BCH_failure (LBLOCK [STR "Stackslot already taken"])) + let sslot = H.find stackslots offset in + raise + (BCH_failure + (LBLOCK [ + STR "Add register restore at address "; + STR iaddr; + STR " for register "; + STR (register_to_string reg); + STR " at offset "; + INT offset; + STR " cannot be completed, because another stackslot "; + STR "at this offset, with name: "; + STR sslot#name; + STR " already exists"])) else let ssrec = { sslot_name = (register_to_string reg) ^ "_spill"; diff --git a/CodeHawk/CHB/bchlib/bCHLibTypes.mli b/CodeHawk/CHB/bchlib/bCHLibTypes.mli index ac3a46e2..30d2be74 100644 --- a/CodeHawk/CHB/bchlib/bCHLibTypes.mli +++ b/CodeHawk/CHB/bchlib/bCHLibTypes.mli @@ -1417,6 +1417,7 @@ object method enable_sideeffects_on_globals : string list -> unit method disable_sideeffects_on_globals: string list -> unit method set_no_varinvs: unit + method set_fail_on_function_failure: unit method set_abstract_stackvars_disabled: unit method set_apps_dir: string -> unit method set_app_summary_jars: string -> unit (* application name *) @@ -1451,6 +1452,7 @@ object method has_thumb: bool method use_ssa: bool method collect_data: bool + method fail_on_function_failure: bool method generate_varinvs: bool method include_arm_extension_registers: bool method show_function_timing: bool diff --git a/CodeHawk/CHB/bchlib/bCHSystemSettings.ml b/CodeHawk/CHB/bchlib/bCHSystemSettings.ml index f4e7c3ad..98b9ebdc 100644 --- a/CodeHawk/CHB/bchlib/bCHSystemSettings.ml +++ b/CodeHawk/CHB/bchlib/bCHSystemSettings.ml @@ -181,9 +181,14 @@ object (self) val mutable ssa = false val mutable collectdata = false val mutable generate_varinvs = true + val mutable fail_on_function_failure = false method set_collect_data = collectdata <- true + method set_fail_on_function_failure = fail_on_function_failure <- true + + method fail_on_function_failure = fail_on_function_failure + method set_no_varinvs = generate_varinvs <- false method collect_data = collectdata diff --git a/CodeHawk/CHB/bchlib/bCHVersion.ml b/CodeHawk/CHB/bchlib/bCHVersion.ml index 610ce036..7166e281 100644 --- a/CodeHawk/CHB/bchlib/bCHVersion.ml +++ b/CodeHawk/CHB/bchlib/bCHVersion.ml @@ -95,8 +95,8 @@ end let version = new version_info_t - ~version:"0.6.0_20250811" - ~date:"2025-08-11" + ~version:"0.6.0_20250812" + ~date:"2025-08-12" ~licensee: None ~maxfilesize: None ()