diff --git a/.github/workflows/dune.yaml b/.github/workflows/dune.yaml index ee993159..99797757 100644 --- a/.github/workflows/dune.yaml +++ b/.github/workflows/dune.yaml @@ -31,7 +31,7 @@ jobs: - name: Prepare tar file for upload run: tar -hcvf artifacts.tar CodeHawk/_build/install/default/bin/* - name: Upload artifacts tar file - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} path: artifacts.tar @@ -54,7 +54,7 @@ jobs: - name: Delete submitted prebuilts run: rm -f chb/bin/binaries/linux/chx86_analyze - name: Download artifacts tar - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} - name: Extract artifacts @@ -84,7 +84,7 @@ jobs: rm -f chc/bin/linux/parseFile rm -f chc/bin/linux/canalyzer - name: Download artifacts tar - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} - name: Extract artifacts diff --git a/.github/workflows/makefiles.yaml b/.github/workflows/makefiles.yaml index 0c74c23f..dca59e03 100644 --- a/.github/workflows/makefiles.yaml +++ b/.github/workflows/makefiles.yaml @@ -24,7 +24,7 @@ jobs: - name: Prepare tar file for upload run: tar -cvf artifacts.tar CodeHawk/CHB/bchcmdline/chx86_analyze CodeHawk/CHC/cchcil/parseFile CodeHawk/CHC/cchcmdline/canalyzer - name: Upload artifacts tar file - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} path: artifacts.tar @@ -45,7 +45,7 @@ jobs: - name: Delete submitted prebuilts run: rm -f chb/bin/binaries/linux/chx86_analyze - name: Download artifacts tar - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} - name: Extract artifacts @@ -73,7 +73,7 @@ jobs: rm -f chc/bin/linux/parseFile rm -f chc/bin/linux/canalyzer - name: Download artifacts tar - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: artifacts-${{ matrix.ocaml-compiler }} - name: Extract artifacts diff --git a/CodeHawk/CH/chutil/cHLogger.ml b/CodeHawk/CH/chutil/cHLogger.ml index 434e9400..82daa9ed 100644 --- a/CodeHawk/CH/chutil/cHLogger.ml +++ b/CodeHawk/CH/chutil/cHLogger.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -226,3 +226,29 @@ let log_tfold_default log_tracelog_error logspec e; d end + + +let log_error_result + ?(msg="") + ?(tag="") + (filename: string) + (linenumber: int) + (error: string list) = + let tag = if tag = "" then tag else tag ^ ":" in + let msg = if msg = "" then msg else msg ^ ": " in + ch_error_log#add + (tag ^ filename ^ ":" ^ (string_of_int linenumber)) + (LBLOCK [STR msg; STR (String.concat "; " error)]) + + +let log_result + ?(msg="") + ?(tag="") + (filename: string) + (linenumber: int) + (error: string list) = + let tag = if tag = "" then tag else tag ^ ":" in + let msg = if msg = "" then msg else msg ^ ":" in + chlog#add + (tag ^ filename ^ ":" ^ (string_of_int linenumber)) + (LBLOCK [STR msg; STR (String.concat "; " error)]) diff --git a/CodeHawk/CH/chutil/cHLogger.mli b/CodeHawk/CH/chutil/cHLogger.mli index 5f21b22f..d6878066 100644 --- a/CodeHawk/CH/chutil/cHLogger.mli +++ b/CodeHawk/CH/chutil/cHLogger.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020-2021 Henny B. Sipma - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -112,3 +112,19 @@ val log_tfold: [e] is logged according [tls].*) val log_tfold_default: tracelogspec_t -> ('a -> 'c) -> 'c -> 'a traceresult -> 'c + + +(** [log_error_result msg tag filename linenumber error] writes an entry to + [ch_error_log] with a tag that combines [tag], [filename], and [linenumber]. + The entry is the concatenation of [msg] and the list of error messages + making up [error].*) +val log_error_result: + ?msg:string -> ?tag:string -> string -> int -> string list -> unit + + +(** [log_result msg tag filename linenumber error] writes an entry to + [chlog] with a tag that combines [tag], [filename], and [linenumber]. + The entry is the concatenation of [msg] and the list of error messages + making up [error].*) +val log_result: + ?msg:string -> ?tag:string -> string -> int -> string list -> unit diff --git a/CodeHawk/CH/chutil/cHTraceResult.ml b/CodeHawk/CH/chutil/cHTraceResult.ml index 218b29f3..541faf5f 100644 --- a/CodeHawk/CH/chutil/cHTraceResult.ml +++ b/CodeHawk/CH/chutil/cHTraceResult.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2023-2024 Aarno Labs LLC + Copyright (c) 2023-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 @@ -61,6 +61,25 @@ let tmap2 | Error e1, Error e2 -> Error (msg1 :: msg2 :: (e1 @ e2)) +let tmap3 + ?(msg1="") + ?(msg2="") + ?(msg3="") + (f: 'a -> 'b -> 'c -> 'd) + (r1: 'a traceresult) + (r2: 'b traceresult) + (r3: 'c traceresult): 'd traceresult = + match r1, r2, r3 with + | Ok v1, Ok v2, Ok v3 -> Ok (f v1 v2 v3) + | Error e1, Ok _, Ok _ -> Error (msg1 :: e1) + | Ok _, Error e2, Ok _ -> Error (msg2 :: e2) + | Ok _, Ok _, Error e3 -> Error (msg3 :: e3) + | Error e1, Error e2, Ok _ -> Error (msg1 :: msg2 :: (e1 @ e2)) + | Error e1, Ok _, Error e3 -> Error (msg1 :: msg3 :: (e1 @ e3)) + | Ok _, Error e2, Error e3 -> Error (msg2 :: msg3 :: (e2 @ e3)) + | Error e1, Error e2, Error e3 -> Error (msg1 :: msg2 :: msg3 :: (e1 @ e2 @ e3)) + + let tbind ?(msg="") (f: 'a -> 'c traceresult) (r: 'a traceresult) = match r with | Ok v -> f v @@ -86,7 +105,13 @@ let tprop (r: 'a traceresult) (msg: string): 'a traceresult = | Error e -> Error (msg :: e) -let titer (f: 'a -> unit) (r: 'a traceresult) = +let titer ~(ok:'a -> unit) ~(error: string list -> unit) (r: 'a traceresult) = + match r with + | Ok v -> ok v + | Error e -> error e + + +let titer_default (f: 'a -> unit) (r: 'a traceresult) = match r with | Ok v -> f v | Error _ -> () diff --git a/CodeHawk/CH/chutil/cHTraceResult.mli b/CodeHawk/CH/chutil/cHTraceResult.mli index 7b6ef8be..49dd40a0 100644 --- a/CodeHawk/CH/chutil/cHTraceResult.mli +++ b/CodeHawk/CH/chutil/cHTraceResult.mli @@ -65,6 +65,20 @@ val tmap2: -> 'c traceresult +(** [tmap3 f r1 r2 r3] is [Ok (f v1 v2 v3)] if [r1] is [Ok v1] and [r2] is + [Ok v2] and [r3] is [Ok v3]; otherwise it returns an [Error] appending + the messages corresponding to the error value as appropriate.*) +val tmap3: + ?msg1:string + -> ?msg2:string + -> ?msg3:string + -> ('a -> 'b -> 'c -> 'd) + -> 'a traceresult + -> 'b traceresult + -> 'c traceresult + -> 'd traceresult + + (** [tfold ~ok ~error r] is [ok v] if [r] is [Ok v] and [error e] if [r] is [Error e].*) val tfold: ok:('a -> 'c) -> error:(string list -> 'c) -> 'a traceresult -> 'c @@ -86,8 +100,13 @@ val tbind: ?msg:string -> ('a -> 'c traceresult) -> ('a traceresult) -> 'c traceresult -(** [titer f r] is [f v] if [r] is [Ok v] and [()] otherwise.*) -val titer: ('a -> unit) -> ('a traceresult) -> unit +(** [titer ~ok ~error r] is [ok v] if [r] is [Ok v] and [error e] if [r] is + [Error e].*) +val titer: ok:('a -> unit) -> error:(string list -> unit) -> ('a traceresult) -> unit + + +(** [titer_default f r] is [f v] if [r] is [Ok v] and [()] otherwise.*) +val titer_default: ('a -> unit) -> 'a traceresult -> unit (** [tfold_list ~ok init rl] folds [Ok] values left to right, starting from diff --git a/CodeHawk/CHB/bchanalyze/bCHFileIO.ml b/CodeHawk/CHB/bchanalyze/bCHFileIO.ml index 5ec422d5..c9bc0b8c 100644 --- a/CodeHawk/CHB/bchanalyze/bCHFileIO.ml +++ b/CodeHawk/CHB/bchanalyze/bCHFileIO.ml @@ -200,6 +200,19 @@ let save_global_state () = file_output#saveFile filename doc#toPretty end + +let save_global_memory_map () = + let filename = get_global_memory_map_filename () in + let doc = xmlDocument () in + let root = get_bch_root "global-locations" in + let gNode = xmlElement "global-locations" in + begin + BCHGlobalMemoryMap.global_memory_map#write_xml gNode; + doc#setNode root; + root#appendChildren [gNode]; + file_output#saveFile filename doc#toPretty + end + let save_system_info () = let filename = get_system_info_filename () in let doc = xmlDocument () in diff --git a/CodeHawk/CHB/bchanalyze/bCHFileIO.mli b/CodeHawk/CHB/bchanalyze/bCHFileIO.mli index 2e4b867e..9511e6c7 100644 --- a/CodeHawk/CHB/bchanalyze/bCHFileIO.mli +++ b/CodeHawk/CHB/bchanalyze/bCHFileIO.mli @@ -43,6 +43,7 @@ val save_functions_list: unit -> unit val save_arm_functions_list: unit -> unit val save_global_state: unit -> unit +val save_global_memory_map: unit -> unit val save_system_info: unit -> unit val save_resultmetrics: xml_element_int -> unit val save_disassembly_status: unit -> unit diff --git a/CodeHawk/CHB/bchanalyze/bCHTrace.ml b/CodeHawk/CHB/bchanalyze/bCHTrace.ml index 3930b53f..889bbadc 100644 --- a/CodeHawk/CHB/bchanalyze/bCHTrace.ml +++ b/CodeHawk/CHB/bchanalyze/bCHTrace.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 @@ -76,10 +76,13 @@ let se_address_is_referenced if floc#is_address x then let (memref,memoffset) = floc#decompose_address x in if is_constant_offset memoffset then - let memv = - finfo#env#mk_memory_variable memref (get_total_constant_offset memoffset) in - let memx = floc#rewrite_variable_to_external memv in - var_is_referenced finfo memx v + TR.tfold_default + (fun offset -> + let memv = finfo#env#mk_memory_variable memref offset in + let memx = floc#rewrite_variable_to_external memv in + var_is_referenced finfo memx v) + false + (get_total_constant_offset memoffset) else false else diff --git a/CodeHawk/CHB/bchcil/bCHParseCilFile.ml b/CodeHawk/CHB/bchcil/bCHParseCilFile.ml index eeb46546..37b7ee6d 100644 --- a/CodeHawk/CHB/bchcil/bCHParseCilFile.ml +++ b/CodeHawk/CHB/bchcil/bCHParseCilFile.ml @@ -38,30 +38,25 @@ open CHLogger (* bchlib *) open BCHBCFiles open BCHBCTypes -open BCHBCTypePretty open BCHBCTypeUtil open BCHCilToCBasic -open BCHConstantDefinitions let update_symbolic_address_types () = - let globalvarnames = get_untyped_symbolic_address_names () in - begin - List.iter (fun name -> - if bcfiles#has_varinfo name then - let vinfo = bcfiles#get_varinfo name in - begin - update_symbolic_address_btype name vinfo.bvtype; - chlog#add - "symbolic address: update with vinfo" - (LBLOCK [STR name; STR ": "; STR (btype_to_string vinfo.bvtype)]) - end - else - chlog#add "symbolic address: no update" (STR name)) globalvarnames; - chlog#add - "symbolic address updates" - (LBLOCK [STR "Names: "; STR (String.concat ", " globalvarnames)]) - end + let gfunnames = bcfiles#get_gfun_names in + let varinfos = bcfiles#get_varinfos in + List.iter + (fun vinfo -> + if List.mem vinfo.bvname gfunnames then + () + else + match BCHGlobalMemoryMap.update_global_location_type vinfo with + | Error e -> + ch_error_log#add + "update-global-location-type" + (LBLOCK [ + STR "varinfo: "; STR vinfo.bvname; STR (String.concat "; " e)]) + | _ -> ()) varinfos let parse_cil_file ?(computeCFG=true) ?(removeUnused=true) (filename: string) = diff --git a/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml b/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml index 6018c7c8..f46f564c 100644 --- a/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml +++ b/CodeHawk/CHB/bchcmdline/bCHXBinaryAnalyzer.ml @@ -537,7 +537,9 @@ let main () = let t = ref (Unix.gettimeofday ()) in let _ = load_elf_files () in let _ = pr_timing [STR "elf files loaded"] in - let _ = List.iter parse_cil_file system_info#ifiles in + let _ = + List.iter (fun f -> + parse_cil_file ~removeUnused:false f) system_info#ifiles in let _ = if (List.length system_info#ifiles) > 0 then pr_timing [STR "c header files loaded"] in @@ -600,6 +602,8 @@ let main () = pr_timing [STR "system_info saved"]; save_arm_dictionary (); pr_timing [STR "dictionary saved"]; + save_global_memory_map (); + pr_timing [STR "global-locations saved"]; save_interface_dictionary (); pr_timing [STR "interface dictionary saved"]; save_bcdictionary (); @@ -843,8 +847,6 @@ let main () = let _ = pr_timing [STR "bdictionary loaded"] in let _ = load_bc_files () in let _ = pr_timing [STR "bc files loaded"] in - let _ = system_info#initialize in - let _ = pr_timing [STR "system info initialized"] in let _ = load_interface_dictionary () in let _ = pr_timing [STR "interface dictionary loaded"] in let _ = load_arm_dictionary () in @@ -859,12 +861,21 @@ let main () = STR ")"] in let _ = load_elf_files () in let _ = pr_timing [STR "elf files loaded"] in + + (* symbolic addresses in userdata should be loaded before the header + files are parsed. *) + let _ = system_info#initialize in + let _ = pr_timing [STR "system info initialized"] in let _ = List.iter (fun f -> parse_cil_file ~removeUnused:false f) system_info#ifiles in let _ = if (List.length system_info#ifiles > 0) then pr_timing [STR "c header files parsed"] in + (* 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 index = file_metrics#get_index in let logcmd = "analyze_" ^ (string_of_int index) in let analysisstart = Unix.gettimeofday () in @@ -896,6 +907,8 @@ let main () = (* save_arm_assembly_instructions (); *) save_arm_dictionary (); pr_timing [STR "arm dictionary saved"]; + save_global_memory_map (); + pr_timing [STR "global-locations saved"]; save_bc_files (); pr_timing [STR "bc files saved"]; save_interface_dictionary (); diff --git a/CodeHawk/CHB/bchcmdline/bCHXInspectSummaries.ml b/CodeHawk/CHB/bchcmdline/bCHXInspectSummaries.ml index 7038d24b..721b7caf 100644 --- a/CodeHawk/CHB/bchcmdline/bCHXInspectSummaries.ml +++ b/CodeHawk/CHB/bchcmdline/bCHXInspectSummaries.ml @@ -38,7 +38,6 @@ open CHLogger (* bchlib *) open BCHBasicTypes -open BCHConstantDefinitions open BCHFunctionSummaryLibrary open BCHLibTypes open BCHSystemInfo @@ -126,7 +125,7 @@ let print_statistics () = STR "Type definitions: "; NL; type_definitions#toPretty; NL; STR "IO action categories: "; INT (List.length pActions); NL; STR "Parameter roles : "; INT nParamRoles; NL; - constant_statistics_to_pretty (); NL] + BCHConstantDefinitions.constant_statistics_to_pretty (); NL] end let main () = diff --git a/CodeHawk/CHB/bchlib/Makefile b/CodeHawk/CHB/bchlib/Makefile index 2f7f3510..9540d089 100644 --- a/CodeHawk/CHB/bchlib/Makefile +++ b/CodeHawk/CHB/bchlib/Makefile @@ -60,6 +60,7 @@ MLIS := \ bCHFunctionData \ bCHSystemData \ bCHConstantDefinitions \ + bCHGlobalMemoryMap \ bCHStructTables \ bCHCallbackTables \ bCHImmediate \ @@ -153,6 +154,7 @@ SOURCES := \ bCHCodegraph \ bCHSystemData \ bCHConstantDefinitions \ + bCHGlobalMemoryMap \ bCHStructTables \ bCHCallbackTables \ bCHImmediate \ diff --git a/CodeHawk/CHB/bchlib/bCHBCDictionary.ml b/CodeHawk/CHB/bchlib/bCHBCDictionary.ml index 4937c612..e8446b45 100644 --- a/CodeHawk/CHB/bchlib/bCHBCDictionary.ml +++ b/CodeHawk/CHB/bchlib/bCHBCDictionary.ml @@ -432,8 +432,8 @@ object (self) let r = List.mapi (fun i (name, typ, attrs) -> let name = - if name = "" then "$par$" ^ (string_of_int (i+1)) else name in - (name,typ,attrs)) r in + if name = "" then "x" ^ (string_of_int (i+1)) else name in + (name, typ, attrs)) r in funargs_table#add ([], List.map self#index_funarg r) method get_funargs (index: int): bfunarg_t list = diff --git a/CodeHawk/CHB/bchlib/bCHBCFiles.ml b/CodeHawk/CHB/bchlib/bCHBCFiles.ml index a2119544..f2e60711 100644 --- a/CodeHawk/CHB/bchlib/bCHBCFiles.ml +++ b/CodeHawk/CHB/bchlib/bCHBCFiles.ml @@ -70,6 +70,7 @@ object (self) method add_bcfile (f: bcfile_t) = let i = bcd#index_location in + begin List.iter (fun g -> match g with | GType (tinfo, loc) -> @@ -92,8 +93,10 @@ object (self) | GEnumTagDecl (einfo, loc) -> H.replace genumtagdecls einfo.bename (bcd#index_enuminfo einfo, i loc) | GVarDecl (vinfo, loc) -> + let _ = chlog#add "bcfiles:add gvardecl" (STR vinfo.bvname) in H.replace gvardecls vinfo.bvname (bcd#index_varinfo vinfo, i loc) | GVar (vinfo, iinfo, loc) -> + let _ = chlog#add "bcfiles:add gvar" (STR vinfo.bvname) in H.replace gvars vinfo.bvname (bcd#index_varinfo vinfo, @@ -102,8 +105,20 @@ object (self) | _ -> (-1)), i loc) | GFun (fundec, loc) -> + let _ = chlog#add "bcfiles:add gfun" (STR fundec.bsvar.bvname) in H.replace gfuns fundec.bsvar.bvname (fundec, bcd#index_location loc); - | _ -> ()) f.bglobals + | _ -> ()) f.bglobals; + chlog#add + "bcfiles:add_bcfile" + (LBLOCK [ + STR "gvars: "; + INT (H.length gvars); + STR "; gvardecls: "; + INT (H.length gvardecls); + STR "; gfuns: "; + INT (H.length gfuns) + ]) + end method update_global (g: bglobal_t) = let i = bcd#index_location in @@ -316,10 +331,40 @@ object (self) (BCH_failure (LBLOCK [STR "No enuminfo found with name "; STR name])) - method has_varinfo (name: string) = - (H.mem gvars name) || (H.mem gvardecls name) - - method get_varinfo (name: string) = + method private get_prefixed_name (name: string): bvarinfo_t option = + let declnames = H.fold (fun k _ a -> k :: a) gvardecls [] in + let gvarnames = H.fold (fun k _ a -> k :: a) gvars [] in + let namelen = String.length name in + let result = + List.fold_left (fun result n -> + match result with + | Some _ -> result + | _ -> + if String.length n > namelen && (String.sub n 0 namelen) = name then + let (ix, _) = H.find gvardecls n in + Some ix + else + None) None declnames in + let result = + List.fold_left (fun result n -> + match result with + | Some _ -> result + | _ -> + if String.length n > namelen && (String.sub n 0 namelen) = name then + let (ix, _, _) = H.find gvars n in + Some ix + else + None) result gvarnames in + match result with + | Some ix -> Some (bcd#get_varinfo ix) + | _ -> None + + method has_varinfo ?(prefix=false) (name: string) = + (H.mem gvars name) + || (H.mem gvardecls name) + || (prefix && (Option.is_some (self#get_prefixed_name name))) + + method get_varinfo ?(prefix=false) (name: string): bvarinfo_t = if self#has_varinfo name then let ix = if H.mem gvars name then @@ -328,11 +373,28 @@ object (self) let (ix, _) = H.find gvardecls name in ix in bcd#get_varinfo ix + else if prefix then + match self#get_prefixed_name name with + | Some vinfo -> vinfo + | _ -> + raise + (BCH_failure + (LBLOCK [STR "No varinfo found with prefixed name "; STR name])) else raise (BCH_failure (LBLOCK [STR "No varinfo found with name "; STR name])) + method get_varinfos = + let result = ref [] in + begin + H.iter (fun _ (ix, _, _) -> + result := (bcd#get_varinfo ix) :: !result) gvars; + H.iter (fun _ (ix, _) -> + result := (bcd#get_varinfo ix) :: !result) gvardecls; + !result + end + method list_varinfos = let result = ref [] in let v2s v = v.bvname ^ ": " ^ (btype_to_string v.bvtype) in diff --git a/CodeHawk/CHB/bchlib/bCHBCTypeUtil.ml b/CodeHawk/CHB/bchlib/bCHBCTypeUtil.ml index 76454372..d49d67fe 100644 --- a/CodeHawk/CHB/bchlib/bCHBCTypeUtil.ml +++ b/CodeHawk/CHB/bchlib/bCHBCTypeUtil.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -148,6 +148,48 @@ let t_vararg_function (returntype:btype_t) (args:bfunarg_t list) = let t_function_anon (returntype:btype_t) = TFun (returntype, None, false, []) +(* =========================================================== string -> type *) + +let convert_string_to_type (name: string): btype_t traceresult = + match name with + | "char" -> Ok (TInt (IChar, [])) + | "signed char" -> Ok (TInt (ISChar, [])) + | "unsigned char" -> Ok (TInt (IUChar, [])) + | "wchar_t" -> Ok (TInt (IWChar, [])) + | "bool" -> Ok (TInt (IBool, [])) + | "int" -> Ok (TInt (IInt, [])) + | "unsigned int" -> Ok (TInt (IUInt, [])) + | "short" -> Ok (TInt (IShort, [])) + | "unsigned short" -> Ok (TInt (IUShort, [])) + | "long" -> Ok (TInt (ILong, [])) + | "unsigned long" -> Ok (TInt (IULong, [])) + | "long long" -> Ok (TInt (ILongLong, [])) + | "unsigned long long" -> Ok (TInt (IULongLong, [])) + | "int8_t" -> Ok (TInt (ISChar, [])) + | "uint8_t" -> Ok (TInt (IUChar, [])) + | "int16_t" -> Ok (TInt (IShort, [])) + | "uint16_t" -> Ok (TInt (IUShort, [])) + | "int32_t" -> Ok (TInt (IInt, [])) + | "uint32_t" -> Ok (TInt (IUInt, [])) + | "int64_t" -> Ok (TInt (ILongLong, [])) + | "uint64_t" -> Ok (TInt (IULongLong, [])) + | "int128_t" -> Ok (TInt (IInt128, [])) + | "uint128_t" -> Ok (TInt (IUInt128, [])) + | "float" -> Ok (TFloat (FFloat, FScalar, [])) + | "double" -> Ok (TFloat (FDouble, FScalar, [])) + | "long double" -> Ok (TFloat (FLongDouble, FScalar, [])) + | "complex" -> Ok (TFloat (FComplexFloat, FScalar, [])) + | "double complex" -> Ok (TFloat (FComplexDouble, FScalar, [])) + | "long double complex" -> Ok (TFloat (FComplexLongDouble, FScalar, [])) + | "void" -> Ok (TVoid []) + | _ -> + if bcfiles#has_typedef name then + Ok (bcfiles#get_typedef name) + else + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "unable to convert type name " ^ name] + (* =============================================================== attributes *) let get_attributes (t: btype_t): b_attributes_t = @@ -1109,6 +1151,17 @@ let get_struct_field_at_offset end +let is_sub_struct (ckey1: int) (ckey2: int) = + let cinfo2 = get_compinfo_by_key ckey2 in + let field0 = get_struct_field_at_offset cinfo2 0 in + match field0 with + | Some (bfinfo, 0) -> + (match bfinfo.bftype with + | TComp (i, _) -> ckey1 = i + | _ -> false) + | _ -> false + + let rec get_compinfo_scalar_type_at_offset (cinfo: bcompinfo_t) (offset: int): btype_t option = let finfos = cinfo.bcfields in @@ -1231,3 +1284,8 @@ let struct_offset_field_categories (ty: btype_t): (int * string) list = STR "Struct definition has no field layout: "; STR (btype_to_string ty)]))) compinfo.bcfields | _ -> [(0, btype_to_string ty)] + + +let bexp_intconstant ?(ikind=IInt) (n: int) = + let i64 = Int64.of_int n in + Const (CInt (i64, ikind, None)) diff --git a/CodeHawk/CHB/bchlib/bCHBCTypeUtil.mli b/CodeHawk/CHB/bchlib/bCHBCTypeUtil.mli index 9eabfabc..22ec5506 100644 --- a/CodeHawk/CHB/bchlib/bCHBCTypeUtil.mli +++ b/CodeHawk/CHB/bchlib/bCHBCTypeUtil.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -126,6 +126,17 @@ val t_vararg_function: btype_t -> bfunarg_t list -> btype_t val t_function_anon: btype_t -> btype_t (* arguments not known *) +(** {1 Types from strings} *) + +(** [convert_string_to_type name] attempts to convert [name] into a [btype_t]. + Valid names include the standard names for the integer and float types, + as well as typedef names. + + If [name] is not a standard type name or typedef name, an Error is returned. + *) +val convert_string_to_type: string -> btype_t traceresult + + (** {1 Type predicates}*) val is_void: btype_t -> bool @@ -256,6 +267,10 @@ val get_compinfo_scalar_type_at_offset: bcompinfo_t -> int -> btype_t option val get_compinfo_by_key: int -> bcompinfo_t +(** [is_sub_struct ckey1 ckey2] returns [true] if the first field (at offset 0) + of the struct with key [ckey2] is a struct with key [ckey1].*) +val is_sub_struct: int -> int -> bool + (** {2 Fieldinfos}*) @@ -295,3 +310,10 @@ val struct_field_categories: btype_t -> string list If [ty] is not a struct it returns the regular string representation of [ty] with offset 0.*) val struct_offset_field_categories: btype_t -> (int * string) list + + +(** {1 Bexpressions} *) + +(** {2 Constants} *) + +val bexp_intconstant: ?ikind:ikind_t -> int -> bexp_t diff --git a/CodeHawk/CHB/bchlib/bCHBCTypes.mli b/CodeHawk/CHB/bchlib/bCHBCTypes.mli index 088761e1..73a6b66c 100644 --- a/CodeHawk/CHB/bchlib/bCHBCTypes.mli +++ b/CodeHawk/CHB/bchlib/bCHBCTypes.mli @@ -592,12 +592,15 @@ class type bcfiles_int = (** [get_varinfo name] returns the varinfo with name [name]. @raise BCH_failure if no varinfo exists with name [name].*) - method get_varinfo: string -> bvarinfo_t + method get_varinfo: ?prefix:bool -> string -> bvarinfo_t + + (** Returns all global varinfos (including functions) *) + method get_varinfos: bvarinfo_t list (** [has_varinfo name] returns true if there exists either a defined or declared variable with name [name]. Note that this includes function names.*) - method has_varinfo: string -> bool + method has_varinfo: ?prefix:bool -> string -> bool method list_varinfos: string list diff --git a/CodeHawk/CHB/bchlib/bCHDataBlock.ml b/CodeHawk/CHB/bchlib/bCHDataBlock.ml index d5195a8f..7d8669d9 100644 --- a/CodeHawk/CHB/bchlib/bCHDataBlock.ml +++ b/CodeHawk/CHB/bchlib/bCHDataBlock.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -372,7 +372,7 @@ let find_seh4_structures_in_section (base:doubleword_int) (section:string) = let dw = ch#read_doubleword in if dw#equal wordzero then (* GSCookieXOROffset *) let startAddr = base#add_int (ch#pos - 8) in - TR.titer + TR.titer_default (fun db -> if db#get_length > 16 then structs := db :: !structs) diff --git a/CodeHawk/CHB/bchlib/bCHDoubleword.ml b/CodeHawk/CHB/bchlib/bCHDoubleword.ml index 73a1a500..d76c01c5 100644 --- a/CodeHawk/CHB/bchlib/bCHDoubleword.ml +++ b/CodeHawk/CHB/bchlib/bCHDoubleword.ml @@ -488,6 +488,11 @@ let numerical_to_doubleword (num:numerical_t): doubleword_result = "numerical_to_doubleword" +let numerical_mod_to_doubleword (num: numerical_t): doubleword_int = + let num = num#modulo numerical_e32 in + TR.tget_ok (numerical_to_doubleword num) + + let dw_index_to_int (index:dw_index_t) = index diff --git a/CodeHawk/CHB/bchlib/bCHDoubleword.mli b/CodeHawk/CHB/bchlib/bCHDoubleword.mli index bbd075f6..9b390c33 100644 --- a/CodeHawk/CHB/bchlib/bCHDoubleword.mli +++ b/CodeHawk/CHB/bchlib/bCHDoubleword.mli @@ -109,7 +109,7 @@ val big_int_to_doubleword: big_int -> doubleword_result val string_to_doubleword: string -> doubleword_result -(**[numerical_to_doubleword num] converts num to a doubleword. +(**[numerical_to_doubleword num] converts [num] to a doubleword. [num] must be less than [2^32] and greater than or equal [-2^31]. Negative numbers are represented by their two's complement @@ -118,6 +118,11 @@ val string_to_doubleword: string -> doubleword_result val numerical_to_doubleword: numerical_t -> doubleword_result +(** [numerical_mod_to_doubleword num] converts [num] to a a doubleword. + [num] will be forced within the range [0..2^32-1] using wraparound.*) +val numerical_mod_to_doubleword: numerical_t -> doubleword_int + + (** [numerical_to_hex_string num] converts num to a hexadecimal string representation via a doubleword representation. diff --git a/CodeHawk/CHB/bchlib/bCHFloc.ml b/CodeHawk/CHB/bchlib/bCHFloc.ml index 40d246ab..552aff60 100644 --- a/CodeHawk/CHB/bchlib/bCHFloc.ml +++ b/CodeHawk/CHB/bchlib/bCHFloc.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 @@ -93,6 +93,8 @@ let x2s x = p2s (x2p x) let log_error (tag: string) (msg: string): tracelogspec_t = mk_tracelog_spec ~tag:("floc:" ^ tag) msg +let memmap = BCHGlobalMemoryMap.global_memory_map + let unknown_write_symbol = new symbol_t "unknown write" @@ -401,16 +403,6 @@ object (self) method memrecorder = mk_memory_recorder self#f self#cia - (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * - * return values * - * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) - - method record_return_value = - let eax = self#env#mk_cpu_register_variable Eax in - let returnExpr = self#rewrite_variable_to_external eax in - self#f#record_return_value self#cia returnExpr - - (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * * call targets * * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) @@ -599,22 +591,10 @@ object (self) let fintf = ctinfo#get_function_interface in let stackpars = get_stack_parameters fintf in let regpars = get_register_parameters fintf in - let _ = - chlog#add - "floc:get_call_arguments" - (LBLOCK [ - self#l#toPretty; - STR " "; - STR ctinfo#get_name; - STR ": "; - INT (List.length stackpars); - STR " stackparameters; "; - INT (List.length regpars); - STR " register parameters"]) in - List.concat [(get_regargs regpars); (get_stackargs stackpars)] method get_call_args = + (* used in x86 only *) let ctinfo = self#get_call_target in if ctinfo#is_wrapped_app_call then self#get_wrapped_call_args @@ -653,11 +633,82 @@ object (self) * resolve and save IndReg (cpureg, offset) (memrefs1) * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) + method get_memory_variable_numoffset + ?(align=1) + ?(size=4) + (var: variable_t) + (numoffset: numerical_t): variable_t traceresult = + let inv = self#inv in + let mk_memvar memref_r memoffset_r = + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memref -> + if memref#is_global_reference then + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) + ^ ": memref:global") + (fun memoff -> + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + self#env#mk_global_variable + (get_total_constant_offset memoff)) + memoffset_r + else + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memoff -> + (self#env#mk_offset_memory_variable memref memoff)) + memoffset_r) + memref_r in + + if inv#is_base_offset_constant var then + let (base, offset) = inv#get_base_offset_constant var in + let memoffset = numoffset#add offset in + let memref_r = self#env#mk_base_sym_reference base in + let memoff_r = + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun basevar -> + let optbasetype = self#env#get_variable_type basevar in + let basetype = + match optbasetype with + | Some t when is_pointer t -> ptr_deref t + | _ -> t_unknown in + address_memory_offset basetype (num_constant_expr memoffset)) + (self#env#get_variable base#getSeqNumber) in + mk_memvar memref_r memoff_r + + else + let varx = + if align > 1 then + let alignx = int_constant_expr align in + XOp (XMult, [XOp (XDiv, [XVar var; alignx]); alignx]) + else + XVar var in + let addr = XOp (XPlus, [varx; num_constant_expr numoffset]) in + let address = inv#rewrite_expr addr in + match address with + | XConst (IntConst n) -> + let dw = numerical_mod_to_doubleword n in + if system_info#get_image_base#le dw then + tprop + (self#env#mk_global_variable ~size n) + (__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": memref:global") + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to convert constant value " ^ n#toString + ^ "to a valid program address (should be greater than " + ^ system_info#get_image_base#to_hex_string + ^ ")"] + | _ -> + let (memref_r, memoffset_r) = self#decompose_memaddr address in + mk_memvar memref_r memoffset_r + method get_memory_variable_1 ?(align=1) (* alignment of var value *) ?(size=4) (var:variable_t) - (offset:numerical_t) = + (offset:numerical_t): variable_t = let default () = self#env#mk_memory_variable (self#env#mk_unknown_memory_reference "memref-1") offset in @@ -702,23 +753,6 @@ object (self) default ()) (default ()) (numerical_to_doubleword n) - | XVar v when self#f#env#is_memory_address_variable v -> - log_tfold_default - (log_error - "get_memory_variable_1" - (self#cia ^ ": memory address variable: " ^ (p2s var#toPretty))) - (fun v -> v) - (default ()) - (self#env#mk_memory_address_deref_variable v) - | XOp (XPlus, [XVar v; XConst (IntConst n)]) - when self#f#env#is_memory_address_variable v -> - log_tfold_default - (log_error - "get_memory_variable_1" - (self#cia ^ ": memory address variable: " ^ (p2s var#toPretty))) - (fun v -> v) - (default ()) - (self#env#mk_memory_address_deref_variable ~offset:n#toInt v) | _ -> let (memref, memoffset) = self#decompose_address address in if is_constant_offset memoffset then @@ -730,10 +764,15 @@ object (self) (self#cia)) (fun v -> v) (default ()) - (self#env#mk_global_variable (get_total_constant_offset memoffset)) + (TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + self#env#mk_global_variable + (get_total_constant_offset memoffset)) else - self#env#mk_memory_variable - memref (get_total_constant_offset memoffset) in + (TR.tfold_default + (self#env#mk_memory_variable memref) + (default ()) + (get_total_constant_offset memoffset)) in memvar else default () in @@ -747,32 +786,100 @@ object (self) * resolve and save ScaledReg (cpureg1, cpureg2, 1, offset) (memrefs2) * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) + method get_memory_variable_varoffset + ?(size=4) (var1: variable_t) (var2: variable_t) (offset: numerical_t): + variable_t traceresult = + let addr = XOp (XPlus, [XVar var1; XVar var2]) in + let addr = XOp (XPlus, [addr; num_constant_expr offset]) in + let address = simplify_xpr (self#inv#rewrite_expr addr) in + let (memref_r, memoff_r) = self#decompose_memaddr address in + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memref -> + if memref#is_global_reference then + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": memref:global") + (fun memoff -> + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (self#env#mk_global_variable ~size) + (get_total_constant_offset memoff)) + memoff_r + else + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memoff -> + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (self#env#mk_memory_variable memref) + (get_total_constant_offset memoff)) + memoff_r) + memref_r + method get_memory_variable_2 ?(size=4) (var1:variable_t) (var2:variable_t) (offset:numerical_t) = - let _ = track_function - ~iaddr:self#cia self#fa - (LBLOCK [ - STR "get_memory_variable_2: "; - STR "var1: "; - var1#toPretty; - STR "; var2: "; - var2#toPretty; - STR "; offset: "; - offset#toPretty]) in + let default () = + self#env#mk_memory_variable + (self#env#mk_unknown_memory_reference "memref-2") numerical_zero in let addr = XOp (XPlus, [XVar var1; XVar var2]) in let addr = XOp (XPlus, [addr; num_constant_expr offset]) in let address = self#inv#rewrite_expr addr in let (memref, memoffset) = self#decompose_address address in if is_constant_offset memoffset then - self#env#mk_memory_variable ~size memref (get_total_constant_offset memoffset) + TR.tfold_default + (self#env#mk_memory_variable ~size memref) + (default ()) + (get_total_constant_offset memoffset) else - self#env#mk_memory_variable - (self#env#mk_unknown_memory_reference "memref-2") numerical_zero + default () (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * resolve and save ScaledReg (cpureg1, cpureg2, s, offset) (memrefs3) * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) + method get_memory_variable_scaledoffset + ?(size=4) + (base: variable_t) + (index: variable_t) + (scale: int) + (offset: numerical_t): variable_t traceresult = + let indexexpr = + if self#inv#is_constant index then + num_constant_expr (self#inv#get_constant index) + else + XVar index in + let addr = XOp (XPlus, [XVar base; num_constant_expr offset]) in + let addr = self#inv#rewrite_expr addr in + let addr = + XOp (XPlus, + [addr; XOp (XMult, [int_constant_expr scale; indexexpr])]) in + let address = simplify_xpr (self#inv#rewrite_expr addr) in + let (memref_r, memoff_r) = self#decompose_memaddr address in + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memref -> + if memref#is_global_reference then + self#get_var_at_address ~size:(Some size) address + (* + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": memref:global") + (fun memoff -> + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (self#env#mk_global_variable ~size) + (get_total_constant_offset memoff)) + memoff_r *) + else + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memoff -> + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (self#env#mk_memory_variable memref) + (get_total_constant_offset memoff)) + memoff_r) + memref_r + method get_memory_variable_3 ?(size=4) (base:variable_t) @@ -781,7 +888,7 @@ object (self) (offset:numerical_t) = let default () = self#env#mk_memory_variable - (self#env#mk_unknown_memory_reference "memref-1") offset in + (self#env#mk_unknown_memory_reference "memref-3") offset in let inv = self#inv in let indexExpr = if inv#is_constant index then @@ -803,14 +910,21 @@ object (self) (self#cia ^ ": memoffset: " ^ (memory_offset_to_string memoffset))) (fun v -> v) (default ()) - (self#env#mk_global_variable (get_total_constant_offset memoffset)) + (TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + self#env#mk_global_variable + (get_total_constant_offset memoffset)) else - self#env#mk_memory_variable - ~size memref (get_total_constant_offset memoffset) + TR.tfold_default + (self#env#mk_memory_variable ~size memref) + (default ()) + (get_total_constant_offset memoffset) else + default () + (* match memoffset with | IndexOffset _ -> - self#env#mk_index_offset_memory_variable memref memoffset + self#env#mk_offset_memory_variable memref memoffset | ConstantOffset (n, IndexOffset (v, s, o)) -> let n = n#modulo (mkNumerical BCHDoubleword.e32) in log_tfold_default @@ -833,7 +947,7 @@ object (self) n (IndexOffset (v, s, o))) | _ -> default () - + *) (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * resolve and save ScaledReg (None,indexreg, scale, offset) @@ -1132,82 +1246,173 @@ object (self) method get_fts_parameter_expr (_p: fts_parameter_t) = None - method decompose_memvar_address - (x: xpr_t): (memory_reference_int * memory_offset_t) option = - let _ = chlog#add "decompose_array_address" (LBLOCK [STR "xpr: "; x2p x]) in + method get_var_at_address + ?(size=None) + ?(btype=t_unknown) + (addrvalue: xpr_t): variable_t traceresult = + match memmap#xpr_containing_location addrvalue with + | Some gloc -> + (TR.tmap + (fun offset -> self#f#env#mk_gloc_variable gloc offset) + (gloc#address_memory_offset ~tgtsize:size ~tgtbtype:btype addrvalue)) + | _ -> + let (memref_r, memoff_r) = self#decompose_memaddr addrvalue in + TR.tmap2 + ~msg1:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memref memoff -> + self#f#env#mk_offset_memory_variable memref memoff) + memref_r memoff_r + + method decompose_memaddr (x: xpr_t): + (memory_reference_int traceresult * memory_offset_t traceresult) = + let is_external (v: variable_t) = self#env#is_function_initial_value v in let vars = vars_as_positive_terms x in - let memaddrs = List.filter self#f#env#is_memory_address_variable vars in - let optbase = - match memaddrs with - | [base] -> - let (_, _, _, optty) = - TR.tget_ok (self#f#env#varmgr#get_memory_address_meminfo base) in - let offset = simplify_xpr (XOp (XMinus, [x; XVar base])) in - Some (XVar base, offset, optty) - | _ -> - None in - match optbase with - | None -> None - | Some (_, _, None) -> None - | Some (XVar base, xoffset, Some ty) when is_array_type ty -> - let _ = - chlog#add - "decompose_array_address" (LBLOCK [STR "xoffset: "; x2p xoffset]) in - let eltty = get_element_type ty in - let elttysize_r = size_of_btype eltty in - (match elttysize_r with - | Error e -> - begin - CHTimingLog.log_error - "Unable to obtain array element size for %s: %s [%s:%d]" - (x2s (XVar base)) - (String.concat "; " e) - __FILE__ __LINE__; - None - end - | Ok elttysize -> - let optmemref = TR.to_option (self#env#mk_base_variable_reference base) in - let optindex = get_array_index_offset xoffset elttysize in - let memoffset = - match optindex with - | None -> - let _ = - chlog#add - "decompose_array_address" - (LBLOCK [ - STR "Unable to get array index offset for "; - x2p xoffset; - STR " with size "; - INT elttysize]) in - UnknownOffset - | Some (indexxpr, rem) -> - let remoffset = mk_maximal_memory_offset rem eltty in - ArrayIndexOffset (indexxpr, remoffset) in - (match (optmemref, memoffset) with - | (_, UnknownOffset) -> None - | (Some memref, memoffset) -> Some (memref, memoffset) - | _ -> - None)) - | Some (XVar base, xoffset, Some ty) when is_struct_type ty -> - let _ = - chlog#add - "decompose_struct_address" (LBLOCK [STR "xoffset: "; x2p xoffset]) in - let optmemref = TR.to_option (self#env#mk_base_variable_reference base) in - let cinfo = get_struct_type_compinfo ty in - (match xoffset with - | XConst (IntConst n) -> - let optfinfo = get_struct_field_at_offset cinfo n#toInt in - (match optfinfo with - | None -> None - | Some (finfo, rem) when rem = 0 -> - let memoffset = FieldOffset ((finfo.bfname, cinfo.bckey), NoOffset) in - (match optmemref with - | Some memref -> Some (memref, memoffset) - | _ -> None) - | _ -> None) - | _ -> None) - | _ -> None + let knownpointers = List.filter self#f#is_base_pointer vars in + match knownpointers with + (* one known pointer, must be the base *) + | [base] -> + let offset = simplify_xpr (XOp (XMinus, [x; XVar base])) in + let memref_r = self#env#mk_base_variable_reference base in + let vartype = self#f#env#get_variable_type base in + let vartype = match vartype with None -> t_unknown | Some t -> t in + let memoff_r = address_memory_offset vartype offset in + (* + (match offset with + | XConst (IntConst n) -> Ok (ConstantOffset (n, NoOffset)) + | XOp (XMult, [XConst (IntConst n); XVar v]) -> + Ok (IndexOffset (v, n#toInt, NoOffset)) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Offset from base " + ^ (x2s (XVar base)) + ^ " not recognized: " ^ (x2s offset)]) in *) + (memref_r, memoff_r) + + (* no known pointers, have to find a base *) + | [] -> + let maxC = largest_constant_term x in + let maxCdw = TR.tvalue (numerical_to_doubleword maxC) ~default:wordzero in + (* if maxC#gt system_info#get_image_base#to_numerical then *) + if system_info#is_code_address maxCdw + || memmap#is_global_data_address maxCdw then + (* global base *) + let memref_r = Ok self#env#mk_global_memory_reference in + let offset = simplify_xpr (XOp (XMinus, [x; num_constant_expr maxC])) in + let gmemoff_r = + match offset with + | XConst (IntConst n) -> Ok (ConstantOffset (n, NoOffset)) + | XOp (XMult, [XConst (IntConst n); XVar v]) -> + Ok (IndexOffset (v, n#toInt, NoOffset)) + | XOp (XMult, [XConst (IntConst n); x]) + when self#is_composite_symbolic_value x -> + let v = self#env#mk_symbolic_value x in + Ok (IndexOffset (v, n#toInt, NoOffset)) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "Offset from global base " + ^ maxC#toString + ^ " not recognized: " ^ (x2s offset)] in + let memoff_r = + tmap + (fun gmemoff -> ConstantOffset (maxC, gmemoff)) + gmemoff_r in + (memref_r, memoff_r) + else + (* find a candidate base pointer *) + (match vars with + | [base] when (self#is_initial_value_variable base) + || (is_external base) -> + let _ = self#f#add_base_pointer base in + let offset = simplify_xpr (XOp (XMinus, [x; XVar base])) in + let memref_r = self#env#mk_base_variable_reference base in + let memoff_r = + match offset with + | XConst (IntConst n) -> Ok (ConstantOffset (n, NoOffset)) + | XOp (XMult, [XConst (IntConst n); XVar v]) -> + Ok (IndexOffset (v, n#toInt, NoOffset)) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "Offset from base " + ^ (x2s (XVar base)) + ^ " not recognized: " ^ (x2s offset)] in + (memref_r, memoff_r) + + | [base] when (self#env#is_stack_parameter_variable base) + && (self#f#env#has_constant_offset base) + && (self#has_initial_value base) -> + let base_r = + TR.tmap + (fun baseInit -> + let _ = self#f#add_base_pointer baseInit in + baseInit) + (self#f#env#mk_initial_memory_value base) in + let memref_r = + TR.tbind + (fun base -> self#env#mk_base_variable_reference base) + base_r in + let memoff_r = + TR.tbind + (fun base -> + let offset = simplify_xpr (XOp (XMinus, [x; XVar base])) in + match offset with + | XConst (IntConst n) -> Ok (ConstantOffset (n, NoOffset)) + | XOp (XMult, [XConst (IntConst n); XVar v]) -> + Ok (IndexOffset (v, n#toInt, NoOffset)) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "Offset from base " + ^ (x2s (XVar base)) + ^ " not recognized: " ^ (x2s offset)]) + base_r in + (memref_r, memoff_r) + + | [v] -> + let memref_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "No candidate base pointers. Only variable found: " + ^ (p2s v#toPretty)] in + let memoff_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__)] in + (memref_r, memoff_r) + + | [] -> + let memref_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "No candidate pointers. Left with maxC: " + ^ maxC#toString] in + let memoff_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__)] in + (memref_r, memoff_r) + + (* multiple variables *) + | _ -> + let memref_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "Multiple variables: " + ^ (String.concat "; " + (List.map (fun v -> p2s v#toPretty) vars))] in + let memoff_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__)] in + (memref_r, memoff_r)) + + (* multiple known pointers *) + | _ -> + let memref_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (p2s self#l#toPretty) ^ ": " + ^ "Multiple known pointers: " + ^ (String.concat "; " + (List.map (fun v -> p2s v#toPretty) knownpointers))] in + let memoff_r = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__)] in + (memref_r, memoff_r) (* the objective is to extract a base pointer and an offset expression * first check whether the expression contains any variables that are known @@ -1245,13 +1450,21 @@ object (self) self#f#add_base_pointer base; Some (XVar base, simplify_xpr (XOp (XMinus, [x; XVar base]))) end - | [base] when self#env#is_stack_parameter_variable base && - self#f#env#has_constant_offset base && self#has_initial_value base -> - let baseInit = self#f#env#mk_initial_memory_value base in - begin - self#f#add_base_pointer baseInit; - Some (XVar base, simplify_xpr (XOp (XMinus, [x; XVar base]))) - end + | [base] when self#env#is_stack_parameter_variable base + && self#f#env#has_constant_offset base + && self#has_initial_value base -> + TR.tfold + ~ok:(fun baseInit -> + begin + self#f#add_base_pointer baseInit; + Some (XVar base, simplify_xpr (XOp (XMinus, [x; XVar base]))) + end) + ~error:(fun e -> + begin + log_error_result ~tag:"decompose_address" __FILE__ __LINE__ e; + None + end) + (self#f#env#mk_initial_memory_value base) | [_] -> None | [] -> (* suspicious address below the image base *) begin @@ -1433,6 +1646,89 @@ object (self) (List.length vars) > 0 && List.for_all is_fixed_type (variables_in_expr x) + method get_assign_commands_r + ?(signed=false) + ?(size=4) + (lhs_r: variable_t traceresult) + (rhs_r: xpr_t traceresult): cmd_t list = + if Result.is_error lhs_r then + let (cmds, op_args) = + TR.tfold + ~ok:(fun rhs -> + let reqN () = self#env#mk_num_temp in + let reqC = self#env#request_num_constant in + let (rhscmds, rhs_c) = xpr_to_numexpr reqN reqC rhs in + (rhscmds, get_rhs_op_args rhs_c)) + ~error:(fun e -> + begin + log_error_result + ~tag:("assignment lhs unknown") + ~msg:(p2s self#l#toPretty) + __FILE__ __LINE__ e; + ([], []) + end) + rhs_r in + cmds @ [OPERATION ({op_name = unknown_write_symbol; op_args = op_args})] + + else if Result.is_error rhs_r then + let lhs = TR.tget_ok lhs_r in + [ABSTRACT_VARS [lhs]] + + else + let lhs = TR.tget_ok lhs_r in + let rhs = TR.tget_ok rhs_r in + let rhs = simplify_xpr (self#inv#rewrite_expr rhs) in + let rhs = + if not signed then + match rhs with + | XConst (IntConst n) -> + let n = + match size with + | 1 -> n#modulo numerical_e8 + | 2 -> n#modulo numerical_e16 + | 4 -> n#modulo numerical_e32 + | _ -> n in + num_constant_expr n + | _ -> rhs + else + rhs in + + let rhs = + (* if rhs is a composite symbolic expression, create a new variable + for it *) + if self#is_composite_symbolic_value rhs then + XVar (self#env#mk_symbolic_value rhs) + else + rhs in + let reqN () = self#env#mk_num_temp in + let reqC = self#env#request_num_constant in + let (rhscmds, rhs_c) = xpr_to_numexpr reqN reqC rhs in + let cmds = rhscmds @ [ASSIGN_NUM (lhs, rhs_c)] in + let fndata = self#f#get_function_data in + match fndata#get_regvar_intro self#ia with + | Some rvi when rvi.rvi_cast && Option.is_some rvi.rvi_vartype -> + TR.tfold + ~ok:(fun reg -> + let ty = Option.get rvi.rvi_vartype in + let tcvar = + self#f#env#mk_typecast_value self#cia rvi.rvi_name ty reg in + begin + log_result __FILE__ __LINE__ + ["Create typecast var for " + ^ (register_to_string reg) + ^ " at " + ^ self#cia]; + cmds @ [ASSIGN_NUM (lhs, NUM_VAR tcvar)] + end) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ + ("expected a register variable" :: e); + cmds + end) + (self#f#env#get_register lhs) + | _ -> cmds + (* Note: recording of loads and stores is performed by the different architectures directly in FnXXXDictionary.*) method get_assign_commands @@ -1511,17 +1807,15 @@ object (self) (match vtype with | TUnknown _ -> () | _ -> - begin - chlog#add - "set constant-value variable type" - (LBLOCK [ - STR self#cia; - STR ": "; - sv#toPretty; - STR ": "; - STR (btype_to_string vtype)]); - self#f#set_btype sv vtype - end); + chlog#add + "set constant-value variable type" + (LBLOCK [ + STR self#cia; + STR ": "; + sv#toPretty; + STR ": "; + STR (btype_to_string vtype)])); + (* self#f#set_btype sv vtype *) XVar sv end else @@ -1657,6 +1951,18 @@ object (self) (x2s size) (btype_to_string vtype) in [ABSTRACT_VARS [lhs]] + method get_abstract_commands_r (lhs_r: variable_t traceresult): cmd_t list = + TR.tfold + ~ok:(fun lhs -> [ABSTRACT_VARS [lhs]]) + ~error:(fun e -> + begin + log_error_result + ~tag:"lhs not abstracted" ~msg:(p2s self#l#toPretty) + __FILE__ __LINE__ e; + [] + end) + lhs_r + method get_ssa_abstract_commands (reg: register_t) () = let regvar = self#env#mk_register_variable reg in (regvar, [ABSTRACT_VARS [regvar]]) @@ -2127,6 +2433,10 @@ object (self) self#env#set_variable_name rvar name in ASSIGN_NUM (r0, NUM_VAR rvar) in let bridgeVars = self#env#get_bridge_values_at self#cia in + let abstractglobals = + let globals = + List.filter self#env#is_global_variable self#env#get_variables in + [ABSTRACT_VARS globals] in let sideeffect_assigns = self#get_sideeffect_assigns self#get_call_target#get_semantics in let _ = @@ -2139,6 +2449,7 @@ object (self) | _ -> [ABSTRACT_VARS abstrRegs]) @ [returnassign] @ sideeffect_assigns + @ abstractglobals @ (match bridgeVars with | [] -> [] | _ -> [ABSTRACT_VARS bridgeVars]) diff --git a/CodeHawk/CHB/bchlib/bCHFunctionData.ml b/CodeHawk/CHB/bchlib/bCHFunctionData.ml index 61baf471..8185afb0 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionData.ml +++ b/CodeHawk/CHB/bchlib/bCHFunctionData.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2019 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 @@ -14,10 +14,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,12 +34,14 @@ open CHPretty open CHIndexTable open CHLogger open CHNumRecordTable +open CHTraceResult open CHUtil open CHXmlDocument (* bchlib *) open BCHBasicTypes open BCHBCTypes +open BCHBCTypePretty open BCHBCTypeUtil open BCHDemangler open BCHDoubleword @@ -56,9 +58,33 @@ let sanitize_function_name (s: string) = string_replace '.' "_" s +let regvar_intro_to_string (rvi: regvar_intro_t) = + let ptype = + match rvi.rvi_vartype with + | Some t -> + let iscast = if rvi.rvi_cast then ", cast" else "" in + " (" ^ (btype_to_string t) ^ iscast ^ ")" + | _ -> "" in + rvi.rvi_iaddr#to_hex_string ^ ": " ^ rvi.rvi_name ^ ptype + + +let stackvar_intro_to_string (svi: stackvar_intro_t) = + let ptype = + match svi.svi_vartype with + | Some t -> " (" ^ (btype_to_string t) ^ ")" + | _ -> "" in + (string_of_int svi.svi_offset) ^ ": " ^ svi.svi_name ^ ptype + + +let function_annotation_to_string (a: function_annotation_t) = + (String.concat "\n" (List.map regvar_intro_to_string a.regvarintros)) + ^ (String.concat "\n" (List.map stackvar_intro_to_string a.stackvarintros)) + + class function_data_t (fa:doubleword_int) = object (self) + val faddr = fa val mutable names = [] val mutable non_returning = false val mutable incomplete = false @@ -67,6 +93,7 @@ object (self) val mutable by_preamble = false val mutable virtual_function = false val mutable classinfo = None + val mutable functionannotation: function_annotation_t option = None val mutable inlined = false val mutable library_stub = false val mutable inlined_blocks = [] @@ -123,6 +150,77 @@ object (self) method set_class_info ~(classname:string) ~(isstatic:bool) = classinfo <- Some (classname,isstatic) + method set_function_annotation (a: function_annotation_t) = + begin + functionannotation <- Some a; + chlog#add + "function annotation" + (LBLOCK [faddr#toPretty; NL; STR (function_annotation_to_string a)]) + end + + method has_function_annotation: bool = + match functionannotation with Some _ -> true | _ -> false + + method get_function_annotation: function_annotation_t option = + functionannotation + + method get_regvar_intro (iaddr: doubleword_int): regvar_intro_t option = + match self#get_function_annotation with + | Some a -> + List.fold_left (fun acc rvi -> + match acc with + | Some _ -> acc + | _ -> if rvi.rvi_iaddr#equal iaddr then Some rvi else None) + None a.regvarintros + | _ -> None + + method has_regvar_type_annotation (iaddr: doubleword_int): bool = + match self#get_function_annotation with + | Some a -> + List.exists + (fun rvi -> rvi.rvi_iaddr#equal iaddr && Option.is_some rvi.rvi_vartype) + a.regvarintros + | _ -> false + + method has_regvar_type_cast (iaddr: doubleword_int): bool = + match self#get_function_annotation with + | Some a -> + List.exists + (fun rvi -> rvi.rvi_iaddr#equal iaddr && rvi.rvi_cast) a.regvarintros + | _ -> false + + method get_regvar_type_annotation (iaddr: doubleword_int): btype_t traceresult = + let opttype = + match self#get_function_annotation with + | None -> + Some + (Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Function " ^ faddr#to_hex_string ^ " does not have annotations"]) + | Some a -> + List.fold_left + (fun acc rvi -> + match acc with + | Some _ -> acc + | _ -> + if rvi.rvi_iaddr#equal iaddr then + match rvi.rvi_vartype with + | Some t -> Some (Ok t) + | _ -> + Some (Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Register var annotation at " + ^ iaddr#to_hex_string + ^ " does not have a type"]) + else + acc) None a.regvarintros in + match opttype with + | Some r -> r + | None -> + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No register var annotation found at " ^ iaddr#to_hex_string] + method add_inlined_block (baddr:doubleword_int) = inlined_blocks <- baddr :: inlined_blocks @@ -261,6 +359,10 @@ object (self) method get_library_stubs: doubleword_int list = self#retrieve_addresses (fun f -> f#is_library_stub) + method is_in_function_stub ?(size=3) (va: doubleword_int): bool = + let libstubs = self#get_library_stubs in + List.exists (fun s -> s#le va && va#lt(s#add_int (size * 4))) libstubs + method is_function_entry_point (fa:doubleword_int) = H.mem table fa#index method has_function_name (fa:doubleword_int) = @@ -353,5 +455,136 @@ end let functions_data = new functions_data_t - - + + +let read_xml_regvar_intro (node: xml_element_int): regvar_intro_t traceresult = + let get = node#getAttribute in + let has = node#hasNamedAttribute in + if not (has "name") then + Error ["register var intro without name"] + else if not (has "iaddr") then + Error ["register var intro without instruction address"] + else + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun dw -> + let rvi_iaddr = dw in + let rvi_name = get "name" in + let (rvi_vartype, rvi_cast) = + if has "typename" then + let iscast = (has "cast") && ((get "cast") = "yes") in + let typename = get "typename" in + TR.tfold + ~ok:(fun btype -> + if has "ptrto" && (get "ptrto") = "yes" then + (Some (t_ptrto btype), iscast) + else + (Some btype, iscast)) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + (None, false) + end) + (convert_string_to_type typename) + else + (None, false) in + Ok {rvi_iaddr = rvi_iaddr; + rvi_name = rvi_name; + rvi_cast = rvi_cast; + rvi_vartype = rvi_vartype}) + (string_to_doubleword (get "iaddr")) + + +let read_xml_stackvar_intro (node: xml_element_int): stackvar_intro_t traceresult = + let get = node#getAttribute in + let geti = node#getIntAttribute in + let has = node#hasNamedAttribute in + if not (has "offset") then + Error ["stackvar intro without offset"] + else if not (has "name") then + Error ["stackvar intro without name"] + else + let svi_offset = geti "offset" in + let svi_name = get "name" in + let svi_vartype = + if has "typename" then + let typename = get "typename" in + TR.tfold + ~ok:(fun btype -> + if has "ptrto" && (get "ptrto") = "yes" then + Some (t_ptrto btype) + else if has "arraysize" then + let arraysize = geti "arraysize" in + Some (t_array btype arraysize) + else + Some btype) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + None + end) + (convert_string_to_type typename) + else + None in + Ok {svi_offset = svi_offset; + svi_name = svi_name; + svi_vartype = svi_vartype} + + +let read_xml_function_annotation (node: xml_element_int) = + let get = node#getAttribute in + let getc = node#getTaggedChild in + let hasc = node#hasOneTaggedChild in + 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 + fndata#set_function_annotation + {regvarintros = regvintros; stackvarintros = stackvintros} + else + log_error_result + ~tag:"function annotation faddr not found" + __FILE__ __LINE__ + ["Function annotation address: " ^ faddr ^ " not known"]) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + (string_to_doubleword faddr) + + +let read_xml_function_annotations (node: xml_element_int) = + List.iter + read_xml_function_annotation (node#getTaggedChildren "function-annotation") diff --git a/CodeHawk/CHB/bchlib/bCHFunctionData.mli b/CodeHawk/CHB/bchlib/bCHFunctionData.mli index 240c436e..dbc373c3 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionData.mli +++ b/CodeHawk/CHB/bchlib/bCHFunctionData.mli @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny Sipma - Copyright (c) 2021-2023 Aarno Labs + Copyright (c) 2021-2025 Aarno Labs Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -14,10 +14,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,7 +27,12 @@ SOFTWARE. ============================================================================= *) +(* chutil *) +open CHXmlDocument + (* bchlib *) open BCHLibTypes val functions_data: functions_data_int + +val read_xml_function_annotations: xml_element_int -> unit diff --git a/CodeHawk/CHB/bchlib/bCHFunctionInfo.ml b/CodeHawk/CHB/bchlib/bCHFunctionInfo.ml index 29f95172..da626ee7 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionInfo.ml +++ b/CodeHawk/CHB/bchlib/bCHFunctionInfo.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 @@ -53,14 +53,12 @@ open BCHBCTypePretty open BCHBCTypes open BCHBCTypeUtil open BCHBTerm -open BCHCallTarget open BCHCallTargetInfo open BCHCPURegisters open BCHConstantDefinitions open BCHCppClass open BCHCStruct open BCHDoubleword -open BCHExternalPredicate open BCHFtsParameter open BCHFunctionInterface open BCHFunctionData @@ -82,10 +80,9 @@ module H = Hashtbl module LF = CHOnlineCodeSet.LanguageFactory module TR = CHTraceResult -let bcd = BCHBCDictionary.bcdictionary - let x2p = xpr_formatter#pr_expr -let p2s = pretty_to_string +let p2s = CHPrettyUtil.pretty_to_string +let x2s x = p2s (x2p x) let log_error (tag: string) (msg: string): tracelogspec_t = @@ -109,6 +106,8 @@ module DoublewordCollections = CHCollections.Make let id = BCHInterfaceDictionary.interface_dictionary +let memmap = BCHGlobalMemoryMap.global_memory_map + type po_anchor_t = (* proof obligation anchor *) | DirectAccess @@ -169,7 +168,6 @@ object (self) val scope = LF.mkScope () val virtual_calls = H.create 3 - val initial_call_target_values = H.create 3 val initial_string_values = H.create 3 initializer @@ -178,6 +176,15 @@ object (self) method get_variable_comparator = varmgr#get_external_variable_comparator + method private log_dc_error_result (line: int) (e: string list) = + if BCHSystemSettings.system_settings#collect_data then + self#log_error_result line e + else + () + + method private log_error_result (line: int) (e: string list) = + log_error_result ~msg:(faddr#to_hex_string ^ ":env") __FILE__ line e + (* ------------------------------------------------------ variable names -- *) val variable_names = make_variable_names () @@ -216,7 +223,7 @@ object (self) (mkNumerical fld.fld_offset) in let fldname = vname ^ "->" ^ fld.fld_name in let fldtype = fld.fld_type in - let ifldvar = self#mk_initial_memory_value fldvar in + let ifldvar = TR.tget_ok (self#mk_initial_memory_value fldvar) in let ifldname = fldname ^ "_in" in let _ = chlog#add "set field var" (STR fldname) in begin @@ -241,7 +248,7 @@ object (self) List.iter (fun (offset, name, _ty) -> let memref = self#mk_local_stack_reference in let v = self#mk_memory_variable memref (mkNumerical offset) in - let initV = self#mk_initial_memory_value v in + let initV = TR.tget_ok (self#mk_initial_memory_value v) in begin self#set_variable_name initV name ; if offset = 4 then @@ -251,7 +258,7 @@ object (self) let jniInterfacePtr = self#mk_memory_variable memref numerical_zero in let jniInterfacePtrIn = - self#mk_initial_memory_value jniInterfacePtr in + TR.tget_ok (self#mk_initial_memory_value jniInterfacePtr) in self#set_variable_name jniInterfacePtrIn "jni$Ifp") ~error:(fun _ -> ()) (self#mk_base_variable_reference initV) @@ -262,7 +269,7 @@ object (self) List.iter (fun (offset, name, _ty) -> let memref = self#mk_local_stack_reference in let v = self#mk_memory_variable memref (mkNumerical offset) in - let initV = self#mk_initial_memory_value v in + let initV = TR.tget_ok (self#mk_initial_memory_value v) in begin self#set_variable_name initV name ; if offset = 4 then @@ -273,7 +280,7 @@ object (self) let jniInterfacePtr = self#mk_memory_variable memref numerical_zero in let jniInterfacePtrIn = - self#mk_initial_memory_value jniInterfacePtr in + TR.tget_ok (self#mk_initial_memory_value jniInterfacePtr) in self#set_variable_name jniInterfacePtrIn "jni$Ifp") ~error:(fun _ -> ()) (self#mk_base_variable_reference initV) @@ -285,7 +292,7 @@ object (self) let memref = self#mk_local_stack_reference in let argvar = self#mk_memory_variable ~save_name:false memref (mkNumerical (4*i)) in - let argvarin = self#mk_initial_memory_value argvar in + let argvarin = TR.tget_ok (self#mk_initial_memory_value argvar) in begin match sc with | FieldValues l -> @@ -294,7 +301,7 @@ object (self) (log_error "set_argument_structconstant" "invalid memref") ~ok:(fun mref -> let mvar = self#mk_memory_variable mref (mkNumerical offset) in - let mvarin = self#mk_initial_memory_value mvar in + let mvarin = TR.tget_ok (self#mk_initial_memory_value mvar) in match ssc with | FieldString s -> begin @@ -311,50 +318,6 @@ object (self) STR " -- "; STR s]) end - | FieldCallTarget tgt -> - begin - H.add - initial_call_target_values - mvarin#getName#getSeqNumber - tgt; - chlog#add - "struct constant invariant" - (LBLOCK [ - faddr#toPretty; - STR ": "; - mvarin#toPretty; - STR " -- "; - call_target_to_pretty tgt]) - end - | FieldValues ll -> - List.iter (fun (offset, ssc) -> - log_tfold - (log_error - "set_argument_structconstant" "invalid memref-2") - ~ok:(fun mref -> - let mvar = - self#mk_memory_variable mref - (mkNumerical offset) in - let mvarin = self#mk_initial_memory_value mvar in - match ssc with - | FieldCallTarget tgt -> - begin - H.add - initial_call_target_values - mvarin#getName#getSeqNumber - tgt; - chlog#add - "struct constant invariant" - (LBLOCK [ - faddr#toPretty; - STR ": "; - mvarin#toPretty; - STR " -- "; - call_target_to_pretty tgt]) - end - | _ -> ()) - ~error:(fun _ -> ()) - (self#mk_base_variable_reference mvarin)) ll | _ -> ()) ~error:(fun _ -> ()) (self#mk_base_variable_reference argvarin)) l @@ -391,7 +354,7 @@ object (self) memref (mkNumerical (i * 4)) in - let memInitVar = self#mk_initial_memory_value memvar in + let memInitVar = TR.tget_ok (self#mk_initial_memory_value memvar) in (name,memInitVar)) stackpardata in let regVars = List.map (fun (r,name) -> @@ -437,7 +400,8 @@ object (self) ~save_name:false memref (mkNumerical dm.cppdm_offset) in - let memberInitVar = self#mk_initial_memory_value memberVar in + let memberInitVar = + TR.tget_ok (self#mk_initial_memory_value memberVar) in let mName = self#variable_name_to_string basevar in let name = mName ^ "->" ^ dm.cppdm_name in self#set_variable_name memberInitVar name) @@ -455,7 +419,7 @@ object (self) memref (mkNumerical vf.cppvf_offset) in let vfptrInitVar = - self#mk_initial_memory_value vfptrVar in + TR.tget_ok (self#mk_initial_memory_value vfptrVar) in let mName = self#variable_name_to_string basevar in let vfptrName = mName ^ "->vtableptr" in let vfsummaries = get_vtable_summaries vf.cppvf_table in @@ -472,7 +436,7 @@ object (self) vfmemref (mkNumerical vfOffset) in let vfInitVar = - self#mk_initial_memory_value vfVar in + TR.tget_ok (self#mk_initial_memory_value vfVar) in self#register_virtual_call vfInitVar summary) ~error:(fun _ -> ()) (self#mk_base_variable_reference vfptrInitVar)) @@ -495,7 +459,8 @@ object (self) ~save_name:false memref (mkNumerical dm.cppdm_offset) in - let memberInitVar = self#mk_initial_memory_value memberVar in + let memberInitVar = + TR.tget_ok (self#mk_initial_memory_value memberVar) in let name = "this->" ^ dm.cppdm_name in begin self#set_variable_name memberInitVar name ; @@ -514,7 +479,8 @@ object (self) ~save_name:false memref (mkNumerical vf.cppvf_offset) in - let vfptrInitVar = self#mk_initial_memory_value vfptrVar in + let vfptrInitVar = + TR.tget_ok (self#mk_initial_memory_value vfptrVar) in let vfptrVarName = "this->" ^ "vtableptr" in let vfsummaries = get_vtable_summaries vf.cppvf_table in begin @@ -529,7 +495,8 @@ object (self) ~save_name:false vfmemref (mkNumerical vfOffset) in - let vfInitVar = self#mk_initial_memory_value vfVar in + let vfInitVar = + TR.tget_ok (self#mk_initial_memory_value vfVar) in self#register_virtual_call vfInitVar summary) ~error:(fun _ -> ()) (self#mk_base_variable_reference vfptrInitVar)) @@ -554,34 +521,57 @@ object (self) let stackpardata = List.map (fun p -> let (name, ty) = get_parameter_signature p in - let offset = TR.tget_ok (get_stack_parameter_offset p) in - (offset, name, ty)) (get_stack_parameters fintf) in + let offset = get_stack_parameter_offset p in + (offset, name, ty)) + (get_stack_parameters fintf) in let regpardata = List.map (fun p -> let (name, ty) = get_parameter_signature p in - let reg = TR.tget_ok (get_register_parameter_register p) in + let reg = get_register_parameter_register p in (reg, name, ty)) (get_register_parameters fintf) in begin - List.iter (fun (offset, name, ty) -> - let memref = self#mk_local_stack_reference in - let v = - self#mk_memory_variable - ~save_name:false memref (mkNumerical offset) in - let iv = self#mk_initial_memory_value v in - let vname = name ^ "$" ^ (string_of_int offset) in - begin - self#set_variable_name iv vname ; - if is_ptrto_known_struct ty then - self#set_pointedto_struct_field_names 1 iv vname ty - end) stackpardata; - List.iter (fun (reg,name,ty) -> - let v = self#mk_initial_register_value ~level:0 reg in - let vname = name in - begin - self#set_variable_name v vname ; - if is_ptrto_known_struct ty then - self#set_pointedto_struct_field_names 1 v vname ty - end) regpardata + List.iter (fun (offset_r, name, ty) -> + let memref = self#mk_local_stack_reference in + TR.tfold + ~ok:(fun offset -> + let v = + self#mk_memory_variable + ~save_name:false memref (mkNumerical offset) in + TR.tfold + ~ok:(fun iv -> + let vname = name ^ "$" ^ (string_of_int offset) in + begin + self#set_variable_name iv vname; + if is_ptrto_known_struct ty then + self#set_pointedto_struct_field_names 1 iv vname ty + end) + ~error:(fun e -> + ch_error_log#add + ("set_argument_names:" ^ (string_of_int __LINE__)) + (STR (String.concat "; " e))) + (self#mk_initial_memory_value v)) + ~error:(fun e -> + ch_error_log#add + ("set_argument_names" ^ (string_of_int __LINE__)) + (STR (String.concat "; " e))) + offset_r + ) stackpardata; + List.iter (fun (reg_r, name, ty) -> + TR.tfold + ~ok:(fun reg -> + let v = self#mk_initial_register_value ~level:0 reg in + let vname = name in + begin + self#set_variable_name v vname; + if is_ptrto_known_struct ty then + self#set_pointedto_struct_field_names 1 v vname ty + end) + ~error:(fun e -> + ch_error_log#add + ("set_argument_names:" ^ (string_of_int __LINE__)) + (STR (String.concat "; " e))) + reg_r + ) regpardata end @@ -606,7 +596,7 @@ object (self) method mk_base_sym_reference (s: symbol_t): memory_reference_int traceresult = tbind - ~msg:"env:mk_base_sym_reference" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) self#mk_base_variable_reference (self#get_variable s#getSeqNumber) @@ -668,7 +658,9 @@ object (self) end method get_symbolic_num_variable(v: variable_t): variable_t traceresult = - self#get_variable v#getName#getSeqNumber + tprop + (self#get_variable v#getName#getSeqNumber) + (__FILE__ ^ ":" ^ (string_of_int __LINE__)) method private has_chifvar index = H.mem chifvars index @@ -686,7 +678,8 @@ object (self) if H.mem chifvars index then Ok (H.find chifvars index) else - Error ["env#get_variable: index not found: " ^ (string_of_int index)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No variable found with index: " ^ (string_of_int index)] method get_variable_type (var: variable_t): btype_t option = varmgr#get_variable_type var @@ -756,19 +749,23 @@ object (self) self#mk_variable (varmgr#make_memory_variable (self#mk_unknown_memory_reference s) NoOffset) + (* Eventually this function should be replaced with mk_offset_memory_variable *) method mk_memory_variable ?(save_name=true) ?(size=4) (memref: memory_reference_int) (offset: numerical_t) = if memref#is_unknown_reference then - self#mk_num_temp + begin + log_error_result __FILE__ __LINE__ ["unknown memory reference: tmp created"]; + self#mk_num_temp + end else let optName = match memref#get_base with | BaseVar v when variable_names#has v#getName#getSeqNumber -> Some (variable_names#get v#getName#getSeqNumber) | _ -> None in - let offset = ConstantOffset (offset,NoOffset) in + let offset = ConstantOffset (offset, NoOffset) in let avar = varmgr#make_memory_variable ~size memref offset in let v = self#mk_variable avar in let _ = match optName with @@ -780,39 +777,31 @@ object (self) | _ -> () in v - method mk_index_offset_memory_variable + method add_memory_offset + (v:variable_t) + (memoff: memory_offset_t): variable_t traceresult = + if self#is_memory_variable v then + tmap + (fun av -> self#mk_variable av) + (varmgr#add_memvar_offset v memoff) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "variable " ^ (p2s v#toPretty) ^ " is not a memory variable"] + + method mk_offset_memory_variable ?(size=4) (memref: memory_reference_int) - (offset: memory_offset_t) = + (offset: memory_offset_t): variable_t = if memref#is_unknown_reference then - self#mk_num_temp + raise + (BCH_failure + (LBLOCK [STR "Unknown memory reference in mk_offset_memory_variable"])) else let avar = varmgr#make_memory_variable memref ~size offset in self#mk_variable avar - method mk_memory_address_deref_variable - ?(size=4) - ?(offset=0) - (var: variable_t): variable_t traceresult = - if self#is_memory_address_variable var then - let memref_r = varmgr#make_memref_from_basevar var in - let optty = tfold_default (fun memref -> memref#get_type) None memref_r in - match optty with - | None -> - Error ["Unknown type for memory address variable: " ^ (p2s var#toPretty)] - | Some ty when is_struct_type ty -> - let memoffset = mk_maximal_memory_offset (mkNumerical offset) ty in - tmap - (fun memref -> - self#mk_index_offset_memory_variable ~size memref memoffset) - memref_r - | Some ty -> - Error [ - "mk_memory_address_deref_variable: type is not a struct type: " - ^ (p2s var#toPretty) ^ " (" ^ (btype_to_string ty) ^ ")"] - else - Error ["Not a memory address variable: " ^ (p2s var#toPretty)] + (* method mk_index_offset_global_memory_variable ?(elementsize=4) (base: numerical_t) @@ -845,121 +834,66 @@ object (self) self#set_variable_name ivar (vname ^ "_in") end in Ok var + *) + + method mk_gloc_variable + (gloc: global_location_int) (offset: memory_offset_t): variable_t = + let numgaddr = gloc#address#to_numerical in + let gvar = self#mk_variable (varmgr#make_global_variable numgaddr) in + let ivar = self#mk_variable (varmgr#make_initial_memory_value gvar) in + begin + self#set_variable_name gvar gloc#name; + self#set_variable_name ivar (gloc#name ^ "_in"); + match offset with + | NoOffset -> gvar + | _ -> + let gvar = varmgr#make_global_variable ~offset numgaddr in + let gvar = self#mk_variable gvar in + let ivar = self#mk_variable (varmgr#make_initial_memory_value gvar) in + let name = gloc#name ^ (memory_offset_to_string offset) in + begin + self#set_variable_name gvar name; + self#set_variable_name ivar (name ^ "_in"); + gvar + end + end method mk_global_variable ?(size=4) - ?(offset=NoOffset) + ?(btype=t_unknown) (base: numerical_t): variable_t traceresult = - let base = base#modulo (mkNumerical BCHDoubleword.e32) in - match numerical_to_doubleword base with - | Error e -> Error ("finfo.mk_global_variable" :: e) - | Ok addr -> - let name: string option = - if has_symbolic_address_name addr then - let vname = get_symbolic_address_name addr in - let vtype = get_symbolic_address_type addr in - begin - chlog#add - "make named global variable" - (LBLOCK [ - addr#toPretty; - STR ": "; - STR vname; - STR " with type "; - STR (btype_to_string vtype)]); - Some vname - end - else - None in - let default () = - let var = - self#mk_variable (varmgr#make_global_variable ~size ~offset base) in + let dw = numerical_mod_to_doubleword base in + match memmap#containing_location dw with + | Some gloc -> + let gvar = + self#mk_variable + (self#varmgr#make_global_variable gloc#address#to_numerical) in + let ivar = self#mk_variable (varmgr#make_initial_memory_value gvar) in + if dw#equal gloc#address then begin - (match name with - | Some vname -> - let ivar = self#mk_variable (varmgr#make_initial_memory_value var) in - begin - self#set_variable_name var vname; - self#set_variable_name ivar (vname ^ "_in") - end - | _ -> ()); - Ok var - end in - - if is_in_global_structvar addr then - (match get_structvar_base_offset addr with - | Some (base, off) -> - let basename = get_symbolic_address_name base in - (match off with - | Field ((fname, fckey), NoOffset) -> - let cinfo = bcfiles#get_compinfo fckey in - let finfo = get_compinfo_field cinfo fname in - let finfotype = resolve_type finfo.bftype in - (match finfotype with - | Error _ -> default () - | Ok finfotype -> - let foffset = - if is_struct_type finfotype then - let subcinfo = get_struct_type_compinfo finfotype in - let subfield0 = List.hd subcinfo.bcfields in - let suboffset = - FieldOffset - ((subfield0.bfname, subfield0.bfckey), NoOffset) in - FieldOffset ((fname, fckey), suboffset) - else - FieldOffset ((fname, fckey), NoOffset) in - let var = - self#mk_variable - (varmgr#make_global_variable - ~offset:foffset base#to_numerical) in - let vname = basename ^ (memory_offset_to_string foffset) in - let _ = self#set_variable_name var vname in - Ok var) - | _ -> - default ()) - | _ -> - default ()) - else if is_in_global_arrayvar addr then - (match get_arrayvar_base_offset addr with - | Some (base, off, _) -> - let basename = get_symbolic_address_name base in - let basevar = - self#mk_variable (varmgr#make_global_variable base#to_numerical) in - let _ = self#set_variable_name basevar basename in - (match off with - | Index (Const (CInt (i64, _, _)), _) -> - let cindex = mkNumericalFromInt64 i64 in - let ioffset = ConstantOffset (cindex, NoOffset) in - let var = - self#mk_variable - (varmgr#make_global_variable - ~offset:ioffset base#to_numerical) in - let ivar = - self#mk_initial_memory_value var in - let vname = basename ^ (memory_offset_to_string ioffset) in - let ivname = vname ^ "_in" in - let _ = self#set_variable_name var vname in - let _ = self#set_variable_name ivar ivname in - let _ = - chlog#add - "array element variable" - (LBLOCK [ - addr#toPretty; - STR ": "; - var#toPretty; - STR ": "; - STR vname]) in - Ok var - | _ -> - default ()) - | _ -> - default ()) + self#set_variable_name gvar gloc#name; + self#set_variable_name ivar (gloc#name ^ "_in"); + Ok gvar + end else - default () - - method mk_global_memory_address - ?(optname = None) ?(opttype=None) (n: numerical_t) = - self#mk_variable (varmgr#make_global_memory_address ~optname ~opttype n) + tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": memref:global") + (fun offset -> + let gvar = + self#mk_variable + (self#varmgr#make_global_variable + ~size ~offset gloc#address#to_numerical) in + let ivar = self#mk_variable (varmgr#make_initial_memory_value gvar) in + let name = gloc#name ^ (memory_offset_to_string offset) in + begin + self#set_variable_name gvar name; + self#set_variable_name ivar (name ^ "_in"); + gvar + end) + (gloc#address_memory_offset ~tgtbtype:btype (num_constant_expr base)) + | _ -> + let _ = memmap#add_location ~size:(Some size) ~btype dw in + Ok (self#mk_variable (self#varmgr#make_global_variable dw#to_numerical)) method mk_register_variable (register:register_t) = self#mk_variable (varmgr#make_register_variable register) @@ -1042,6 +976,10 @@ object (self) method mk_return_value (address:ctxt_iaddress_t) = self#mk_variable (varmgr#make_return_value address) + method mk_typecast_value + (iaddr: ctxt_iaddress_t) (name: string) (ty: btype_t) (reg: register_t) = + self#mk_variable (varmgr#make_typecast_value iaddr name ty reg) + method mk_function_pointer_value (fname:string) (cname:string) (address:ctxt_iaddress_t) = self#mk_variable (varmgr#make_function_pointer_value fname cname address) @@ -1081,28 +1019,20 @@ object (self) self#set_variable_name iv (vname ^ "_in") in if is_ptrto_known_struct vtype then self#set_pointedto_struct_field_names 1 iv vname vtype) - ~error:(fun _ -> ()) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) (varmgr#get_global_variable_address v) - method mk_initial_memory_value (v:variable_t):variable_t = + method mk_initial_memory_value (v:variable_t):variable_t traceresult = if (self#is_memory_variable v) && (self#has_constant_offset v) then let iv = self#mk_variable (varmgr#make_initial_memory_value v) in let _ = if varmgr#is_global_variable v then self#probe_global_var_field_values v iv in - iv + Ok iv else - let msg = - (LBLOCK [ - STR "variable is not suitable for initial memory variable: "; - v#toPretty; - STR " ("; - faddr#toPretty; - STR ")"]) in - begin - ch_error_log#add "function environment" msg; - raise (BCH_failure msg) - end + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not suitable for initial memory value: " + ^ v#getName#getBaseName] method mk_initial_register_value ?(level=0) (r:register_t) = self#mk_variable (varmgr#make_initial_register_value r level) @@ -1112,38 +1042,32 @@ object (self) method private nested_exprs_in_var (v: variable_t): xpr_t list = if self#is_symbolic_value v then - log_tfold - (log_error "nested_exprs_in_var" "invalid symbolic value") - ~ok:(fun x -> - let _ = - chlog#add - "nested exprs in var" - (LBLOCK [v#toPretty; STR ": "; x2p x]) in - [x]) - ~error:(fun _ -> []) + TR.tfold + ~ok:(fun x -> [x]) + ~error:(fun e -> + begin + log_error_result + ~msg:("invalid symbolic value: " ^ v#getName#getBaseName) + __FILE__ __LINE__ e; + [] + end) (self#get_symbolic_value_expr v) - else if self#is_global_variable v then - log_tfold - (log_error "nested_exprs_in_var" "invalid offset") + else if self#is_memory_variable v then + TR.tfold ~ok:(fun memoff -> - match memoff with - | ConstantOffset (_, IndexOffset (indexvar, _, _)) -> - let _ = - chlog#add - "nested exprs in var" - (LBLOCK [v#toPretty; STR ": "; indexvar#toPretty]) in - [XVar indexvar] - | _ -> []) - ~error:(fun _ -> []) + List.map (fun v -> XVar v) (get_index_offset_variables memoff)) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + [] + end) (self#get_memvar_offset v) else [] method variables_in_expr (expr: xpr_t): variable_t list = - let s = new VariableCollections.set_t in - let rec vs x = match x with | XVar v -> @@ -1160,24 +1084,8 @@ object (self) s#toList end - method has_initialized_call_target_value (v:variable_t) = - H.mem initial_call_target_values v#getName#getSeqNumber - - method get_initialized_call_target_value (v:variable_t) = - let index = v#getName#getSeqNumber in - if H.mem initial_call_target_values index then - H.find initial_call_target_values index - else - raise - (BCH_failure - (LBLOCK [ - STR "initialized call target value not found for "; - v#toPretty; - STR " in "; - faddr#toPretty])) - method has_initialized_string_value (v:variable_t) (offset:int) = - H.mem initial_string_values (v#getName#getSeqNumber,offset) + H.mem initial_string_values (v#getName#getSeqNumber, offset) method get_initialized_string_value (v:variable_t) (offset:int) = let index = v#getName#getSeqNumber in @@ -1218,7 +1126,9 @@ object (self) (BCH_failure (LBLOCK [STR "No virtual target found for "; v#toPretty])) - method get_frozen_variable (v: variable_t) = + method get_frozen_variable + (v: variable_t): + (variable_t * ctxt_iaddress_t * ctxt_iaddress_t) traceresult = varmgr#get_frozen_variable v method private get_register_variables = @@ -1265,10 +1175,13 @@ object (self) method get_stack_parameter_index (v: variable_t): int option = if self#is_initial_memory_value v then - log_tfold - (log_error "get_stack_parameter_index" "invalid initial value") + TR.tfold ~ok:(fun iv -> varmgr#get_stack_parameter_index iv) - ~error:(fun _ -> None) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + None + end) (varmgr#get_initial_memory_value_variable v) else varmgr#get_stack_parameter_index v @@ -1288,41 +1201,50 @@ object (self) method get_memval_offset (v:variable_t): memory_offset_t traceresult = varmgr#get_memval_offset v - method get_constant_offsets (v: variable_t): numerical_t list option = + method get_constant_offsets (v: variable_t): numerical_t list traceresult = let offset_r = if self#is_initial_memory_value v then self#get_memval_offset v else if self#is_memory_variable v then self#get_memvar_offset v else - Error ["get_constant_offsets: " ^ v#getName#getBaseName] in - log_tfold - (log_error "get_constant_offsets" "invalid offset or variable") - ~ok:(fun offset -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a memory variable or initial memory value: " + ^ v#getName#getBaseName] in + TR.tbind + (fun offset -> if is_constant_offset offset then - Some (get_constant_offsets offset) + get_constant_offsets offset else - None) - ~error:(fun _ -> None) + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable does not have constant offset: " + ^ (p2s v#toPretty)]) offset_r - method get_total_constant_offset (v:variable_t) = - match self#get_constant_offsets v with - | Some l -> Some (List.fold_left (fun acc n -> acc#add n) numerical_zero l) - | _ -> None + method get_total_constant_offset (v:variable_t): numerical_t traceresult = + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (List.fold_left (fun acc n -> acc#add n) numerical_zero) + (self#get_constant_offsets v) - method get_calltarget_value = varmgr#get_calltarget_value + method get_calltarget_value (v: variable_t): call_target_t traceresult = + varmgr#get_calltarget_value v - method get_register = varmgr#get_register + method get_register (v: variable_t): register_t traceresult = + varmgr#get_register v - method get_pointed_to_function_name = varmgr#get_pointed_to_function_name + method get_pointed_to_function_name (v: variable_t): string traceresult = + varmgr#get_pointed_to_function_name v - method get_call_site = varmgr#get_call_site + method get_call_site (v: variable_t): ctxt_iaddress_t traceresult = + varmgr#get_call_site v - method get_se_argument_descriptor = varmgr#get_se_argument_descriptor + method get_se_argument_descriptor (v: variable_t): string traceresult = + varmgr#get_se_argument_descriptor v - method get_global_sideeffect_target_address = - varmgr#get_global_sideeffect_target_address + method get_global_sideeffect_target_address (v: variable_t): doubleword_result = + varmgr#get_global_sideeffect_target_address v method is_global_sideeffect = varmgr#is_global_sideeffect @@ -1353,24 +1275,24 @@ object (self) if varmgr#has_global_variable_address v then varmgr#get_global_variable_address v else - Error [ - "env#get_global_variable_address: " - ^ "no constant numerical offset: " - ^ v#getName#getBaseName] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No constant numerical offset: " + ^ v#getName#getBaseName] else if varmgr#is_initial_memory_value v then tbind - ~msg:("env#get_global_variable_address: invalid initial_memory_value") + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun ivar -> if varmgr#has_global_variable_address ivar then self#get_global_variable_address ivar else - Error ["env#get_global_variable_address: not a constant offset"]) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a constant offset: " + ^ v#getName#getBaseName]) (varmgr#get_initial_memory_value_variable v) else - Error [ - "env#get_global_variable_address: " - ^ "not a global variable or initial-value global variable: " - ^ v#getName#getBaseName] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a global variable or initial-value global variable: " + ^ v#getName#getBaseName] method is_volatile_variable (v: variable_t) = if varmgr#has_global_variable_address v then @@ -1389,46 +1311,50 @@ object (self) method get_optreturn_value_capabilities (var: variable_t): (ctxt_iaddress_t * type_cap_label_t list) option = + let memvar_caps (v: variable_t) = + match self#get_optreturn_value_capabilities v with + | Some (callsite, labels) -> + tfold_default + (fun offset -> + if is_constant_offset offset then + tfold_default + (fun num -> + Some (callsite, + Load :: (OffsetAccess (4, num#toInt)) :: labels)) + None + (get_total_constant_offset offset) + else + None) + None + (self#get_memvar_offset v) + | _ -> None in + + let memval_caps (v: variable_t) = + match self#get_optreturn_value_capabilities v with + | Some (callsite, labels) -> + tfold_default + (fun offset -> + if is_constant_offset offset then + tfold_default + (fun num -> + Some (callsite, + Load :: (OffsetAccess (4, num#toInt)) :: labels)) + None + (get_total_constant_offset offset) + else + None) + None + (self#get_memval_offset v) + | _ -> None in + let aux (v: variable_t) = if self#is_return_value v then tfold_default (fun callsite -> Some (callsite, [])) None (self#get_call_site v) else if self#is_basevar_memory_variable v then - tfold_default - (fun var -> - match self#get_optreturn_value_capabilities var with - | Some (callsite, labels) -> - tfold_default - (fun offset -> - if is_constant_offset offset then - let num = get_total_constant_offset offset in - Some - (callsite, Load :: (OffsetAccess (4, num#toInt)) :: labels) - else - None) - None - (self#get_memvar_offset v) - | _ -> None) - None - (self#get_memvar_basevar v) + tfold_default memvar_caps None (self#get_memvar_basevar v) else if self#is_basevar_memory_value v then - tfold_default - (fun var -> - match self#get_optreturn_value_capabilities var with - | Some (callsite, labels) -> - tfold_default - (fun offset -> - if is_constant_offset offset then - let num = get_total_constant_offset offset in - Some - (callsite, Load :: (OffsetAccess (4, num#toInt)) :: labels) - else - None) - None - (self#get_memval_offset v) - | _ -> None) - None - (self#get_memval_basevar v) + tfold_default memval_caps None (self#get_memval_basevar v) else None in @@ -1448,8 +1374,6 @@ object (self) method is_basevar_memory_value = varmgr#is_basevar_memory_value - method is_memory_address_variable = varmgr#is_memory_address_variable - method is_calltarget_value = varmgr#is_calltarget_value method has_constant_offset (v:variable_t) = varmgr#has_constant_offset v @@ -1484,64 +1408,74 @@ object (self) (varmgr#get_initial_memory_value_variable v)) method private get_argbasevar_with_offsets_aux - (v:variable_t) (offsets:numerical_t list) = + (v:variable_t) + (offsets:numerical_t list): + (variable_t * numerical_t list) option = if self#is_initial_memory_value v then - log_tfold - (log_error "get_argbasevar_with_offsets_aux" "invalid memory variable") + TR.tfold ~ok:(fun iv -> if self#is_basevar_memory_variable iv then - log_tfold - (log_error "get_argbasevar_with_offsets_aux" "invalid base var") + TR.tfold ~ok:(fun basevar -> - match self#get_total_constant_offset iv with - | Some o -> - let newoffsets = o :: offsets in - if self#is_stack_parameter_variable basevar || - self#is_initial_register_value basevar then - Some (basevar, newoffsets) - else - self#get_argbasevar_with_offsets_aux basevar newoffsets - | _ -> None) - ~error:(fun _ -> None) + TR.tfold + ~ok:(fun o -> + let newoffsets = o :: offsets in + if self#is_stack_parameter_variable basevar || + self#is_initial_register_value basevar then + Some (basevar, newoffsets) + else + self#get_argbasevar_with_offsets_aux basevar newoffsets) + ~error:(fun e -> + begin self#log_dc_error_result __LINE__ e; None end) + (self#get_total_constant_offset iv)) + ~error:(fun e -> + begin self#log_dc_error_result __LINE__ e; None end) (self#get_memvar_basevar iv) else None) - ~error:(fun _ -> None) + ~error:(fun e -> + begin self#log_dc_error_result __LINE__ e; None end) (varmgr#get_initial_memory_value_variable v) else None - method get_argbasevar_with_offsets (v:variable_t) = + method get_argbasevar_with_offsets + (v:variable_t): (variable_t * numerical_t list) option = self#get_argbasevar_with_offsets_aux v [] method private get_globalbasevar_with_offsets_aux - (v:variable_t) (offsets:numerical_t list) = + (v:variable_t) + (offsets:numerical_t list): + (variable_t * numerical_t list) option = if self#is_initial_memory_value v then - log_tfold - (log_error "get_globalbasevar_with_offsets_aux" "invalid memory variable") + TR.tfold ~ok:(fun iv -> if self#is_basevar_memory_variable iv then - log_tfold - (log_error "get_globalbasevar_with_offsets_aux" "invalid basevar") + TR.tfold ~ok:(fun basevar -> - match self#get_total_constant_offset iv with - | Some o -> - let newoffsets = o :: offsets in - if self#is_global_variable basevar then - Some (basevar, newoffsets) - else - self#get_globalbasevar_with_offsets_aux basevar newoffsets - | _ -> None) - ~error:(fun _ -> None) + TR.tfold + ~ok:(fun o -> + let newoffsets = o :: offsets in + if self#is_global_variable basevar then + Some (basevar, newoffsets) + else + self#get_globalbasevar_with_offsets_aux basevar newoffsets) + ~error:(fun e -> + begin self#log_dc_error_result __LINE__ e; None end) + (self#get_total_constant_offset iv)) + ~error:(fun e-> + begin self#log_dc_error_result __LINE__ e; None end) (self#get_memvar_basevar iv) else None) - ~error:(fun _ -> None) + ~error:(fun e -> + begin self#log_dc_error_result __LINE__ e; None end) (varmgr#get_initial_memory_value_variable v) else None - method get_globalbasevar_with_offsets (v:variable_t) = + method get_globalbasevar_with_offsets + (v:variable_t): (variable_t * numerical_t list) option = self#get_globalbasevar_with_offsets_aux v [] method is_return_value = varmgr#is_return_value @@ -1570,7 +1504,8 @@ object (self) varmgr#get_initial_memory_value_variable v else if self#is_initial_register_value v then tbind - ~msg:("finfo:get_init_value_variable: " ^ v#getName#getBaseName) + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ v#getName#getBaseName) (fun iv -> match iv with | CPURegister r -> Ok (self#mk_cpu_register_variable r) @@ -1582,14 +1517,14 @@ object (self) | PowerGPRegister i -> Ok (self#mk_pwr_gp_register_variable i) | PowerSPRegister r -> Ok (self#mk_pwr_sp_register_variable r) | _ -> - Error [ - "finfo:get_init_value_variable: not a cpu/mips/arm/pwr register: " - ^ v#getName#getBaseName]) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a cpu/mips/arm/pwr initial register value: " + ^ v#getName#getBaseName]) (self#get_initial_register_value_register v) else - Error [ - "finfo:get_init_value_variable: variable is not an initial value: " - ^ v#getName#getBaseName] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not an initial value: " + ^ v#getName#getBaseName] method get_initial_register_value_register (v:variable_t): register_t traceresult = @@ -1605,7 +1540,8 @@ object (self) if self#is_symbolic_value v then varmgr#get_symbolic_value_expr v else - Error ["finfo:get_symbolic_value_expr: " ^ v#getName#getBaseName] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a symbolic value expr: " ^ v#getName#getBaseName] method is_in_test_jump_range (v: variable_t) (a: ctxt_iaddress_t) = (varmgr#is_in_test_jump_range a v) @@ -1637,7 +1573,7 @@ object (self) val constant_table = new VariableCollections.table_t (* constants *) val calltargets = H.create 5 (* call-targets *) - val mutable base_pointers = new VariableCollections.set_t (* base-pointers *) + val base_pointers = new VariableCollections.set_t (* base-pointers *) val mutable stack_adjustment = None (* stack-adjustment *) val saved_registers = H.create 3 (* saved-registers -- not read *) @@ -1645,7 +1581,7 @@ object (self) val test_expressions = H.create 3 (* test-expressions *) val test_variables = H.create 3 (* test-variables *) - val cvariable_types = H.create 3 (* types of constant-value variables *) + (* val cvariable_types = H.create 3 *) (* types of constant-value variables *) (* ------------------------------------------------------------------------- *) @@ -1655,8 +1591,7 @@ object (self) val instrbytes = H.create 5 val jump_targets = H.create 5 (* to be saved *) - val return_values = H.create 3 - val sideeffects = H.create 3 (* iaddr -> sideeffect-ix *) + val mutable nonreturning = false val mutable user_summary = None (* to be deprecated *) val mutable appsummary = @@ -1678,6 +1613,15 @@ object (self) (* ------------------------------------------------------------------------- *) + method private log_dc_error_result (line: int) (e: string list) = + if BCHSystemSettings.system_settings#collect_data then + self#log_error_result line e + else + () + + method private log_error_result (line: int) (e: string list) = + log_error_result ~msg:self#a#to_hex_string __FILE__ line e + method stackframe = stackframe method xpod = self#proofobligations#xpod @@ -1699,48 +1643,6 @@ object (self) STR " in function "; faddr#toPretty])) - method set_btype (v: variable_t) (ty: btype_t) = - let vix = v#getName#getSeqNumber in - let bix = bcd#index_typ ty in - let entry: int list = - if H.mem cvariable_types vix then - H.find cvariable_types vix - else - [] in - if List.mem bix entry then - () - else - H.replace cvariable_types vix (bix :: entry) - - method has_btype (v: variable_t): bool = - let vix = v#getName#getSeqNumber in - H.mem cvariable_types vix - - method get_btype (v: variable_t): btype_t = - let vix = v#getName#getSeqNumber in - if H.mem cvariable_types vix then - let btypes = List.map bcd#get_typ (H.find cvariable_types vix) in - btype_join btypes - else - TUnknown [] - - method get_btypes (v: variable_t): btype_t list = - let vix = v#getName#getSeqNumber in - if H.mem cvariable_types vix then - List.map bcd#get_typ (H.find cvariable_types vix) - else - [] - - method get_btype_table: (int * int * int list) list = - let result = ref [] in - let _ = - H.iter (fun vix bixs -> - let btypes = List.map bcd#get_typ bixs in - let jbtype = btype_join btypes in - let entry = (vix, bcd#index_typ jbtype, bixs) in - result := entry :: !result) cvariable_types in - !result - method sideeffects_changed = sideeffects_changed method call_targets_were_set = call_targets_set @@ -1749,6 +1651,8 @@ object (self) method a = faddr + method get_function_data = functions_data#get_function self#get_address + method env = env method finv = invio @@ -1864,38 +1768,32 @@ object (self) method save_register (vmem: variable_t) (iaddr:ctxt_iaddress_t) (reg:register_t) = if self#env#is_stack_variable vmem then - log_tfold - (log_error "save_register" "invalid offset") + TR.tfold ~ok:(fun offset -> match offset with | ConstantOffset (n, NoOffset) -> self#stackframe#add_register_spill ~offset:n#toInt reg iaddr | _ -> - ch_error_log#add - "save_register:no offset" - (LBLOCK [ - self#get_address#toPretty; - STR " "; - STR iaddr; - STR ": "; - vmem#toPretty; - STR " ("; - STR (register_to_string reg); - STR ")"])) - ~error:(fun _ -> ()) + log_error_result + ~msg:"save_register:not a constant offset" + __FILE__ __LINE__ + ["(" ^ (p2s self#get_address#toPretty) ^ "," ^ iaddr ^ "): "; + (p2s vmem#toPretty) ^ " with " ^ (register_to_string reg) + ^ " and offset " ^ (memory_offset_to_string offset)]) + ~error:(fun e -> + log_error_result + ~msg:"save_register" + __FILE__ __LINE__ + (["(" ^ (p2s self#get_address#toPretty) ^ "," ^ iaddr ^ "): "; + (p2s vmem#toPretty) ^ " with " ^ (register_to_string reg)] @ e)) (self#env#get_memvar_offset vmem) else - ch_error_log#add - "save_register:not a stack variable" - (LBLOCK [ - self#get_address#toPretty; - STR " "; - STR iaddr; - STR ": "; - vmem#toPretty; - STR " ("; - STR (register_to_string reg); - STR ")"]) + log_error_result + ~msg:"save register:not a stack variable" + __FILE__ __LINE__ + ["(" ^ (p2s self#get_address#toPretty) ^ "," ^ iaddr ^ "): "; + "not a stack variable: " + ^ (p2s vmem#toPretty) ^ " with " ^ (register_to_string reg)] method restore_register (memaddr: xpr_t) (iaddr:ctxt_iaddress_t) (reg:register_t) = @@ -1906,95 +1804,30 @@ object (self) | XConst (IntConst n) -> self#stackframe#add_register_restore ~offset:n#neg#toInt reg iaddr | _ -> - ch_error_log#add - "restore_register:no offset" - (LBLOCK [ - self#get_address#toPretty; - STR " "; - STR iaddr; - STR ": "; - x2p memaddr; - STR " ("; - STR (register_to_string reg); - STR ")"]) + log_error_result + ~msg:"restore register:not a constant offset" + __FILE__ __LINE__ + ["(" ^ (p2s self#get_address#toPretty) ^ "," ^ iaddr ^ ")"; + (x2s memaddr)] else - ch_error_log#add - "restore_register:not an initial value" - (LBLOCK [ - self#get_address#toPretty; - STR " "; - STR iaddr; - STR ": "; - x2p memaddr; - STR " ("; - STR (register_to_string reg); - STR ")"]) + () | _ -> - ch_error_log#add - "restore_register:not a stack address" - (LBLOCK [ - self#get_address#toPretty; - STR " "; - STR iaddr; - STR ": "; - x2p memaddr; - STR " ("; - STR (register_to_string reg); - STR ")"]) + () method saved_registers_to_pretty = let p = ref [] in let _ = - H.iter (fun _ s -> p := (LBLOCK [ s#toPretty ; NL ]) :: !p) saved_registers in + H.iter (fun _ s -> p := (LBLOCK [s#toPretty; NL]) :: !p) saved_registers in match !p with [] -> - LBLOCK [ STR (string_repeat "~" 80) ; NL ; STR "No saved registers" ; NL ; - STR (string_repeat "~" 80) ; NL ] + LBLOCK [ + STR (string_repeat "~" 80); NL; STR "No saved registers"; NL; + STR (string_repeat "~" 80); NL] | l -> - LBLOCK [ STR "Saved Registers" ; NL ; STR (string_repeat "~" 80) ; NL ; - LBLOCK l ; NL ; - STR (string_repeat "~" 80) ; NL] - - (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * - * record return values * - * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) - - method record_return_value (iaddr:ctxt_iaddress_t) (x:xpr_t) = - H.replace return_values iaddr x - - method get_return_values = H.fold (fun _ x a -> x :: a) return_values [] - - method return_values_to_pretty = - let p = ref [] in - let _ = H.iter (fun iaddr x -> - let pp = LBLOCK [ STR iaddr ; STR ": " ; pr_expr x ; NL ] in - p := pp :: !p ) return_values in - LBLOCK [ STR "Return values: (" ; INT (H.length return_values) ; STR ")" ; NL ; - INDENT (3, LBLOCK !p) ; NL ] - - (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * - * record side effects * - * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) - - method record_sideeffect (iaddr: ctxt_iaddress_t) (s: xxpredicate_t) = - let index = id#index_xxpredicate s in - if H.mem sideeffects iaddr then - let prev_ix = H.find sideeffects iaddr in - if index = prev_ix then - () - else - begin - H.replace sideeffects iaddr index; - sideeffects_changed <- true - end - else - begin - H.add sideeffects iaddr index; - sideeffects_changed <- true; - chlog#add - "sideeffects changed" - (LBLOCK [self#a#toPretty; STR ": "; xxpredicate_to_pretty s]) - end + LBLOCK [ + STR "Saved Registers"; NL; STR (string_repeat "~" 80); NL; + LBLOCK l; NL; + STR (string_repeat "~" 80); NL] method set_nonreturning = if nonreturning then () else @@ -2015,7 +1848,14 @@ object (self) method set_bc_summary (fs: function_summary_int) = begin appsummary <- fs; - env#set_argument_names fs#get_function_interface + env#set_argument_names fs#get_function_interface; + chlog#add + "set-bc-summary" + (LBLOCK [ + function_interface_to_pretty fs#get_function_interface; + STR " with function signature "; + STR (btype_to_string + fs#get_function_interface.fintf_type_signature.fts_returntype)]) end method read_xml_user_summary (node:xml_element_int) = @@ -2223,8 +2063,6 @@ object (self) * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) method add_base_pointer (var:variable_t) = - let _ = track_function - self#a (LBLOCK [ STR "add base pointer: " ; var#toPretty ]) in base_pointers#add var method get_base_pointers = base_pointers#toList @@ -2656,27 +2494,50 @@ let load_finfo_userdata (finfo: function_info_int) (faddr: doubleword_int) = | Some node -> finfo#read_xml_user_summary node | _ -> - let fname = - if functions_data#has_function_name faddr then - (functions_data#get_function faddr)#get_function_name + if functions_data#has_function_name faddr then + let fname = (functions_data#get_function faddr)#get_function_name in + if bcfiles#has_varinfo fname then + let vinfo = bcfiles#get_varinfo fname in + let bcsum = function_summary_of_bvarinfo vinfo in + begin + finfo#set_bc_summary bcsum; + chlog#add + "bc-function-summary" + (LBLOCK [ + STR fname; + STR ": "; + function_interface_to_pretty bcsum#get_function_interface]) + end else + () + else + let fname = let hexfaddr = faddr#to_hex_string in let lenfaddr = String.length hexfaddr in "sub_" ^ (String.sub (faddr#to_hex_string) 2 (lenfaddr - 2)) in - if bcfiles#has_varinfo fname then - let vinfo = bcfiles#get_varinfo fname in - let bcsum = function_summary_of_bvarinfo vinfo in - begin - finfo#set_bc_summary bcsum; - chlog#add - "bc-function-summary" - (LBLOCK [ - STR fname; - STR ": "; - function_interface_to_pretty bcsum#get_function_interface]) - end - else - () + if bcfiles#has_varinfo ~prefix:true fname then + let vinfo = bcfiles#get_varinfo ~prefix:true fname in + let bcsum = function_summary_of_bvarinfo vinfo in + begin + (if not (vinfo.bvname = fname) then + if functions_data#has_function faddr then + let fndata = functions_data#get_function faddr in + begin + fndata#add_name vinfo.bvname; + chlog#add + "bc-function-summary (update name)" + (LBLOCK [STR vinfo.bvname; STR " from "; STR fname]) + end); + finfo#set_bc_summary bcsum; + chlog#add + "bc-function-summary" + (LBLOCK [ + STR vinfo.bvname; + STR ": "; + function_interface_to_pretty bcsum#get_function_interface]) + end + else + () let load_function_info ?(reload=false) (faddr:doubleword_int) = diff --git a/CodeHawk/CHB/bchlib/bCHFunctionSummaryLibrary.ml b/CodeHawk/CHB/bchlib/bCHFunctionSummaryLibrary.ml index 695e8191..c1d742cf 100644 --- a/CodeHawk/CHB/bchlib/bCHFunctionSummaryLibrary.ml +++ b/CodeHawk/CHB/bchlib/bCHFunctionSummaryLibrary.ml @@ -40,7 +40,6 @@ open CHXmlDocument (* bchlib *) open BCHBasicTypes open BCHBCFiles -open BCHConstantDefinitions open BCHBCTypeXml open BCHDemangler open BCHFunctionSummary @@ -342,10 +341,10 @@ object (self) let root = doc#getRoot in if root#hasOneTaggedChild "symbolic-constants" then let node = root#getTaggedChild "symbolic-constants" in - read_xml_symbolic_constants node + BCHConstantDefinitions.read_xml_symbolic_constants node else if root#hasOneTaggedChild "symbolic-flags" then let node = root#getTaggedChild "symbolic-flags" in - read_xml_symbolic_flags node + BCHConstantDefinitions.read_xml_symbolic_flags node else raise (BCH_failure diff --git a/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.ml b/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.ml new file mode 100644 index 00000000..a294ce51 --- /dev/null +++ b/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.ml @@ -0,0 +1,886 @@ +(* ============================================================================= + CodeHawk Binary Analyzer + Author: Henny Sipma + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2024 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 + 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 CHPretty + +(* chutil *) +open CHLogger +open CHTraceResult +open CHXmlDocument + +(* xprlib *) +open Xprt +open XprTypes + +(* bchlib *) +open BCHBasicTypes +open BCHBCTypePretty +open BCHBCTypes +open BCHBCTypeUtil +open BCHDoubleword +open BCHLibTypes + +module H = Hashtbl +module TR = CHTraceResult + +let x2p = XprToPretty.xpr_formatter#pr_expr +let p2s = CHPrettyUtil.pretty_to_string +let x2s x = p2s (x2p x) + +let bcd = BCHBCDictionary.bcdictionary + + +let globalvalue_to_pretty (gv: globalvalue_t): pretty_t = + match gv with + | GConstantString s -> STR s + | GScalarValue dw -> dw#toPretty + + +let _global_location_ref_to_pretty (gref: global_location_ref_t): pretty_t = + match gref with + | GLoad (gaddr, iaddr, gxpr, size, signed) -> + LBLOCK [ + STR "load: "; + gaddr#toPretty; STR ", "; + STR iaddr; STR " "; + x2p gxpr; + STR " "; + INT size; + (if signed then STR " (signed)" else STR "") + ] + | GStore (gaddr, iaddr, gxpr, size, _optvalue) -> + LBLOCK [ + STR "store: "; + gaddr#toPretty; STR ", "; + STR iaddr; + STR " "; + x2p gxpr; + STR " "; + INT size] + | GAddressArgument (gaddr, iaddr, argindex, gxpr, btype, memoff) -> + LBLOCK [ + STR "addr-arg: "; + gaddr#toPretty; STR ", "; + STR iaddr; + STR " ("; + INT argindex; + STR ") "; + x2p gxpr; + (if is_unknown_type btype then + STR "" + else + LBLOCK [STR " "; STR (btype_to_string btype)]); + (match memoff with + | Some NoOffset -> STR "" + | Some memoff -> + LBLOCK [ + STR " ("; BCHMemoryReference.memory_offset_to_pretty memoff; STR ")"] + | _ -> STR "") + ] + + +let global_location_rec_to_pretty (grec: global_location_rec_t): pretty_t = + LBLOCK [ + STR "addr: "; grec.gloc_address#toPretty; NL; + STR "name: "; STR grec.gloc_name; NL; + STR "type: "; STR (btype_to_string grec.gloc_btype); NL; + (match grec.gloc_size with + | Some s -> LBLOCK [STR "size: "; INT s; NL] + | _ -> STR ""); + (match grec.gloc_initialvalue with + | Some init -> LBLOCK [STR "init: "; globalvalue_to_pretty init; NL] + | _ -> STR ""); + (match grec.gloc_desc with + | Some desc -> LBLOCK [STR "desc: "; STR desc; NL] + | _ -> STR ""); + (if grec.gloc_is_readonly then LBLOCK [STR "readonly"; NL] else STR ""); + (if grec.gloc_is_initialized then LBLOCK [STR "initialized"; NL] else STR "") + ] + + +class global_location_t (grec: global_location_rec_t): global_location_int = +object (self) + + method grec: global_location_rec_t = grec + + method name: string = grec.gloc_name + + method address: doubleword_int = grec.gloc_address + + method btype: btype_t = grec.gloc_btype + + method is_struct: bool = + match resolve_type self#btype with + | Ok (TComp _) -> true + | _ -> false + + method is_array: bool = + match resolve_type self#btype with + | Ok (TArray _) -> true + | _ -> false + + method is_typed: bool = not (btype_equal self#btype t_unknown) + + method size: int option = grec.gloc_size + + method is_readonly: bool = grec.gloc_is_readonly + + method is_initialized: bool = grec.gloc_is_initialized + + method contains_address (addr: doubleword_int): bool = + (self#address#equal addr) + || (match self#size with + | Some s -> + addr#index >= self#address#index + && addr#index < (self#address#index + s) + | _ -> false) + + method address_offset (xpr: xpr_t): xpr_t traceresult = + (* xpr = cterm + remainder + addroffset = cterm - gaddr + xpr = addroffset + gaddr + remainder + xproffset = xpr - gaddr = addroffset + remainder *) + let cterm = BCHXprUtil.largest_constant_term xpr in + let remainder = XOp (XMinus, [xpr; num_constant_expr cterm]) in + let remainder = Xsimplify.simplify_xpr remainder in + let addr = numerical_mod_to_doubleword cterm in + let addroffset_r = + if self#contains_address addr then + if self#address#equal addr then + Ok 0 + else + Ok (addr#index - self#address#index) + else + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ "largest constant term: " + ^ addr#to_hex_string + ^ " not known to be part of this location (" + ^ self#address#to_hex_string + ^ ":" + ^ self#name + ^ ")"] in + tmap + (fun offset -> + Xsimplify.simplify_xpr (XOp (XPlus, [remainder; int_constant_expr offset]))) + (addroffset_r) + + method private get_field_memory_offset_at + ~(tgtsize: int option) + ~(tgtbtype: btype_t option) + (c: bcompinfo_t) + (xoffset: xpr_t): memory_offset_t traceresult = + let check_tgttype_compliance (t: btype_t) (s: int) = + match tgtsize, tgtbtype with + | None, None -> true + | Some size, None -> size = s + | None, Some ty -> btype_equal ty t + | Some size, Some ty -> size = s && btype_equal ty t in + let compliance_failure (t: btype_t) (s: int) = + let size_discrepancy size s = + "size discrepancy between tgtsize: " + ^ (string_of_int size) + ^ " and field size: " + ^ (string_of_int s) in + let type_discrepancy ty t = + "type discrepancy between tgttype: " + ^ (btype_to_string ty) + ^ " and field type: " + ^ (btype_to_string t) in + match tgtsize, tgtbtype with + | Some size, Some ty when (size != s) && (not (btype_equal ty t)) -> + (size_discrepancy size s) ^ " and " ^ (type_discrepancy ty t) + | Some size, _ when size != s -> size_discrepancy size s + | _, Some ty when not (btype_equal ty t) -> type_discrepancy ty t + | _ -> "" in + match xoffset with + | XConst (IntConst n) -> + let offset = n#toInt in + let finfos = c.bcfields in + let optfield_r = + List.fold_left (fun acc_r finfo -> + match acc_r with + (* Error has been detected earlier *) + | Error e -> Error e + (* Result has already been determined *) + | Ok (Some _) -> acc_r + (* Still looking for a result *) + | Ok _ -> + match finfo.bfieldlayout with + | None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No field layout for field " ^ finfo.bfname] + | Some (foff, sz) -> + if offset < foff then + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Skipped over field: " + ^ (string_of_int offset)] + else if offset >= (foff + sz) then + Ok None + else + let offset = offset - foff in + tbind + (fun fldtype -> + if offset = 0 + && (is_scalar fldtype) + && (check_tgttype_compliance fldtype sz) then + Ok (Some (FieldOffset + ((finfo.bfname, finfo.bfckey), NoOffset))) + else + if offset = 0 && is_scalar fldtype then + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Scalar type or size is not consistent: " + ^ (compliance_failure fldtype sz)] + else if is_struct_type fldtype then + tmap + (fun suboff -> + Some (FieldOffset + ((finfo.bfname, finfo.bfckey), suboff))) + (self#structvar_memory_offset + ~tgtsize ~tgtbtype fldtype (int_constant_expr offset)) + else if is_array_type fldtype then + tmap + (fun suboff -> + Some (FieldOffset + ((finfo.bfname, finfo.bfckey), suboff))) + (self#arrayvar_memory_offset + ~tgtsize ~tgtbtype fldtype (int_constant_expr offset)) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Nonzero offset: " ^ (string_of_int offset) + ^ " with unstructured field type: " + ^ (btype_to_string fldtype)]) + (resolve_type finfo.bftype)) (Ok None) finfos in + (match optfield_r with + | Error e -> Error e + | Ok (Some offset) -> Ok offset + | Ok None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to find field at offset " ^ (string_of_int offset)]) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ "Unable to determine field for xoffset: " ^ (x2s xoffset)] + + method private structvar_memory_offset + ~(tgtsize: int option) + ~(tgtbtype: btype_t option) + (btype: btype_t) + (xoffset: xpr_t): memory_offset_t traceresult = + match xoffset with + | XConst (IntConst n) when + n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok NoOffset + | XConst (IntConst _) -> + if is_struct_type btype then + let compinfo = get_struct_type_compinfo btype in + (self#get_field_memory_offset_at ~tgtsize ~tgtbtype compinfo xoffset) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ " xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ " xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + + method private arrayvar_memory_offset + ~(tgtsize: int option) + ~(tgtbtype: btype_t option) + (btype: btype_t) + (xoffset: xpr_t): memory_offset_t traceresult = + let iszero x = + match x with + | XConst (IntConst n) -> n#equal CHNumerical.numerical_zero + | _ -> false in + match xoffset with + | XConst (IntConst n) when + n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok NoOffset + | _ -> + if is_array_type btype then + let eltty = get_element_type btype in + tbind + (fun elsize -> + let optindex = BCHXprUtil.get_array_index_offset xoffset elsize in + match optindex with + | None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to extract index from " ^ (x2s xoffset)] + | Some (indexxpr, xrem) when + iszero xrem + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok (ArrayIndexOffset (indexxpr, NoOffset)) + | Some (indexxpr, rem) -> + if (TR.tfold_default is_struct_type false (resolve_type eltty)) then + let eltty = TR.tvalue (resolve_type eltty) ~default:t_unknown in + tbind + (fun suboff -> Ok (ArrayIndexOffset (indexxpr, suboff))) + (self#structvar_memory_offset ~tgtsize ~tgtbtype eltty rem) + else if is_array_type eltty then + tbind + (fun suboff -> Ok (ArrayIndexOffset (indexxpr, suboff))) + (self#arrayvar_memory_offset ~tgtsize ~tgtbtype eltty rem) + else if is_scalar eltty then + if iszero rem then + Ok (ArrayIndexOffset (indexxpr, NoOffset)) + else + let suboff = + let x2index = XOp (XDiv, [rem; int_constant_expr elsize]) in + let x2index = Xsimplify.simplify_xpr x2index in + ArrayIndexOffset (x2index, NoOffset) in + Ok (ArrayIndexOffset (indexxpr, suboff)) + else + Error[__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ "xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype) + ^ "; elementtype: " ^ (btype_to_string eltty)]) + (size_of_btype eltty) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ "xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + + method address_memory_offset + ?(tgtsize=None) + ?(tgtbtype=t_unknown) + (xpr: xpr_t): memory_offset_t traceresult = + tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun xoffset -> + match xoffset with + | XConst (IntConst n) + when n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && is_unknown_type tgtbtype -> + Ok NoOffset + | XConst (IntConst n) + when n#equal CHNumerical.numerical_zero && (not self#is_typed) -> + Ok NoOffset + | XConst (IntConst n) when not self#is_typed -> + Ok (ConstantOffset (n, NoOffset)) + | _ -> + let tgtbtype = + if is_unknown_type tgtbtype then None else Some tgtbtype in + if self#is_struct then + let btype = TR.tvalue (resolve_type self#btype) ~default:t_unknown in + self#structvar_memory_offset ~tgtsize ~tgtbtype btype xoffset + else if self#is_array then + let btype = TR.tvalue (resolve_type self#btype) ~default:t_unknown in + self#arrayvar_memory_offset ~tgtsize ~tgtbtype btype xoffset + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ (btype_to_string self#btype) + ^ " is not known to be a struct or array"]) + (self#address_offset xpr) + + method initialvalue: globalvalue_t option = grec.gloc_initialvalue + + method desc: string option = grec.gloc_desc + + method has_elf_symbol: bool = + match self#desc with + | Some "symbol-table" -> true + | _ -> false + + method write_xml (node: xml_element_int) = + begin + (if is_known_type self#btype then + node#setIntAttribute "tix" (bcd#index_typ self#btype)); + (match self#size with + | Some s -> node#setIntAttribute "size" s + | _ -> ()) + end + +end + + +class global_memory_map_t: global_memory_map_int = +object (self) + + val locations = H.create 51 (* gaddr#ix -> gloc *) + val locreferences = H.create 51 (* faddr#ix -> gref list *) + val namedlocations = H.create 51 (* name -> ix *) + val unconnectedreferences = H.create 51 (* faddr#ix -> gref list *) + val sections = H.create 5 + + method set_section + ~(readonly: bool) + ~(initialized: bool) + (name: string) + (addr: doubleword_int) + (size: doubleword_int) = + let _ = + chlog#add + "globalmemorymap:set_section" + (LBLOCK [ + STR name; + STR ": @"; + addr#toPretty; + STR " ("; + size#toPretty; + STR " bytes)"]) in + H.add sections addr#value (name, size#value, readonly, initialized) + + method private is_initialized (addr: doubleword_int): bool = + H.fold (fun k (_, size, _, initialized) acc -> + if k <= addr#value && addr#value < (k + size) then + initialized + else + acc) sections false + + method private is_readonly (addr: doubleword_int): bool = + H.fold (fun k (_, size, readonly, _) acc -> + if k <= addr#value && addr#value < (k + size) then + readonly + else + acc) sections false + + method private get_section_name (addr: doubleword_int): string option = + H.fold (fun k (name, size, _, _) acc -> + if k <= addr#value && addr#value < (k + size) then + Some name + else + acc) sections None + + method add_location + ?(name = None) + ?(desc = None) + ?(btype = t_unknown) + ?(initialvalue = None) + ?(size = None) + (address: doubleword_int): global_location_int traceresult = + if H.mem locations address#index then + begin + ch_error_log#add + "duplicate global location" + (LBLOCK [ + STR "Global location at address "; + address#toPretty; + STR " already exists"]); + Ok (H.find locations address#index) + end + else + match self#containing_location address with + | Some gloc -> + let msg = + "Global location at address " + ^ address#to_hex_string + ^ " overlaps with " + ^ gloc#name + ^ " (" + ^ gloc#address#to_hex_string + ^ (match gloc#size with + | Some s -> ", size: " ^ (string_of_int s) + | _ -> "") + ^ ")" in + begin + ch_error_log#add "overlapping global location" (STR msg); + Error [msg] + end + | _ -> + let gname = + match name with + | Some name -> name + | _ -> "gv_" ^ address#to_hex_string in + let is_readonly = self#is_readonly address in + let is_initialized = self#is_initialized address in + let section = self#get_section_name address in + let grec = { + gloc_name = gname; + gloc_address = address; + gloc_is_readonly = is_readonly; + gloc_is_initialized = is_initialized; + gloc_section = section; + gloc_btype = btype; + gloc_initialvalue = initialvalue; + gloc_size = size; + gloc_desc = desc + } in + let gloc = new global_location_t grec in + begin + H.add locations address#index gloc; + H.add namedlocations gname address#index; + chlog#add + "global-memory-map:add-location" + (LBLOCK [ + address#toPretty; + STR ": "; + STR gname; + STR ":"; + STR (btype_to_string btype); + STR "; "; + (match size with + | Some s -> LBLOCK [STR " (size: "; INT s; STR ")"] + | _ -> STR ""); + (match section with + | Some name -> LBLOCK [STR " ("; STR name; STR ")"] + | _ -> STR ""); + (if is_readonly then STR " (RO) " else STR ""); + (if is_initialized then STR " (IV) " else STR ""); + (match desc with + | Some desc -> LBLOCK [STR " ("; STR desc; STR ")"] + | _ -> STR "") + ]); + Ok gloc + end + + method private add_global_ref + (faddr: doubleword_int) (gref: global_location_ref_t) = + let entry = + if H.mem locreferences faddr#index then + H.find locreferences faddr#index + else + [] in + H.replace locreferences faddr#index (gref :: entry) + + method private add_unconnected_ref + (faddr: doubleword_int) (gref: global_location_ref_t) = + let entry = + if H.mem unconnectedreferences faddr#index then + H.find unconnectedreferences faddr#index + else + [] in + H.replace unconnectedreferences faddr#index (gref :: entry) + + method add_gload + (faddr: doubleword_int) + (iaddr: ctxt_iaddress_t) + (gxpr: xpr_t) + (size: int) + (signed: bool) = + match self#xpr_containing_location gxpr with + | Some gloc -> + let gload = GLoad (gloc#address, iaddr, gxpr, size, signed) in + self#add_global_ref faddr gload + | _ -> + (match gxpr with + | XConst (IntConst n) -> + let gaddr = numerical_mod_to_doubleword n in + let gload = GLoad (gaddr, iaddr, gxpr, size, signed) in + self#add_unconnected_ref faddr gload + | _ -> + ()) + + method add_gstore + (faddr: doubleword_int) + (iaddr: ctxt_iaddress_t) + (gxpr: xpr_t) + (size: int) + (optvalue: CHNumerical.numerical_t option) = + match self#xpr_containing_location gxpr with + | Some gloc -> + let gstore = GStore (gloc#address, iaddr, gxpr, size, optvalue) in + self#add_global_ref faddr gstore + | _ -> + (match gxpr with + | XConst (IntConst n) -> + let gaddr = numerical_mod_to_doubleword n in + let gstore = GStore (gaddr, iaddr, gxpr, size, optvalue) in + self#add_unconnected_ref faddr gstore + | _ -> ()) + + method add_gaddr_argument + (faddr: doubleword_int) + (iaddr: ctxt_iaddress_t) + (gxpr: xpr_t) + (argindex: int) + (btype: btype_t) = + match self#xpr_containing_location gxpr with + | Some gloc -> + let memoff = TR.to_option (gloc#address_memory_offset gxpr) in + let garg = + GAddressArgument (gloc#address, iaddr, argindex, gxpr, btype, memoff) in + begin + self#add_global_ref faddr garg; + Some gloc + end + | _ -> + (match gxpr with + | XConst (IntConst n) -> + let gaddr = numerical_mod_to_doubleword n in + let garg = + GAddressArgument (gaddr, iaddr, argindex, gxpr, btype, Some NoOffset) in + begin + self#add_unconnected_ref faddr garg; + None + end + | _ -> None) + + method update_named_location + (name: string) (vinfo: bvarinfo_t): global_location_int traceresult = + if self#has_location_with_name name then + let ix = H.find namedlocations name in + let grec = (H.find locations ix)#grec in + let size = TR.to_option (size_of_btype vinfo.bvtype) in + let newgrec = { + grec with + gloc_btype = vinfo.bvtype; + gloc_size = size + } in + let newgloc = new global_location_t newgrec in + begin + H.replace locations ix newgloc; + chlog#add + "global-memory-map:update-location" + (LBLOCK [ + newgrec.gloc_address#toPretty; + STR ": "; + STR newgrec.gloc_name; + STR ":"; + STR (btype_to_string newgrec.gloc_btype); + (match size with + | Some s -> LBLOCK [STR " (size: "; INT s; STR ")"] + | _ -> STR "") + ]); + Ok newgloc + end + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No location found with name " ^ name ^ " in global memory map"] + + method has_location_with_name (name: string) = H.mem namedlocations name + + method has_location (addr: doubleword_int) = H.mem locations addr#index + + method containing_location (addr: doubleword_int): global_location_int option = + H.fold (fun _ gloc acc -> + match acc with + | Some _ -> acc + | _ -> if gloc#contains_address addr then Some gloc else None) + locations None + + method xpr_containing_location (xpr: xpr_t): global_location_int option = + let cterm = BCHXprUtil.largest_constant_term xpr in + let addr = numerical_mod_to_doubleword cterm in + self#containing_location addr + + method get_location (addr: doubleword_int): global_location_int = + if self#has_location addr then + H.find locations addr#index + else + raise + (BCH_failure + (LBLOCK [STR "No location found at address "; addr#toPretty])) + + method get_location_name (addr: doubleword_int): string = + (self#get_location addr)#name + + method get_location_type (addr: doubleword_int): btype_t = + (self#get_location addr)#btype + + method is_global_data_address (addr: doubleword_int): bool = + H.fold (fun k (_, size, _, _) acc -> + if k <= addr#value && addr#value < (k + size) then + true + else + acc) sections false + + method has_elf_symbol (v: doubleword_int): bool = + (H.mem locations v#index) + && (H.find locations v#index)#has_elf_symbol + + method get_elf_symbol (v: doubleword_int): string = + if self#has_elf_symbol v then + (H.find locations v#index)#name + else + raise + (BCH_failure + (LBLOCK [ + STR "Memory location at "; + v#toPretty; + STR " does not have an elf symbol"])) + + method private write_xml_gref + (vard: vardictionary_int) + (node: xml_element_int) + (gref: global_location_ref_t) = + let xd = vard#xd in + let set = node#setAttribute in + let seti = node#setIntAttribute in + let set_size (s: int) = seti "s" s in + let set_gxpr (xpr: xpr_t) = seti "xix" (xd#index_xpr xpr) in + let set_gaddr (a: doubleword_int) = set "g" a#to_hex_string in + let set_iaddr (a: ctxt_iaddress_t) = set "i" a in + let set_btype (t: btype_t) = + if is_known_type t then seti "tix" (bcd#index_typ t) else () in + let set_memoff (o: memory_offset_t option) = + match o with + | Some off -> seti "mix" (vard#index_memory_offset off) + | _ -> () in + match gref with + | GLoad (gaddr, iaddr, gxpr, size, signed) -> + begin + set "t" "L"; + set_gaddr gaddr; + set_gxpr gxpr; + set_iaddr iaddr; + set_size size; + (if signed then set "sg" "yes") + end + | GStore (gaddr, iaddr, gxpr, size, optvalue) -> + begin + set "t" "S"; + set_gaddr gaddr; + set_gxpr gxpr; + set_iaddr iaddr; + set_size size; + (match optvalue with + | Some n -> set "v" n#toString + | _ -> ()) + end + | GAddressArgument (gaddr, iaddr, argindex, gxpr, btype, memoff) -> + begin + set "t" "CA"; + set_gaddr gaddr; + seti "aix" argindex; + set_gxpr gxpr; + set_iaddr iaddr; + set_btype btype; + set_memoff memoff + end + + method write_xml_references + (faddr: doubleword_int) (vard: vardictionary_int) (node: xml_element_int) = + let xlocrefs = xmlElement "location-references" in + let xunconnected = xmlElement "unconnected-references" in + let locrefs = + if H.mem locreferences faddr#index then + H.find locreferences faddr#index + else + [] in + let unconnectedrefs = + if H.mem unconnectedreferences faddr#index then + H.find unconnectedreferences faddr#index + else + [] in + begin + List.iter (fun gref -> + let vnode = xmlElement "gref" in + begin + self#write_xml_gref vard vnode gref; + xlocrefs#appendChildren [vnode] + end) locrefs; + List.iter (fun gref -> + let vnode = xmlElement "gref" in + begin + self#write_xml_gref vard vnode gref; + xunconnected#appendChildren [vnode] + end) unconnectedrefs; + node#appendChildren [xlocrefs; xunconnected] + end + + method write_xml (node: xml_element_int) = + let secnode = xmlElement "sections" in + let locnode = xmlElement "locations" in + begin + (* record sections *) + H.iter (fun ix (name, size, ro, init) -> + let vnode = xmlElement "sec" in + begin + vnode#setAttribute + "a" (TR.tget_ok (index_to_doubleword ix))#to_hex_string; + vnode#setAttribute "name" name; + vnode#setIntAttribute "size" size; + (if ro then vnode#setAttribute "ro" "yes"); + (if init then vnode#setAttribute "init" "yes"); + secnode#appendChildren [vnode] + end) sections; + + (* record locations *) + H.iter (fun _ gloc -> + let vnode = xmlElement "gloc" in + begin + vnode#setAttribute "a" gloc#address#to_hex_string; + vnode#setAttribute "name" gloc#name; + gloc#write_xml vnode; + locnode#appendChildren [vnode] + end) locations; + node#appendChildren [secnode; locnode] + end + +end + + +let global_memory_map = new global_memory_map_t + + +let read_xml_symbolic_addresses (node: xml_element_int) = + let get = node#getAttribute in + let getx t = + let tx = get t in + fail_tvalue + (trerror_record + (STR ("BCHGlobalMemory.read_xml_symbolic_addresses:" ^ tx))) + (string_to_doubleword tx) in + let name = Some (get "name") in + let address = getx "a" in + ignore (global_memory_map#add_location ~name ~desc:(Some "userdata") address) + + +let read_xml_symbolic_addresses (node: xml_element_int) = + List.iter read_xml_symbolic_addresses (node#getTaggedChildren "syma") + + +let update_global_location_type + (vinfo: bvarinfo_t): global_location_int traceresult = + let name = vinfo.bvname in + let mkerror file line = + let msg = + file ^ ":" ^ (string_of_int line) ^ ": " + ^"global location not updated for " ^ name in + Error [msg] in + if global_memory_map#has_location_with_name name then + global_memory_map#update_named_location name vinfo + else if String.length name > 3 && (String.sub name 0 3) = "gv_" then + let index = String.index name '_' in + if String.contains_from name (index + 1) '_' then + let eindex = String.index_from name (index + 1) '_' in + let hex = String.sub name (index + 1) ((eindex - index) - 1) in + let hex = "0x" ^ hex in + let msg = + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Address " ^ hex ^ " in global variable " ^ name ^ " not recognized" in + TR.tbind + ~msg + (fun dw -> + global_memory_map#add_location + ~name:(Some name) + ~desc:(Some "header file") + ~btype: vinfo.bvtype + ~size:(TR.to_option (size_of_btype vinfo.bvtype)) + dw) + (string_to_doubleword hex) + else + mkerror __FILE__ __LINE__ + else + mkerror __FILE__ __LINE__ diff --git a/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.mli b/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.mli new file mode 100644 index 00000000..c14e8977 --- /dev/null +++ b/CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.mli @@ -0,0 +1,48 @@ +(* ============================================================================= + CodeHawk Binary Analyzer + Author: Henny Sipma + ------------------------------------------------------------------------------ + The MIT License (MIT) + + Copyright (c) 2024 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 + 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 CHPretty + +(* chutil *) +open CHXmlDocument + +(* bchlib *) +open BCHBCTypes +open BCHLibTypes + + +val global_memory_map: global_memory_map_int + +val global_location_rec_to_pretty: global_location_rec_t -> pretty_t + + +val read_xml_symbolic_addresses: xml_element_int -> unit + + +val update_global_location_type: + bvarinfo_t -> global_location_int CHTraceResult.traceresult diff --git a/CodeHawk/CHB/bchlib/bCHGlobalState.ml b/CodeHawk/CHB/bchlib/bCHGlobalState.ml index e82edb64..137855ad 100644 --- a/CodeHawk/CHB/bchlib/bCHGlobalState.ml +++ b/CodeHawk/CHB/bchlib/bCHGlobalState.ml @@ -40,7 +40,6 @@ open BCHBasicTypes open BCHBCTypePretty open BCHBCTypes open BCHBCTypeUtil -open BCHConstantDefinitions open BCHDoubleword open BCHLibTypes open BCHPreFileIO @@ -623,8 +622,9 @@ object (self) let vNode = xmlElement "gvar" in begin vNode#setAttribute "a" dw#to_hex_string; - (if has_symbolic_address_name dw then - vNode#setAttribute "name" (get_symbolic_address_name dw)); + (if BCHConstantDefinitions.has_symbolic_address_name dw then + vNode#setAttribute + "name" (BCHConstantDefinitions.get_symbolic_address_name dw)); v#write_xml vNode; vNode end) global_variables#listOfPairs) diff --git a/CodeHawk/CHB/bchlib/bCHLibTypes.mli b/CodeHawk/CHB/bchlib/bCHLibTypes.mli index 9342eb43..46fc7c53 100644 --- a/CodeHawk/CHB/bchlib/bCHLibTypes.mli +++ b/CodeHawk/CHB/bchlib/bCHLibTypes.mli @@ -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 @@ -325,7 +325,7 @@ type context_t = (** ctxt_iaddress_t spec: - [{ + {[ i ( [], { faddr,iaddr } ) = iaddr i ( [ F{ fa,cs,rs } ], { faddr,iaddr }) = iaddr i ( [ B{ js } ], { faddr,iaddr }) = iaddr @@ -344,7 +344,7 @@ type context_t = ci ( [ B{ js1 }, B{ js2 } ], { faddr,iaddr }) = B:js1_B:js2_iaddr ci ( [ C{true}], {faddr, iaddr}) = T_iaddr ci ( [ C{false}], {faddr, iaddr}) = F_iaddr - }] + ]} *) type ctxt_iaddress_t = string @@ -429,7 +429,7 @@ type flag_definition_t = { xflag_pos: int; (* lowest order bit is zero *) xflag_desc: string; xflag_type: btype_t -} + } class type type_definitions_int = @@ -1497,6 +1497,24 @@ end (** {1 Function data} *) +type regvar_intro_t = { + rvi_iaddr: doubleword_int; + rvi_name: string; + rvi_vartype: btype_t option; + rvi_cast: bool + } + +type stackvar_intro_t = { + svi_offset: int; + svi_name: string; + svi_vartype: btype_t option + } + + +type function_annotation_t = { + regvarintros: regvar_intro_t list; + stackvarintros: stackvar_intro_t list + } class type function_data_int = object @@ -1513,6 +1531,7 @@ class type function_data_int = method set_library_stub: unit method set_by_preamble: unit method set_class_info: classname:string -> isstatic:bool -> unit + method set_function_annotation: function_annotation_t -> unit method add_inlined_block: doubleword_int -> unit (** [add_path_context startaddr sentinels] causes path contexts to @@ -1530,6 +1549,9 @@ class type function_data_int = (* accessors *) method get_names: string list (* raw names *) method get_function_name: string (* demangled or combination of all names *) + method get_function_annotation: function_annotation_t option + method get_regvar_type_annotation: doubleword_int -> btype_t traceresult + method get_regvar_intro: doubleword_int -> regvar_intro_t option method get_inlined_blocks: doubleword_int list method get_function_type: btype_t method get_path_contexts: (string * string list) list @@ -1537,6 +1559,9 @@ class type function_data_int = (* predicates *) method has_function_type: bool method has_name: bool + method has_function_annotation: bool + method has_regvar_type_annotation: doubleword_int -> bool + method has_regvar_type_cast: doubleword_int -> bool method has_class_info: bool method has_callsites: bool method has_path_contexts: bool @@ -1574,6 +1599,7 @@ class type functions_data_int = (* predicates *) method is_function_entry_point: doubleword_int -> bool + method is_in_function_stub: ?size:int -> doubleword_int -> bool method has_function_name: doubleword_int -> bool method has_function_by_name: string -> doubleword_int option method has_function: doubleword_int -> bool @@ -3259,7 +3285,7 @@ class type type_constraint_store_int = [BaseArray (v, t)] and [BaseStruct (v, t)] on the other hand is that the variable [v] referenced in [BaseVar] refers to a variable that is a pointer, that is, its value is the address of the base, while the - variable [v] in [BaseArray] and [BaseStruct] is a symbolic representation + expression [x] in [BaseArray] and [BaseStruct] is a symbolic representation of the address itself, that is, there is no associated variable in the code. The latter two are applicable to global or stack-allocated arrays and structs that can be referenced directly via their address without @@ -3276,10 +3302,10 @@ type memory_base_t = (** base provided by an externally controlled variable, e.g., argument to the function, or return value from malloc *) -| BaseArray of variable_t * btype_t +| BaseArray of xpr_t * btype_t (** base provided by a typed array address *) -| BaseStruct of variable_t * btype_t +| BaseStruct of xpr_t * btype_t (** base provided by a typed struct address *) | BaseUnknown of string (** address without interpretation *) @@ -3289,7 +3315,10 @@ type memory_base_t = type memory_offset_t = | NoOffset | ConstantOffset of numerical_t * memory_offset_t - (** typically used when the type of the variable is not known*) + (** typically used when the type of the variable is not known, or for + global offsets (the absolute address of a global variable), or for + stack offsets (the difference between the stack pointer and the value + of the stack pointer at function entry *) | FieldOffset of fielduse_t * memory_offset_t (** offset in a struct variable with [(fieldname, struct key)] *) @@ -3331,13 +3360,13 @@ object ('a) memory reference. Returns [Error] if this memory reference does not have a [BaseArray] base.*) - method get_array_base: (variable_t * btype_t) traceresult + method get_array_base: (xpr_t * btype_t) traceresult (** Returns the memory address variable and type of the base address of this memory reference. Returns [Error] if this memory reference does not have a [BaseStruct] base.*) - method get_struct_base: (variable_t * btype_t) traceresult + method get_struct_base: (xpr_t * btype_t) traceresult (** {1 Predicates} *) @@ -3376,8 +3405,8 @@ object method mk_allocated_stack_reference: memory_reference_int method mk_realigned_stack_reference: memory_reference_int method mk_basevar_reference: variable_t -> memory_reference_int - method mk_base_array_reference: variable_t -> btype_t -> memory_reference_int - method mk_base_struct_reference: variable_t -> btype_t -> memory_reference_int + method mk_base_array_reference: xpr_t -> btype_t -> memory_reference_int + method mk_base_struct_reference: xpr_t -> btype_t -> memory_reference_int method mk_unknown_reference: string -> memory_reference_int (** {1 Accessors} *) @@ -3439,15 +3468,6 @@ type assembly_variable_denotation_t = - HeapBase pointers External auxiliary variables can be used as the base variable for memory references - - An auxiliary variable can also be a known memory address that is associated - with a name and possibly type. This form of constant-value variable is used - to preserve the identity of the memory address, to prevent that other offsets - are being added to the numeric address, thereby obscuring the meaning of the - address. This is particularly useful when intermediate expressions may - lead to an address that is outside the bounds of the structured variable - denoted by the name. - *) and constant_value_variable_t = | InitialRegisterValue of register_t * int @@ -3469,6 +3489,10 @@ and constant_value_variable_t = (** [FunctionReturnValue iaddr]: return value from call at instruction address [iaddr]*) + | TypeCastValue of ctxt_iaddress_t * string * btype_t * register_t + (** [TypeCastValue iaddr name ty reg]: a register value that takes the value + from [reg] and interprets it as type [ty]; the value gets name [name].*) + | SyscallErrorReturnValue of ctxt_iaddress_t (** [SyscallErrorReturnValue iaddr]: error return value from system call at instruction address [iaddr]*) @@ -3488,10 +3512,6 @@ and constant_value_variable_t = assigned by the callee at call site [iaddr] to the argument with name [name].*) - | MemoryAddress of int * memory_offset_t * string option * btype_t option - (** [MemoryAddress (memrefix, offset, optname, opttype) represents a memory - address with external meaning (e.g., a global arrray) *) - | BridgeVariable of ctxt_iaddress_t * int (* call site, argument index *) | FieldValue of string * int * string (* struct name, offset, fieldname *) @@ -3541,12 +3561,6 @@ object ('a) Returns [Error] if this variable is not a memory variable. *) method get_memory_offset: memory_offset_t traceresult - (** Returns the information associated with a memory address variable: - (memory reference index, memory offset, optional name, and optional - type of the memory region located at the address).*) - method get_memory_address_meminfo: - (int * memory_offset_t * string option * btype_t option) traceresult - (** Returns the name of the associated function pointer. Returns [Error] if this variable is not a function-pointer value. *) @@ -3609,7 +3623,6 @@ object ('a) method is_arm_argument_variable: bool method is_arm_extension_register_variable: bool method is_memory_variable: bool - method is_memory_address_variable: bool (** Returns true if this variable is set by the function environment and does not change during the execution of the function. @@ -3768,6 +3781,11 @@ object memory_offset_t -> assembly_variable_int + method add_memvar_offset: + variable_t + -> memory_offset_t + -> assembly_variable_int traceresult + (** [make_global_variable ?size ?offset address] returns the global variable with address [address] and optional offset [offset].*) method make_global_variable: @@ -3776,18 +3794,8 @@ object -> numerical_t -> assembly_variable_int - (** {2 Auxiliary variables}*) - - (** [make_global_memory_address name type offset] returns a memory address - value variable with [Global] base and offset [offset] (the global address) - with an optional name and type of the global memory region at that - address.*) - method make_global_memory_address: - ?optname:string option - -> ?opttype:btype_t option - -> numerical_t - -> assembly_variable_int + (** {2 Auxiliary variables}*) (** [make_frozen_test_value var taddr jaddr] returns a frozen test value for the variable [var] at test address [taddr] that is part of an @@ -3822,6 +3830,15 @@ object value from the call at address [addr].*) method make_return_value: ctxt_iaddress_t -> assembly_variable_int + (** [make_typecast_value addr name ty reg] returns the variable with name + [name] representing the value of register [reg] cast to type [ty].*) + method make_typecast_value: + ctxt_iaddress_t + -> string + -> btype_t + -> register_t + -> assembly_variable_int + (** [make_symbolic_value x] returns the variable representing the value of expression [x], which must be an expression that consists entirely of constant-value variables.*) @@ -3954,19 +3971,6 @@ object method get_initial_memory_value_variable: variable_t -> variable_t traceresult - (** {2 Memory addressses} *) - - method is_memory_address_variable: variable_t -> bool - - (** Returns the information associated with a memory address value: - (memory reference index, memory offset, optional name, optional type). - - Returns [Error] if the variable is not a memory address value.*) - method get_memory_address_meminfo: - variable_t - -> (int * memory_offset_t * string option * btype_t option) traceresult - - (** {2 Memory offsets} *) (** Returns [true] if [memoff] is a known numerical value, or it is an index @@ -4071,11 +4075,12 @@ object method is_stack_parameter_variable: variable_t -> bool (** Returns the index of the stack parameter variable [var] assuming - 4-byte parameters starting at offset 4 (x86 only). + 4-byte parameters starting at offset 4 (x86 only). The variable may + either be a stack memory variable or a stack initial memory value. Returns None if the variable is not a stack parameter variable or if the variable cannot be found. *) - method get_stack_parameter_index: variable_t -> (int option) + method get_stack_parameter_index: variable_t -> int option (** Returns [true] if [var] is either a register variable or a stack variable (at any offset). *) @@ -4242,10 +4247,205 @@ object end +(** {1 Global Memory Map} *) + +type globalvalue_t = + | GConstantString of string + | GScalarValue of doubleword_int + + +(** Reference to a global location*) +type global_location_ref_t = + | GLoad of doubleword_int * ctxt_iaddress_t * xpr_t * int * bool + (** address of global location, instructions address of load + instruction, load address, size of load, signed *) + + | GStore of + doubleword_int * ctxt_iaddress_t * xpr_t * int * numerical_t option + (** address of global location, instruction address of store + instruction, store address, size of store, optional numerical value + assigned *) + + | GAddressArgument of + doubleword_int + * ctxt_iaddress_t + * int + * xpr_t + * btype_t + * memory_offset_t option + (** address of global location, instruction address of call + instruction, index of argument (1-based), value of address argument, + type of address argument, offset of address argument.*) + + +type global_location_rec_t = { + gloc_name: string; + gloc_address: doubleword_int; + gloc_btype: btype_t; + gloc_size: int option; + gloc_is_readonly: bool; + gloc_is_initialized: bool; + gloc_initialvalue: globalvalue_t option; + gloc_desc: string option; + gloc_section: string option; + } + + +(** Representation of a global location that provides access to size and type + (immutable). *) +class type global_location_int = + object + method grec: global_location_rec_t + method name: string + method address: doubleword_int + method btype: btype_t + method size: int option + method is_readonly: bool + method is_initialized: bool + method is_typed: bool + method is_struct: bool + method is_array: bool + method initialvalue: globalvalue_t option + method desc: string option + method contains_address: doubleword_int -> bool + + (** [address_offset addr] returns the difference between [addr] and the + base address of the location. If [addr] is an expression that contains + symbolic values, the global address is taken as the largest constant + term in the expression. + + If [addr] is not contained within the location (that is, if [addr] is + less than the base address or larger than or equal to the base address + plus the size of the location) an Error is returned. + *) + method address_offset: xpr_t -> xpr_t traceresult + + (** [address_memory_offset size btype addr] returns the symbolic offset + that corresponds to the location of [addr] within the location. An + optional [size] or [btype] can be provided to resolve potential + ambiguities in the offset at a given offset. For example, address + difference 0 in the struct + + {[ + struct s { + char a[10]; + .... + }; + ]} + + may have either one of the following three distinct offsets: + + {[ + (1) NoOffset + (2) FieldOffset ((a, _), NoOffset) + (3) FieldOffset ((a, _), ArrayIndexOffset (0, NoOffset) + ]} + + By default the minimal offset (1) is returned. Offset (2) can be + forced by either passing in [size=10] or [btype=TArray..]. Offset + (3) can be forced by either passing in [size=1] or [btype=TInt...]. + + An Error is returned if either + - [addr] is not contained within the location, or + - [addr] is greater than the base address of the location and the + location is not typed, or + - [addr] does nor correspond to a legitimate offset, or + - the provided type or size cannot be matched to any offset. + *) + method address_memory_offset: + ?tgtsize:int option + -> ?tgtbtype:btype_t + -> xpr_t + -> memory_offset_t traceresult + + method has_elf_symbol: bool + + method write_xml: xml_element_int -> unit + end + + +(** Container for global locations in the system in the data sections, + including initialized and uninitialized (.bss) data, but typically + excluding data contained within the .text section.*) +class type global_memory_map_int = + object + + method set_section: + readonly:bool + -> initialized:bool + -> string + -> doubleword_int + -> doubleword_int + -> unit + + method add_location: + ?name:string option + -> ?desc:string option + -> ?btype: btype_t + -> ?initialvalue: globalvalue_t option + -> ?size: int option + -> doubleword_int + -> global_location_int traceresult + + method add_gload: + doubleword_int + -> ctxt_iaddress_t + -> xpr_t + -> int + -> bool + -> unit + + method add_gstore: + doubleword_int + -> ctxt_iaddress_t + -> xpr_t + -> int + -> numerical_t option + -> unit + + method add_gaddr_argument: + doubleword_int + -> ctxt_iaddress_t + -> xpr_t + -> int + -> btype_t + -> global_location_int option + + method update_named_location: + string -> bvarinfo_t -> global_location_int traceresult + + method has_location: doubleword_int -> bool + + method get_location: doubleword_int -> global_location_int + + method containing_location: doubleword_int -> global_location_int option + + method xpr_containing_location: xpr_t -> global_location_int option + + method get_location_name: doubleword_int -> string + + method get_location_type: doubleword_int -> btype_t + + method has_location_with_name: string -> bool + + method is_global_data_address: doubleword_int -> bool + + method has_elf_symbol: doubleword_int -> bool + + method get_elf_symbol: doubleword_int -> string + + method write_xml: xml_element_int -> unit + + method write_xml_references: + doubleword_int -> vardictionary_int -> xml_element_int -> unit + end + + (* =========================================================== Function info === *) +(** @Deprecated Currenly used only for x86 *) class type argument_values_int = object method add_argument_values : variable_t -> xpr_t list -> unit @@ -4255,6 +4455,7 @@ object method toPretty : pretty_t end +(** {1 Functions} *) (** {2 Function symbol table} *) @@ -4291,9 +4492,16 @@ class type function_environment_int = (** {2 Memory references} *) + (** To be deprecated. *) method mk_unknown_memory_reference: string -> memory_reference_int + + (** Returns global base reference (address zero). *) method mk_global_memory_reference: memory_reference_int + + (** Returns local stack base reference. *) method mk_local_stack_reference: memory_reference_int + + (** Returns a base reference for a realigned stack pointer. *) method mk_realigned_stack_reference: memory_reference_int (** [mk_base_variable_reference var] returns a memory reference with @@ -4305,10 +4513,8 @@ class type function_environment_int = A memory-address value returns a base-array or base-struct reference, depending on the type of the memory-address value. - Returns an unknown-basevar memory variable if [var] cannot be used - as a basevar. - - Returns [Error] if [var] cannot be found. *) + Returns [Error] if [var] cannot be found, or if [var] cannot be + used as a basevar. *) method mk_base_variable_reference: variable_t -> memory_reference_int traceresult @@ -4323,9 +4529,12 @@ class type function_environment_int = (** {2 Register variables} *) - (** {3 x86} *) + (** {3 Generic} *) method mk_register_variable: register_t -> variable_t + + (** {3 x86} *) + method mk_cpu_register_variable: cpureg_t -> variable_t method mk_fpu_register_variable: int -> variable_t method mk_mmx_register_variable: int -> variable_t @@ -4361,47 +4570,76 @@ class type function_environment_int = (** {2 Memory variables} *) + (** [mk_global_variable offset] attempts to find a containing global + location for [offset]. If successful a memory offset will be computed + for that offset relative to the address of the containing location + and the type of that location. + + If no containing location can be found for [offset] a new global + location is created in the global memory map and a global variable + is returned for that address without offset. + + If the global location found is untyped and there is a non-zero offset, + a global variable with a constant offset is returned. Note that a + constant offset cannot be used for lifting. + *) method mk_global_variable: ?size:int - -> ?offset:memory_offset_t - -> numerical_t -> variable_t traceresult - - method mk_global_memory_address: - ?optname: string option - -> ?opttype: btype_t option + -> ?btype:btype_t -> numerical_t - -> variable_t + -> variable_t traceresult + + (** [mk_gloc_variable gloc memoff] creates a global variable for an existing + global location [gloc] with memory offset [memoff]. - method mk_initial_memory_value: variable_t -> variable_t + It also sets the name of the global variable and the name of the global + variable with offset according to the name of the global location [gloc] + *) + method mk_gloc_variable: + global_location_int -> memory_offset_t -> variable_t + (** [mk_initial_memory_value var] returns an auxiliary variable that + represents the initial value of [var] at function entry. + + If [var] is a global struct variable, it also creates initial values + for the struct fields. + + If [var] is not an external memory variable an error is returned. + *) + method mk_initial_memory_value: variable_t -> variable_t traceresult + + (** [mk_memory_variable memref offset] returns a memory variable with + [memref] as basis and a constant (numerical) offset. + + If [memref] is an unknown base a temp variable is returned. + *) method mk_memory_variable: ?save_name:bool -> ?size:int -> memory_reference_int -> numerical_t -> variable_t - method mk_index_offset_memory_variable: + + (** [mk_offset_memory_variable memref memoff] returns a memory variable + with [memref] as basis and a generic memory offset. + + @raise [BCH_failure] if [memref] is an unknown memory reference. + + Note: eventually unknown memory references should be eliminated. *) + method mk_offset_memory_variable: ?size:int -> memory_reference_int -> memory_offset_t -> variable_t + (* method mk_index_offset_global_memory_variable: ?elementsize:int -> numerical_t -> memory_offset_t - -> variable_t traceresult - method mk_unknown_memory_variable: string -> variable_t - - method mk_memory_address_deref_variable: - ?size: int -> ?offset: int -> variable_t -> variable_t traceresult - - (** {2 Memory address variables} *) + -> variable_t traceresult *) - method mk_global_memory_address: - ?optname: string option - -> ?opttype: btype_t option - -> numerical_t - -> variable_t + (** To be deprecated. *) + method mk_unknown_memory_variable: string -> variable_t (** {2 Other variables} *) @@ -4415,6 +4653,8 @@ class type function_environment_int = method mk_special_variable: string -> variable_t method mk_runtime_constant: string -> variable_t method mk_return_value: ctxt_iaddress_t -> variable_t + method mk_typecast_value: + ctxt_iaddress_t -> string -> btype_t -> register_t -> variable_t method mk_calltarget_value: call_target_t -> variable_t method mk_function_pointer_value: @@ -4479,19 +4719,16 @@ class type function_environment_int = method has_variable_index_offset: variable_t -> bool - (** {2 Memory address variables} *) - - (** [is_memory_address_variable v] returns true if [v] is a constant-value - variable for a memory address.*) - method is_memory_address_variable: variable_t -> bool - - (** {2 Memory offsets} *) (** Returns [true if [var] is a memory variable and its offset is a constant numerical value. *) method has_constant_offset: variable_t -> bool + + method add_memory_offset: + variable_t -> memory_offset_t -> variable_t traceresult + (** {2 Register variables} *) (** Returns [true] if [var] is a register variable (of any architecture). *) @@ -4715,6 +4952,12 @@ class type function_environment_int = method is_initial_value: variable_t -> bool + (** [get_init_value_variable var] returns the original variable for which + [var] is the initial value. + + If [var] is not an initial memory or initial register value an Error is + returned. + *) method get_init_value_variable: variable_t -> variable_t traceresult (** {1 Variable collections} *) @@ -4740,15 +4983,25 @@ class type function_environment_int = method get_returnvar_count: int method get_sideeffvar_count: int - method get_constant_offsets: variable_t -> numerical_t list option - method get_total_constant_offset: variable_t -> numerical_t option + method get_constant_offsets: variable_t -> numerical_t list traceresult + method get_total_constant_offset: variable_t -> numerical_t traceresult + + (** [get_argbasevar_with_offsets v] returns a decomposition of [v] into + a base variable and a list of (constant) numerical offsets. + Returns None if [v] is not a memory variable with an argument base or if + [v] does not have constant offsets.*) method get_argbasevar_with_offsets: variable_t -> (variable_t * numerical_t list) option + + (** [get_globalbasevar_with_offsets v] returns a decomposition of [v] into + a base variable a list of (constant) numerical offsets. + + Returns None if [v] is not a memory variable with a global base or if [v] + does not have constant offsets.*) method get_globalbasevar_with_offsets: variable_t -> (variable_t * numerical_t list) option - method get_initialized_call_target_value: variable_t -> call_target_t method get_initialized_string_value: variable_t -> int -> string method variables_in_expr: xpr_t -> variable_t list @@ -4774,7 +5027,6 @@ class type function_environment_int = (** {1 Envionment data predicates} *) method is_virtual_call : variable_t -> bool - method has_initialized_call_target_value: variable_t -> bool method has_initialized_string_value : variable_t -> int -> bool (** {1 Printing} *) @@ -4848,7 +5100,6 @@ class type call_target_info_int = end -(** {1 Functions} *) (** {2 Function-info} *) @@ -4883,6 +5134,7 @@ class type stackframe_int = -> variable_t -> ctxt_iaddress_t -> unit + method add_store: offset:int -> size:int option @@ -4977,6 +5229,9 @@ object (** Returns the address of the function.*) method get_address: doubleword_int + (** Returns the known data about this function.*) + method get_function_data: function_data_int + (** Returns the name of the function.*) method get_name: string @@ -5073,13 +5328,6 @@ object (** Declares that this function is non-returning.*) method set_nonreturning: unit - (** [finfo#record_return_value iaddr xpr] records that the function - returns value [xpr] at return instruction [iaddr].*) - method record_return_value: ctxt_iaddress_t -> xpr_t -> unit - - (** Returns the function return values recorded for this function.*) - method get_return_values: xpr_t list - (* method set_dynlib_stub: call_target_t -> unit *) @@ -5157,34 +5405,6 @@ object method restore_register: xpr_t -> ctxt_iaddress_t -> register_t -> unit - (** {2 Auxvar types} - - The types set and retrieved are inferred variable types for constant-value - variables. Inferences are based on their appearance in certain instructions - or operations performed on them. Throughout the analysis different aspects - may be revealed, and a list of these is maintained.*) - - (** [finfo#set_btype v ty] records type [ty] for variable [v].*) - method set_btype: variable_t -> btype_t -> unit - - (** [finfo#has_btype v] returns true if at least one type has been recorded for - variable [v].*) - method has_btype: variable_t -> bool - - (** [finfo#get_btype v] returns the join of all types that have been recorded - for variable [v]. If no types were recorded [t_unknown] is returned.*) - method get_btype: variable_t -> btype_t - - (** [finfo#get_btypes v] returns all types that have been recorded for - variable [v]. If no types were recorded the empty list is returned.*) - method get_btypes: variable_t -> btype_t list - - (** Returns a list of indexed variable type records, where each entry - represents (index of variable, index of joined type, indices of all - types).*) - method get_btype_table: (int * int * int list) list - - (** {1 Function summaries} Information registered to create a function summary for the application function represented by this function_info (possibly including global @@ -5220,18 +5440,6 @@ object method set_unknown_java_native_method_signature: unit - (** {2 Side effects}*) - - (** [finfo#record_sideeffect iaddr se] records side effect [se] (i.e., - an effect that is observable outside of the function, such as writing - through a pointer provided as argument) at instruction address [iaddr]. - - This method is currently called only when an assignment is performed - with a left-hand-side that is an external memory reference. - *) - method record_sideeffect: ctxt_iaddress_t -> xxpredicate_t -> unit - - (** {1 Condition codes} The function info keeps track of test expressions and the variables used therein for conditional jump instructions. These methods are used mainly @@ -5404,14 +5612,13 @@ object method summary_to_pretty: pretty_t method saved_registers_to_pretty: pretty_t method base_pointers_to_pretty: pretty_t - method return_values_to_pretty: pretty_t + (* method return_values_to_pretty: pretty_t *) end (** {2 Floc} *) - (** Records stack, global, or heap memory accesses performed by a particular instruction *) class type memory_recorder_int = @@ -5429,13 +5636,28 @@ class type memory_recorder_int = -> unit -> unit + method record_argument: + ?btype:btype_t + -> xpr_t + -> int + -> global_location_int option + method record_load: - addr:xpr_t + signed:bool + -> addr:xpr_t -> var:variable_t -> size:int -> vtype:btype_t -> unit + method record_load_r: + signed:bool + -> addr_r:xpr_t traceresult + -> var_r:variable_t traceresult + -> size:int + -> vtype:btype_t + -> unit + method record_store: addr:xpr_t -> var:variable_t @@ -5444,6 +5666,14 @@ class type memory_recorder_int = -> xpr:xpr_t -> unit + method record_store_r: + addr_r:xpr_t traceresult + -> var_r:variable_t traceresult + -> size:int + -> vtype:btype_t + -> xpr_r:xpr_t traceresult + -> unit + end @@ -5597,16 +5827,54 @@ class type floc_int = (** {2 Resolve memory variable}*) + (** [get_memory_variable_numoffset var num] returns the variable that + corresponds to the address expression [var + num]. + + This method is convenient for indirect memory accesses expressed by + a register base and immediate offset. + + This method should eventually replace [get_memory_variable_1] + *) + method get_memory_variable_numoffset: + ?align:int + -> ?size:int + -> variable_t + -> numerical_t + -> variable_t traceresult + (* returns the memory reference corresponding to the address in - variable plus offset *) + variable plus offset. + + Deprecated. Should eventually be replaced by + [get_memory_variable_numoffset]. + *) method get_memory_variable_1: - ?align:int -> ?size:int -> variable_t -> numerical_t -> variable_t + ?align:int + -> ?size:int + -> variable_t + -> numerical_t + -> variable_t + + method get_memory_variable_varoffset: + ?size:int + -> variable_t + -> variable_t + -> numerical_t + -> variable_t traceresult (* returns the memory reference corresponding to a base and index variable plus offset *) method get_memory_variable_2: ?size:int -> variable_t -> variable_t -> numerical_t -> variable_t + method get_memory_variable_scaledoffset: + ?size:int + -> variable_t + -> variable_t + -> int + -> numerical_t + -> variable_t traceresult + (* returns the memory reference corresponding to a base and scaled index variable plus offset *) method get_memory_variable_3: @@ -5621,11 +5889,21 @@ class type floc_int = index variable *) method get_memory_variable_4: variable_t -> int -> numerical_t -> variable_t - (* returns the memory reference that corresponds to the address expression *) - method decompose_address: xpr_t -> (memory_reference_int * memory_offset_t) + (* [decompose_memaddr addr] attempts to separate the terms of [addr] into + a base (global, stack, or base variable) and an offset. + + This method should eventually replace the method [decompose_address]. + *) + method decompose_memaddr: + xpr_t + -> (memory_reference_int traceresult * memory_offset_t traceresult) + + (* returns the memory reference and offset that corresponds to the address + expression. - method decompose_memvar_address: - xpr_t -> (memory_reference_int * memory_offset_t) option + Deprecated. Should eventually be replaced by [decompose_memaddr] + *) + method decompose_address: xpr_t -> (memory_reference_int * memory_offset_t) (* returns the variable associated with the address expression *) method get_lhs_from_address: xpr_t -> variable_t @@ -5641,6 +5919,12 @@ class type floc_int = method get_singleton_stackpointer_offset: numerical_t traceresult + method get_var_at_address: + ?size:int option (** size of the argument, in bytes *) + -> ?btype:btype_t (** type of argument *) + -> xpr_t (** address value *) + -> variable_t traceresult + (** {2 Predicates on variables}*) (* returns true if the given variable evaluates to a constant at this @@ -5710,10 +5994,6 @@ class type floc_int = (** {1 Function summary}*) - (* evaluates the value of eax at this location and reports it to the function - info *) - method record_return_value: unit - method evaluate_summary_address_term: bterm_t -> variable_t option method evaluate_summary_term: bterm_t -> variable_t -> xpr_t @@ -5745,7 +6025,7 @@ class type floc_int = (** {2 Assignments} *) - (** [floc#get_assign_commands var ~size ~vtype xpr] returns the CHIF commands + (** [get_assign_commands var ~size ~vtype xpr] returns the CHIF commands representing the assignment [var := xpr]. If [size] is not None and the left-hand side [var] is externally observable @@ -5754,6 +6034,8 @@ class type floc_int = If [vtype] is known type facts are added for both [var] and [xpr] for this instruction. + + Deprecated. To be replaced with [get_assign_commands_r]. *) method get_assign_commands: variable_t @@ -5762,13 +6044,31 @@ class type floc_int = -> xpr_t -> cmd_t list - (** [floc#get_ssa_assign_commands reg ~vtype xpr] creates an ssa-register + (** [get_assign_commands_r var xpr] returns the CHIF commands representing + the assignment [var := xpr]. + + If [size] of [var] (in bytes) is different from the default value 4, + the value of [xpr] is restricted to the given width if the value is a + numerical constant.*) + method get_assign_commands_r: + ?signed:bool + -> ?size:int + -> variable_t traceresult + -> xpr_t traceresult + -> cmd_t list + + + (** [get_ssa_assign_commands reg ~vtype xpr] creates an ssa-register variable [ssavar] for the current context address and returns a tuple of the register-variable, and the CHIF commands representing the assignment and assert-equal: {[ reg := xpr assert (reg = ssavar) - ]} *) + ]} + + Deprecated. All ssa variables have been moved to the python front end. + To be replaced with [get_assign_commands_r]. + *) method get_ssa_assign_commands: register_t -> ?vtype:btype_t @@ -5782,6 +6082,8 @@ class type floc_int = (** {2 Variable abstraction}*) + method get_abstract_commands_r: variable_t traceresult -> cmd_t list + (* returns the CHIF code associated with an abstraction of variables *) method get_abstract_commands: variable_t -> ?size:xpr_t -> ?vtype:btype_t -> unit -> cmd_t list @@ -5789,7 +6091,10 @@ class type floc_int = (** floc#[get_ssa_abstract_commands reg ()] creates an ssa-register variable [ssavar] for the current context address and returns a tuple of the register-variable and the CHIF commands representing the assignment - {[ reg := ssavar ]}*) + {[ reg := ssavar ]} + + Deprecated. To be replaced with [get_abstract_commands_r] + *) method get_ssa_abstract_commands: register_t -> unit -> (variable_t * cmd_t list) @@ -5912,6 +6217,7 @@ object (* initialization *) method initialize: unit + method initialize_function_annotations: unit method initialize_jumptables: (doubleword_int -> bool) -> (doubleword_int * string) list -> unit method initialize_datablocks: (doubleword_int * string) list -> unit @@ -5981,9 +6287,29 @@ object method get_preamble_cutoff: int method get_filename: string method get_xfilesize: int - method get_file_string: ?hexSize:doubleword_int -> doubleword_int -> string + + (** [get_file_string size offset] returns the segment from the input binary + that starts at file offset [offset] of length [size]. If [size] is zero + the remainder of the file is returned starting at [offset]. + + An error is returned if [offset] is larger than the size of the binary + or if [offset + size] is more than 10 bytes beyond the end of the file + (if it is less than 10 bytes beyond the end of the file, the remainder + is padded with zero's to make up the requested length). + *) + method get_file_string: + ?hexSize:doubleword_int -> doubleword_int -> string traceresult + + (** [get_file_input size offset] returns a wrapper around a segment from + the input binary to facilitate reading different types from the string. + + Errors returned are the same as for [get_file_string]. + *) method get_file_input: - ?hexSize:doubleword_int -> doubleword_int -> stream_wrapper_int + ?hexSize:doubleword_int + -> doubleword_int + -> stream_wrapper_int traceresult + method get_image_base: doubleword_int method get_base_of_code_rva: doubleword_int (* relative virtual address *) method get_address_of_entry_point: doubleword_int @@ -6022,7 +6348,6 @@ object method get_user_struct_count: int method get_user_nonreturning_count: int method get_user_class_count: int - method get_variable_intro_name: doubleword_int -> string (* predicates *) method is_little_endian: bool @@ -6053,8 +6378,6 @@ object method is_trampoline_payload: doubleword_int -> bool method is_trampoline_wrapper: doubleword_int -> bool method is_trampoline_fallthroughaddr: doubleword_int -> bool - method has_variable_intro: doubleword_int -> bool - method has_variable_intros: bool (** [is_thumb addr] returns true if the architecture includes (arm) thumb instructions and the virtual address [addr] is in a code section that @@ -6063,6 +6386,7 @@ object (* xml *) (* method read_xml_constant_file: string -> unit *) + method read_xml_user_data: xml_element_int -> unit (* saving *) method write_xml: xml_element_int -> unit diff --git a/CodeHawk/CHB/bchlib/bCHMemoryRecorder.ml b/CodeHawk/CHB/bchlib/bCHMemoryRecorder.ml index fa751b44..7298fc33 100644 --- a/CodeHawk/CHB/bchlib/bCHMemoryRecorder.ml +++ b/CodeHawk/CHB/bchlib/bCHMemoryRecorder.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2023-2024 Aarno Labs LLC + Copyright (c) 2023-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 @@ -31,6 +31,7 @@ open CHLanguage (* chutil *) open CHLogger +open CHTraceResult (* xprlib *) open Xprt @@ -40,12 +41,20 @@ open XprTypes (* bchlib *) open BCHBCTypes open BCHBCTypeUtil +open BCHDoubleword open BCHGlobalState open BCHLibTypes open BCHLocation +module TR = CHTraceResult + let x2p = xpr_formatter#pr_expr +let p2s = CHPrettyUtil.pretty_to_string +let x2s x = p2s (x2p x) + +let mmap = BCHGlobalMemoryMap.global_memory_map + let log_error (tag: string) (msg: string) = mk_tracelog_spec ~tag:("memoryrecorder:" ^ tag) msg @@ -99,6 +108,17 @@ object (self) | _ -> GUnknownValue) | _ -> GUnknownValue + method record_argument + ?(btype = t_unknown) + (argvalue: xpr_t) + (argindex: int): global_location_int option = + match argvalue with + | XConst (IntConst n) + when mmap#is_global_data_address (numerical_mod_to_doubleword n) -> + mmap#add_gaddr_argument self#faddr iaddr argvalue argindex btype + | _ -> + None + method record_assignment (lhs: variable_t) (rhs: xpr_t) @@ -175,6 +195,7 @@ object (self) (LBLOCK [self#loc#toPretty; STR ": "; v#toPretty])) vars method record_load + ~(signed: bool) ~(addr: xpr_t) ~(var: variable_t) ~(size: int) @@ -200,15 +221,62 @@ object (self) ~error:(fun _ -> ()) (self#env#get_memvar_offset var) else - chlog#add - "memory load not recorded" - (LBLOCK [ - self#loc#toPretty; - STR "; "; - x2p addr; - STR " ("; - var#toPretty; - STR ")"]) + match addr with + | XConst (IntConst n) + when mmap#is_global_data_address (numerical_mod_to_doubleword n) -> + mmap#add_gload self#faddr iaddr addr size signed + | _ -> + chlog#add + "memory load not recorded" + (LBLOCK [ + self#loc#toPretty; + STR "; "; + x2p addr; + STR " ("; + var#toPretty; + STR ")"]) + + method record_load_r + ~(signed: bool) + ~(addr_r: xpr_t traceresult) + ~(var_r: variable_t traceresult) + ~(size: int) + ~(vtype: btype_t) = + TR.tfold + ~ok:(fun var -> + if self#env#is_stack_variable var then + TR.tfold + ~ok:(fun offset -> + match offset with + | ConstantOffset (n, NoOffset) -> + self#finfo#stackframe#add_load + ~offset:n#toInt ~size:(Some size) ~typ:(Some vtype) var iaddr + | _ -> + log_error_result __FILE__ __LINE__ + ["memrecorder:stack"; p2s self#loc#toPretty]) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + (self#env#get_memvar_offset var) + else + TR.tfold + ~ok:(fun addr -> + match addr with + | XConst (IntConst n) + when mmap#is_global_data_address + (numerical_mod_to_doubleword n) -> + mmap#add_gload self#faddr iaddr addr size signed + | XConst (IntConst n) -> + log_result __FILE__ __LINE__ + ["memrecorder:literal load not recorded"; + p2s self#loc#toPretty; + p2s (numerical_mod_to_doubleword n)#toPretty] + | _ -> + log_result __FILE__ __LINE__ + ["memrecorder:load not recorded"; + p2s self#loc#toPretty; (x2s addr)]) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + addr_r) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + var_r method record_store ~(addr: xpr_t) @@ -243,16 +311,76 @@ object (self) ~error:(fun _ -> ()) (self#env#get_memvar_offset var) else - chlog#add - "memory store not recorded" - (LBLOCK [ - self#loc#toPretty; - STR ": "; - x2p addr; - STR " ("; - var#toPretty; - STR "): "; - x2p xpr]) + match addr with + | XConst (IntConst n) + when mmap#is_global_data_address (numerical_mod_to_doubleword n) -> + let optvalue = + match xpr with + | XConst (IntConst n) -> Some n + | _ -> None in + mmap#add_gstore self#faddr iaddr addr size optvalue + | _ -> + chlog#add + "memory store not recorded" + (LBLOCK [ + self#loc#toPretty; + STR ": "; + x2p addr; + STR " ("; + var#toPretty; + STR "): "; + x2p xpr]) + + method record_store_r + ~(addr_r: xpr_t traceresult) + ~(var_r: variable_t traceresult) + ~(size: int) + ~(vtype: btype_t) + ~(xpr_r: xpr_t traceresult) = + TR.tfold + ~ok:(fun var -> + if self#env#is_stack_variable var then + TR.tfold + ~ok:(fun offset -> + match offset with + | ConstantOffset (n, NoOffset) -> + self#finfo#stackframe#add_store + ~offset:n#toInt + ~size:(Some size) + ~typ:(Some vtype) + ~xpr:(TR.tfold_default (fun x -> Some x) None xpr_r) + var + iaddr + | _ -> + log_error_result __FILE__ __LINE__ + ["memrecorder:stack"; p2s self#loc#toPretty]) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + (self#env#get_memvar_offset var) + else + TR.tfold + ~ok:(fun addr -> + match addr with + | XConst (IntConst n) + when mmap#is_global_data_address + (numerical_mod_to_doubleword n) -> + let optvalue = + TR.tfold_default + (fun xpr -> + match xpr with + | XConst (IntConst n) -> Some n + | _ -> None) + None + xpr_r in + mmap#add_gstore self#faddr iaddr addr size optvalue + | _ -> + log_error_result __FILE__ __LINE__ + ["memrecorder: store not recorded"; + p2s self#loc#toPretty; (x2s addr)]) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + addr_r) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + var_r + end diff --git a/CodeHawk/CHB/bchlib/bCHMemoryReference.ml b/CodeHawk/CHB/bchlib/bCHMemoryReference.ml index 1aeeb090..d26f748a 100644 --- a/CodeHawk/CHB/bchlib/bCHMemoryReference.ml +++ b/CodeHawk/CHB/bchlib/bCHMemoryReference.ml @@ -39,6 +39,7 @@ open CHTraceResult (* xprlib *) open Xprt +open XprTypes open XprToPretty (* bchlib *) @@ -50,6 +51,7 @@ open BCHDoubleword open BCHLibTypes module H = Hashtbl +module TR = CHTraceResult let x2p = xpr_formatter#pr_expr @@ -64,8 +66,8 @@ let memory_base_to_string (b: memory_base_t): string = | BAllocatedStackFrame -> "allocated-stack" | BGlobal -> "global" | BaseVar v -> "var-" ^ v#getName#getBaseName - | BaseArray (v, _) -> "array-" ^ v#getName#getBaseName - | BaseStruct (v, _) -> "struct-" ^ v#getName#getBaseName + | BaseArray (x, _) -> "array-" ^ (x2s x) + | BaseStruct (x, _) -> "struct-" ^ (x2s x) | BaseUnknown s -> "unknown-" ^ s @@ -168,6 +170,218 @@ let rec mk_maximal_memory_offset (n: numerical_t) (ty: btype_t): memory_offset_t end +let rec address_memory_offset + ?(tgtsize=None) + ?(tgtbtype=t_unknown) + (basetype: btype_t) + (xoffset: xpr_t): memory_offset_t traceresult = + let rbasetype = TR.tvalue (resolve_type basetype) ~default:t_unknown in + match xoffset with + | XConst (IntConst n) + when n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && is_unknown_type tgtbtype -> Ok NoOffset + | XConst (IntConst n) + when n#equal CHNumerical.numerical_zero && is_unknown_type rbasetype -> + Ok NoOffset + | XConst (IntConst n) when is_unknown_type rbasetype -> + Ok (ConstantOffset (n, NoOffset)) + | _ -> + let tgtbtype = + if is_unknown_type tgtbtype then None else Some tgtbtype in + if is_struct_type rbasetype then + structvar_memory_offset ~tgtsize ~tgtbtype rbasetype xoffset + else if is_array_type rbasetype then + arrayvar_memory_offset ~tgtsize ~tgtbtype rbasetype xoffset + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (btype_to_string basetype) + ^ " (" ^ (btype_to_string rbasetype) ^ ")" + ^ " is not known to be a struct or array"] + +and structvar_memory_offset +~(tgtsize: int option) +~(tgtbtype: btype_t option) +(btype: btype_t) +(xoffset: xpr_t): memory_offset_t traceresult = + match xoffset with + | XConst (IntConst n) when + n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok NoOffset + | XConst (IntConst _) -> + if is_struct_type btype then + let compinfo = get_struct_type_compinfo btype in + (get_field_memory_offset_at ~tgtsize ~tgtbtype compinfo xoffset) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ " xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ " xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + +and arrayvar_memory_offset +~(tgtsize: int option) +~(tgtbtype: btype_t option) +(btype: btype_t) +(xoffset: xpr_t): memory_offset_t traceresult = + let iszero x = + match x with + | XConst (IntConst n) -> n#equal CHNumerical.numerical_zero + | _ -> false in + + match xoffset with + | XConst (IntConst n) when + n#equal CHNumerical.numerical_zero + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok NoOffset + | _ -> + if is_array_type btype then + let eltty = get_element_type btype in + TR.tbind + (fun elsize -> + let optindex = BCHXprUtil.get_array_index_offset xoffset elsize in + match optindex with + | None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to extract index from " ^ (x2s xoffset)] + | Some (indexxpr, xrem) when + iszero xrem + && Option.is_none tgtsize + && Option.is_none tgtbtype -> + Ok (ArrayIndexOffset (indexxpr, NoOffset)) + | Some (indexxpr, rem) -> + if (TR.tfold_default is_struct_type false (resolve_type eltty)) then + let eltty = TR.tvalue (resolve_type eltty) ~default:t_unknown in + TR.tbind + (fun suboff -> Ok (ArrayIndexOffset (indexxpr, suboff))) + (structvar_memory_offset ~tgtsize ~tgtbtype eltty rem) + else if is_array_type eltty then + TR.tbind + (fun suboff -> Ok (ArrayIndexOffset (indexxpr, suboff))) + (arrayvar_memory_offset ~tgtsize ~tgtbtype eltty rem) + else if is_scalar eltty then + let x2index = XOp (XDiv, [rem; int_constant_expr elsize]) in + let x2index = Xsimplify.simplify_xpr x2index in + Ok (ArrayIndexOffset (x2index, NoOffset)) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype) + ^ "; elementtype: " ^ (btype_to_string eltty)]) + (size_of_btype eltty) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":" + ^ " xoffset: " ^ (x2s xoffset) + ^ "; btype: " ^ (btype_to_string btype)] + + +and get_field_memory_offset_at +~(tgtsize: int option) +~(tgtbtype: btype_t option) +(c: bcompinfo_t) +(xoffset: xpr_t): memory_offset_t traceresult = + let check_tgttype_compliance (t: btype_t) (s: int) = + match tgtsize, tgtbtype with + | None, None -> true + | Some size, None -> size = s + | None, Some ty -> btype_equal ty t + | Some size, Some ty -> size = s && btype_equal ty t in + + let compliance_failure (t: btype_t) (s: int) = + let size_discrepancy size s = + "size discrepancy between tgtsize: " + ^ (string_of_int size) + ^ " and field size: " + ^ (string_of_int s) in + let type_discrepancy ty t = + "type discrepancy between tgttype: " + ^ (btype_to_string ty) + ^ " and field type: " + ^ (btype_to_string t) in + match tgtsize, tgtbtype with + | Some size, Some ty when (size != s) && (not (btype_equal ty t)) -> + (size_discrepancy size s) ^ " and " ^ (type_discrepancy ty t) + | Some size, _ when size != s -> size_discrepancy size s + | _, Some ty when not (btype_equal ty t) -> type_discrepancy ty t + | _ -> "" in + + match xoffset with + | XConst (IntConst n) -> + let offset = n#toInt in + let finfos = c.bcfields in + let optfield_r = + List.fold_left (fun acc_r finfo -> + match acc_r with + | Error e -> Error e + | Ok (Some _) -> acc_r + | Ok _ -> + match finfo.bfieldlayout with + | None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "No field layout for field " ^ finfo.bfname] + | Some (foff, sz) -> + if offset < foff then + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Skipped over field: " + ^ (string_of_int offset)] + else if offset > (foff + sz) then + Ok None + else + let offset = offset - foff in + TR.tbind + (fun fldtype -> + if offset = 0 + && (is_scalar fldtype) + && (check_tgttype_compliance fldtype sz) then + Ok (Some (FieldOffset + ((finfo.bfname, finfo.bfckey), NoOffset))) + else + if offset = 0 && is_scalar fldtype then + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Scalar type or size is not consistent: " + ^ (compliance_failure fldtype sz)] + else if is_struct_type fldtype then + TR.tmap + (fun suboff -> + Some (FieldOffset + ((finfo.bfname, finfo.bfckey), suboff))) + (structvar_memory_offset + ~tgtsize + ~tgtbtype + fldtype + (int_constant_expr offset)) + else if is_array_type fldtype then + TR.tmap + (fun suboff -> + Some (FieldOffset + ((finfo.bfname, finfo.bfckey), suboff))) + (arrayvar_memory_offset + ~tgtsize + ~tgtbtype + fldtype + (int_constant_expr offset)) + else + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Nonzero offset: " ^ (string_of_int offset) + ^ " with unstructured field type: " + ^ (btype_to_string fldtype)]) + (resolve_type finfo.bftype)) (Ok None) finfos in + (match optfield_r with + | Error e -> Error e + | Ok (Some offset) -> Ok offset + | Ok None -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to find field at offset " ^ (string_of_int offset)]) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to determine field for xoffset: " ^ (x2s xoffset)] + + let rec is_unknown_offset offset = match offset with | UnknownOffset -> true @@ -205,23 +419,33 @@ let get_index_offset_variables (offset: memory_offset_t): variable_t list = let rec aux (o: memory_offset_t) (vlst: variable_t list) = match o with | IndexOffset (v, _, suboffset) -> aux suboffset (v :: vlst) + | ArrayIndexOffset (x, suboffset) -> + aux suboffset ((Xprt.variables_in_expr x) @ vlst) | ConstantOffset (_, suboffset) | FieldOffset (_, suboffset) -> aux suboffset vlst | _ -> vlst in aux offset [] -let rec get_constant_offsets offset = +let rec get_constant_offsets + (offset: memory_offset_t): numerical_t list traceresult = match offset with - | NoOffset -> [ numerical_zero ] - | ConstantOffset (n, suboffset) -> n :: (get_constant_offsets suboffset) + | NoOffset -> Ok [numerical_zero] + | ConstantOffset (n, suboffset) -> + TR.tmap (fun subo -> n :: subo) (get_constant_offsets suboffset) | _ -> + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Offset is not constant: " + ^ (memory_offset_to_string offset)] + (* raise (BCH_failure (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; STR "offset "; STR (memory_offset_to_string offset); - STR " is not constant"])) + STR " is not constant"])) *) let rec add_offset @@ -235,9 +459,11 @@ let rec add_offset | UnknownOffset -> UnknownOffset -let get_total_constant_offset offset = - List.fold_left (fun acc n -> - acc#add n) numerical_zero (get_constant_offsets offset) +let get_total_constant_offset (offset: memory_offset_t): numerical_t traceresult = + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun nl -> List.fold_left (fun acc n -> acc#add n) numerical_zero nl) + (get_constant_offsets offset) let memory_offset_to_pretty offset = STR (memory_offset_to_string offset) @@ -255,6 +481,7 @@ let stack_offset_to_name offset = "var_" ^ (constant_offset_to_neg_suffix_string n) | ConstantOffset (n,NoOffset) when n#equal numerical_zero -> "var_0000" + | NoOffset -> "var_0000" | _ -> "var.[" ^ (memory_offset_to_string offset) ^ "]" @@ -293,6 +520,24 @@ let realigned_stack_offset_to_name offset = | _ -> "vrr.[" ^ (memory_offset_to_string offset) ^ "]" +let rec boffset_to_memory_offset + (boffset: boffset_t): memory_offset_t traceresult = + match boffset with + | BCHBCTypes.NoOffset -> Ok BCHLibTypes.NoOffset + | Field (fuse, suboffset) -> + tmap + (fun o -> FieldOffset (fuse, o)) + (boffset_to_memory_offset suboffset) + | Index (Const (CInt (i64, _, _)), suboffset) -> + tmap + (fun o -> + let x = num_constant_expr (mkNumericalFromInt64 i64) in + ArrayIndexOffset (x, o)) + (boffset_to_memory_offset suboffset) + | Index (bexp, _) -> + Error ["Unable to convert array index expression " ^ (exp_to_string bexp)] + + class memory_reference_t ~(index: int) ~(base: memory_base_t):memory_reference_int = @@ -304,11 +549,11 @@ object (self:'a) method get_base = base - method get_name = + method get_name: string = match base with | BaseVar v -> v#getName#getBaseName - | BaseArray (v, _) -> v#getName#getBaseName - | BaseStruct (v, _) -> v#getName#getBaseName + | BaseArray (x, _) -> (x2s x) + | BaseStruct (x, _) -> (x2s x) | BLocalStackFrame -> "var" | BRealignedStackFrame -> "varr" | BAllocatedStackFrame -> "vara" @@ -325,25 +570,25 @@ object (self:'a) match base with | BaseVar v -> Ok v | _ -> - Error [ - "get_external_base: not an external base: " - ^ (memory_base_to_string base)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not an external base: " + ^ (memory_base_to_string base)] - method get_array_base: (variable_t * btype_t) traceresult = + method get_array_base: (xpr_t * btype_t) traceresult = match base with - | BaseArray (v, t) -> Ok (v, t) + | BaseArray (x, t) -> Ok (x, t) | _ -> - Error [ - "get_array_base: not an array base: " - ^ (memory_base_to_string base)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not an array base: " + ^ (memory_base_to_string base)] - method get_struct_base: (variable_t * btype_t) traceresult = + method get_struct_base: (xpr_t * btype_t) traceresult = match base with - | BaseStruct (v, t) -> Ok (v, t) + | BaseStruct (x, t) -> Ok (x, t) | _ -> - Error [ - "get_struct_base: not a struct base: " - ^ (memory_base_to_string base)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not a struct base: " + ^ (memory_base_to_string base)] method has_external_base = match base with BaseVar _ -> true | _ -> false @@ -366,7 +611,7 @@ object (self:'a) method is_unknown_reference = match base with BaseUnknown _ -> true | _ -> false - method toPretty = LBLOCK [ memory_base_to_pretty base ] + method toPretty = LBLOCK [memory_base_to_pretty base] end @@ -401,11 +646,11 @@ object (self) method mk_basevar_reference v = self#mk_reference (BaseVar v) - method mk_base_array_reference (v: variable_t) (t: btype_t) = - self#mk_reference (BaseArray (v, t)) + method mk_base_array_reference (x: xpr_t) (t: btype_t) = + self#mk_reference (BaseArray (x, t)) - method mk_base_struct_reference (v: variable_t) (t: btype_t) = - self#mk_reference (BaseStruct (v, t)) + method mk_base_struct_reference (x: xpr_t) (t: btype_t) = + self#mk_reference (BaseStruct (x, t)) method mk_unknown_reference s = self#mk_reference (BaseUnknown s) @@ -413,8 +658,8 @@ object (self) if H.mem table index then Ok (H.find table index) else - Error [ - "get_memory_reference_int: index not found: " ^ (string_of_int index)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Memory reference index not found: " ^ (string_of_int index)] method get_memory_reference_type (index: int): btype_t option = tfold_default @@ -425,13 +670,13 @@ object (self) method is_unknown_reference (index: int): bool traceresult = let memref_r = self#get_memory_reference index in tmap - ~msg:"is_unknown_reference" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun memref -> memref#is_unknown_reference) memref_r method is_global_reference (index: int): bool traceresult = let memref_r = self#get_memory_reference index in tmap - ~msg:"is_global_reference" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun memref -> memref#is_global_reference) memref_r method initialize = diff --git a/CodeHawk/CHB/bchlib/bCHMemoryReference.mli b/CodeHawk/CHB/bchlib/bCHMemoryReference.mli index ac885262..d9389359 100644 --- a/CodeHawk/CHB/bchlib/bCHMemoryReference.mli +++ b/CodeHawk/CHB/bchlib/bCHMemoryReference.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020-2021 Henny Sipma - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -32,6 +32,12 @@ open CHLanguage open CHNumerical open CHPretty +(* chutil *) +open CHTraceResult + +(* xprlib *) +open XprTypes + (* bchlib *) open BCHBCTypes open BCHLibTypes @@ -61,6 +67,15 @@ val memory_offset_compare: memory_offset_t -> memory_offset_t -> int val mk_maximal_memory_offset: numerical_t -> btype_t -> memory_offset_t +val add_offset: memory_offset_t -> memory_offset_t -> memory_offset_t + +val address_memory_offset: + ?tgtsize: int option + -> ?tgtbtype: btype_t + -> btype_t + -> xpr_t + -> memory_offset_t traceresult + (** {1 Offset predicates} *) @@ -83,23 +98,18 @@ val is_index_offset: memory_offset_t -> bool val is_unknown_offset: memory_offset_t -> bool -(** {1 Offset constructors} *) - -val add_offset: memory_offset_t -> memory_offset_t -> memory_offset_t - - (** {1 Offset deconstructors} *) (** Returns a list of numerical offset and suboffsets. - @raise [BCH_failure} if [memoff] is not a constant_offset. *) -val get_constant_offsets: memory_offset_t -> numerical_t list + Returns an Error if [memoff] is not a constant_offset. *) +val get_constant_offsets: memory_offset_t -> numerical_t list traceresult (** Returns the sum of all numerical offsets in [memoff]. - @raise [BCH_failure] if [memoff] is not a constant offset. *) -val get_total_constant_offset: memory_offset_t -> numerical_t + Returns an Error if not all offsets are constant. *) +val get_total_constant_offset: memory_offset_t -> numerical_t traceresult (** Returns the list of index variables in [memoff] (including suboffsets. @@ -107,6 +117,10 @@ val get_total_constant_offset: memory_offset_t -> numerical_t val get_index_offset_variables: memory_offset_t -> variable_t list +val boffset_to_memory_offset: + BCHBCTypes.boffset_t -> memory_offset_t CHTraceResult.traceresult + + (** {1 Memory reference manager} *) val make_memory_reference_manager: diff --git a/CodeHawk/CHB/bchlib/bCHPreFileIO.ml b/CodeHawk/CHB/bchlib/bCHPreFileIO.ml index 8113a53f..92529093 100644 --- a/CodeHawk/CHB/bchlib/bCHPreFileIO.ml +++ b/CodeHawk/CHB/bchlib/bCHPreFileIO.ml @@ -364,6 +364,12 @@ let get_global_state_filename () = let _ = create_directory fdir in Filename.concat fdir (exename ^ "_global_state.xml") +let get_global_memory_map_filename () = + let exename = get_filename () in + let fdir = get_analysis_dir () in + let _ = create_directory fdir in + Filename.concat fdir (exename ^ "_global_locations.xml") + let get_system_info_filename () = let exename = get_filename () in let fdir = get_analysis_dir () in diff --git a/CodeHawk/CHB/bchlib/bCHPreFileIO.mli b/CodeHawk/CHB/bchlib/bCHPreFileIO.mli index 203213e5..5ea8b236 100644 --- a/CodeHawk/CHB/bchlib/bCHPreFileIO.mli +++ b/CodeHawk/CHB/bchlib/bCHPreFileIO.mli @@ -56,6 +56,7 @@ val get_pwr_assembly_instructions_filename: unit -> string val get_functions_filename: unit -> string val get_global_state_filename: unit -> string +val get_global_memory_map_filename: unit -> string val get_system_info_filename: unit -> string val get_jni_calls_filename: unit -> string val get_resultmetrics_filename: unit -> string (* analysis round statistics *) diff --git a/CodeHawk/CHB/bchlib/bCHSumTypeSerializer.ml b/CodeHawk/CHB/bchlib/bCHSumTypeSerializer.ml index 290e57ea..ec62f370 100644 --- a/CodeHawk/CHB/bchlib/bCHSumTypeSerializer.ml +++ b/CodeHawk/CHB/bchlib/bCHSumTypeSerializer.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020 Henny Sipma - Copyrigth (c) 2021-2024 Aarno Labs LLC + Copyrigth (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 @@ -680,11 +680,11 @@ object | InitialMemoryValue _ -> "iv" | FrozenTestValue _ -> "ft" | FunctionReturnValue _ -> "fr" + | TypeCastValue _ -> "tc" | SyscallErrorReturnValue _ -> "ev" | FunctionPointer _ -> "fp" | CallTargetValue _ -> "ct" | SideEffectValue _ -> "se" - | MemoryAddress _ -> "ma" | BridgeVariable _ -> "bv" | FieldValue _ -> "fv" | SymbolicValue _ -> "sv" @@ -695,7 +695,7 @@ object method !tags = [ "bv"; "chiftemp"; "ct"; "ev"; "fr"; "fp"; "ft"; "fv"; "ir"; - "iv"; "ma"; "rt"; "se" ; "sp"; "sv"; "ssv"] + "iv"; "rt"; "se" ; "sp"; "sv"; "ssv"; "tc"] end diff --git a/CodeHawk/CHB/bchlib/bCHSystemInfo.ml b/CodeHawk/CHB/bchlib/bCHSystemInfo.ml index b842819a..a84c9141 100644 --- a/CodeHawk/CHB/bchlib/bCHSystemInfo.ml +++ b/CodeHawk/CHB/bchlib/bCHSystemInfo.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 @@ -49,6 +49,7 @@ open CHUtils (* chutil *) open CHLogger open CHPrettyUtil +open CHTraceResult open CHXmlDocument open CHXmlReader @@ -58,7 +59,6 @@ open BCHBCTypes open BCHBCTypeXml open BCHByteUtilities open BCHCallbackTables -open BCHConstantDefinitions open BCHCppClass open BCHCStruct open BCHCStructConstant @@ -155,7 +155,6 @@ object (self) val initialized_memory = H.create 3 val function_call_targets = H.create 13 (* (faddr, iaddr) -> call_target_t *) - val variable_intros = H.create 13 (* iaddr#index -> name *) val esp_adjustments = H.create 3 (* indexed with faddr, iaddr *) val esp_adjustments_i = H.create 3 (* indexed with iaddr *) @@ -611,6 +610,18 @@ object (self) set_functions_file_path () end + method initialize_function_annotations = + match load_userdata_system_file () with + | Some node -> + let getc = node#getTaggedChild in + let hasc = node#hasOneTaggedChild in + begin + (if hasc "function-annotations" then + BCHFunctionData.read_xml_function_annotations + (getc "function-annotations")) + end + | _ -> () + method private initialize_system_file = try match load_system_file () with @@ -674,7 +685,7 @@ object (self) end | _ -> () - method private read_xml_user_data (node:xml_element_int) = + method read_xml_user_data (node:xml_element_int) = let get = node#getAttribute in let has = node#hasNamedAttribute in let getc = node#getTaggedChild in @@ -830,10 +841,7 @@ object (self) function_summary_library#read_xml_constants_files (getc "use-constants")); (if hasc "symbolic-addresses" then - read_xml_symbolic_addresses (getc "symbolic-addresses")); - - (if hasc "variable-introductions" then - self#read_xml_variable_introductions (getc "variable-introductions")); + BCHGlobalMemoryMap.read_xml_symbolic_addresses (getc "symbolic-addresses")); (if hasc "userdeclared-codesections" then self#read_xml_userdeclared_codesections @@ -1409,39 +1417,6 @@ object (self) let name = get n "n" in (functions_data#add_function fa)#add_name name) (getcc "fn") - method private read_xml_variable_introductions (node: xml_element_int) = - let geta n = - fail_tvalue - (trerror_record - (LBLOCK [ - STR "read_xml_variable_introductions"; - STR (n#getAttribute "ia")])) - (string_to_doubleword (n#getAttribute "ia")) in - let getcc = node#getTaggedChildren in - begin - List.iter (fun n -> - let iaddr = geta n in - let name = n#getAttribute "name" in - H.add variable_intros iaddr#index name) (getcc "vintro"); - chlog#add - "initialization" - (LBLOCK [ - STR "system-info: read "; - INT (H.length variable_intros); - STR " variable introductions"]) - end - - method private write_xml_variable_introductions (node: xml_element_int) = - let vintros = H.fold (fun k v a -> (k, v)::a) variable_intros [] in - List.iter (fun (dwindex, name) -> - let vnode = xmlElement "vintro" in - begin - vnode#setAttribute - "ia" (TR.tget_ok (int_to_doubleword dwindex))#to_hex_string; - vnode#setAttribute "name" name; - node#appendChildren [vnode]; - end) vintros - method private read_xml_user_nonreturning_functions (node:xml_element_int) = let geta n = fail_tvalue @@ -1551,8 +1526,6 @@ object (self) self#read_xml_thread_start_functions (getc "thread-start-functions")) ; (if hasc "goto-returns" then self#read_xml_goto_returns (getc "goto-returns")); - (if hasc "variable-introductions" then - self#read_xml_variable_introductions (getc "variable-introductions")); (if hasc "so-imports" then self#read_xml_so_imports (getc "so-imports")); end @@ -1710,19 +1683,6 @@ object (self) dNode end) data_blocks#toList) - method has_variable_intro (iaddr: doubleword_int) = - H.mem variable_intros iaddr#index - - method has_variable_intros: bool = (H.length variable_intros) > 0 - - method get_variable_intro_name (iaddr: doubleword_int): string = - if self#has_variable_intro iaddr then - H.find variable_intros iaddr#index - else - raise - (BCH_failure - (LBLOCK [STR "No variable intro found for address "; iaddr#toPretty])) - (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * * stage 2: function entry points * * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) @@ -1865,9 +1825,14 @@ object (self) method get_size = String.length !file_as_string - method get_file_input ?(hexSize=wordzero) (hexOffset:doubleword_int) = - let fString = self#get_file_string ~hexSize hexOffset in - file_stream_wrapper_function (IO.input_string fString) + method get_file_input + ?(hexSize=wordzero) + (hexOffset:doubleword_int): stream_wrapper_int traceresult = + let fString_r = self#get_file_string ~hexSize hexOffset in + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun s -> file_stream_wrapper_function (IO.input_string s)) + fString_r method private get_encodings (va:doubleword_int) (len:int) = let encoding_to_pretty (ty, va, size, key, width) = @@ -1895,30 +1860,19 @@ object (self) | [] -> s | encodings -> decode_string s va encodings - method get_file_string ?(hexSize=wordzero) (hexOffset:doubleword_int) = + method get_file_string + ?(hexSize=wordzero) (hexOffset:doubleword_int): string traceresult = let offset = hexOffset#to_int in let size = hexSize#to_int in let len = String.length !file_as_string in if size > 0 then if offset > len then - let hexLen = - fail_tvalue - (trerror_record - (LBLOCK [ - STR "system_info:get_file_string:hexLen: "; INT len])) - (int_to_doubleword len) in - begin - ch_error_log#add - "invalid argument" - (LBLOCK [ - STR "Unable to return input at offset "; - hexOffset#toPretty; - STR " -- file size = "; - hexLen#toPretty ]); - raise - (Invalid_argument - "assembly_xreference_t#get_exe_string_at_offset") - end + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to return input at offset " + ^ (string_of_int size) + ^ "; file size is " + ^ (string_of_int len)] else if offset + size > len then let sizeAvailable = len - offset in @@ -1935,18 +1889,19 @@ object (self) STR " and filling up the rest with zeroes"]); if len > offset then let missing = Bytes.make (size - sizeAvailable) (Char.chr 0) in - String.concat - "" - [string_suffix !file_as_string offset; - Bytes.to_string missing] + Ok (String.concat + "" + [string_suffix !file_as_string offset; + Bytes.to_string missing]) else - raise (BCH_failure - (LBLOCK [ - STR "get-file-string (error case): "; - STR "String.suffix: Length: "; - INT len; - STR "; offset: "; - INT offset])) + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to return input of size " + ^ (string_of_int size) + ^ " at offset " + ^ (string_of_int offset) + ^ "; sum exceeds file size of " + ^ (string_of_int len)] end else begin @@ -1958,29 +1913,29 @@ object (self) STR "only returning "; INT sizeAvailable]); if len > offset then - string_suffix !file_as_string offset + Ok (string_suffix !file_as_string offset) else - raise (BCH_failure - (LBLOCK [ - STR "get-file-string (error case): "; - STR "String.suffix: Length: "; - INT len; - STR "; offset: "; - INT offset])) + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to return input of size " + ^ (string_of_int size) + ^ " at offset " + ^ (string_of_int offset) + ^ "; sum exceeds file size of " + ^ (string_of_int len)] end else - String.sub !file_as_string offset size + Ok (String.sub !file_as_string offset size) else if len > offset then - string_suffix !file_as_string offset + Ok (string_suffix !file_as_string offset) else - raise - (BCH_failure - (LBLOCK [ - STR "get-file-string: String.suffix: Length: "; - INT len; - STR "; offset: "; - INT offset])) + Error [ + __FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to return file input suffix. Offset " + ^ (string_of_int offset) + ^ " exceeds file size " + ^ (string_of_int offset)] method set_image_base (a:doubleword_int) = begin image_base <- a ; system_data#set_image_base a end @@ -2153,7 +2108,6 @@ object (self) let gNode = xmlElement "goto-returns" in let cbNode = xmlElement "call-back-tables" in let stNode = xmlElement "struct-tables" in - let viNode = xmlElement "variable-introductions" in let soNode = xmlElement "so-imports" in begin functions_data#write_xml fNode; @@ -2164,11 +2118,10 @@ object (self) self#write_xml_goto_returns gNode; self#write_xml_call_back_tables cbNode; self#write_xml_struct_tables stNode; - self#write_xml_variable_introductions viNode; string_table#write_xml sNode; self#write_xml_so_imports soNode; append [ - fNode; lNode; dNode; jNode; sNode; tNode; gNode; cbNode; stNode; viNode; + fNode; lNode; dNode; jNode; sNode; tNode; gNode; cbNode; stNode; soNode] end diff --git a/CodeHawk/CHB/bchlib/bCHTypeConstraintStore.ml b/CodeHawk/CHB/bchlib/bCHTypeConstraintStore.ml index 2f38645c..d8fad46b 100644 --- a/CodeHawk/CHB/bchlib/bCHTypeConstraintStore.ml +++ b/CodeHawk/CHB/bchlib/bCHTypeConstraintStore.ml @@ -267,6 +267,8 @@ object (self) method evaluate_reglhs_type (reg: register_t) (faddr: string) (iaddr: string) :(type_variable_t list * type_constant_t list) list = + let logresults = iaddr = "0xffffffff" in + let p2s = CHPrettyUtil.pretty_to_string in let konstraints = self#get_reglhs_constraints reg faddr iaddr in let termset = new IntCollections.set_t in let constraintset = new IntCollections.set_t in @@ -304,27 +306,60 @@ object (self) end done; let tygraph = mk_type_constraint_graph () in + let _ = + if logresults then + log_result __FILE__ __LINE__ ["DEBUG: " ^ (p2s tygraph#toPretty)] in begin tygraph#initialize (List.map tcd#get_type_term termset#toList); constraintset#iter (fun ixc -> let c = tcd#get_type_constraint ixc in tygraph#add_constraint c); let newgraph = tygraph#saturate in + let _ = + if logresults then + log_result __FILE__ __LINE__ ["DEBUG: " ^ (p2s newgraph#toPretty)] in let newgraph = newgraph#saturate in + let _ = + if logresults then + log_result __FILE__ __LINE__ ["DEBUG: " ^ (p2s newgraph#toPretty)] in let partition = newgraph#partition in + let _ = + if logresults then + log_result __FILE__ __LINE__ ["DEBUG: " ^ + (p2s + (pretty_print_list + partition (fun p -> p#toPretty) + "[ " "; " "]"))] in List.fold_left (fun acc s -> let terms = List.map tcd#get_type_term s#toList in + let _ = + if logresults then + log_result __FILE__ __LINE__ + ["terms: " ^ + (String.concat "; " (List.map type_term_to_string terms))] in let reglhsvars = List.fold_left (fun acc t -> match t with | TyVariable tv when has_reg_lhs_basevar reg faddr iaddr t -> tv :: acc | _ -> acc) [] terms in + let _ = + if logresults then + log_result __FILE__ __LINE__ + ["vars: " ^ + (String.concat "; " + (List.map type_variable_to_string reglhsvars))] in let tyconsts = List.fold_left (fun acc t -> match t with | TyConstant c -> c :: acc | _ -> acc) [] terms in + let _ = + if logresults then + log_result __FILE__ __LINE__ + ["consts: " ^ + (String.concat "; " + (List.map type_constant_to_string tyconsts))] in match (reglhsvars, tyconsts) with | ([], _) -> acc | (_, []) -> acc @@ -402,6 +437,7 @@ object (self) method resolve_reglhs_type (reg: register_t) (faddr: string) (iaddr: string): btype_t option = let evaluation = self#evaluate_reglhs_type reg faddr iaddr in + let logresults = iaddr = "0xffffffff" in let log_evaluation () = chlog#add ("reglhs resolution was not successfull:" ^ faddr) @@ -429,6 +465,10 @@ object (self) begin List.iter (fun (vars, consts) -> let jointy = type_constant_join consts in + let _ = + if logresults then + log_result __FILE__ __LINE__ + ["jointy: " ^ (type_constant_to_string jointy)] in List.iter (fun v -> let optty = match jointy with @@ -438,11 +478,11 @@ object (self) | [] -> Some (type_constant_to_btype jointy) | [Deref | Load | Store] -> Some (t_ptrto (type_constant_to_btype jointy)) - | [Load; OffsetAccess _] -> + | [Load; OffsetAccess (_, 0)] -> Some (t_ptrto (type_constant_to_btype jointy)) - | [Store; OffsetAccess _] -> + | [Store; OffsetAccess (_, 0)] -> Some (t_ptrto (type_constant_to_btype jointy)) - | [OffsetAccessA (size, _)] -> + | [OffsetAccessA (size, 0)] -> Some (t_array (type_constant_to_btype jointy) size) | _ -> None in match optty with diff --git a/CodeHawk/CHB/bchlib/bCHTypeConstraintUtil.ml b/CodeHawk/CHB/bchlib/bCHTypeConstraintUtil.ml index b557678d..6578bbc5 100644 --- a/CodeHawk/CHB/bchlib/bCHTypeConstraintUtil.ml +++ b/CodeHawk/CHB/bchlib/bCHTypeConstraintUtil.ml @@ -237,6 +237,8 @@ let join_tc (t1: type_constant_t) (t2: type_constant_t): type_constant_t = | TyTUnknown, _ -> TyTUnknown | _, TyTUnknown -> TyTUnknown | TyTStruct (i, _), TyTStruct (j, _) when i=j -> t1 + | TyTStruct (i, _), TyTStruct (j, _) when is_sub_struct i j -> t2 + | TyTStruct (i, _), TyTStruct (j, _) when is_sub_struct j i -> t1 | TyTStruct _, _ -> TyTUnknown | _, TyTStruct _ -> TyTUnknown | TyTFloat fk1, TyTFloat fk2 -> join_tc_fkind fk1 fk2 @@ -416,7 +418,11 @@ let ikind_to_signedsize (k: ikind_t): (signedness_t * int) = let rec mk_btype_constraint (tv: type_variable_t) (ty: btype_t) : type_constraint_t option = match (resolve_type ty) with - | Error _ -> None + | Error e -> + begin + log_error_result __FILE__ __LINE__ e; + None + end | Ok ty -> match ty with | TInt (ikind, _) -> @@ -447,14 +453,11 @@ let rec mk_btype_constraint (tv: type_variable_t) (ty: btype_t) end) | rty -> begin - chlog#add - "make btype constraint" - (LBLOCK [ - STR "Not yet supported: "; - btype_to_pretty ty; - STR " ("; - btype_to_pretty rty; - STR ")"]); + log_result + __FILE__ __LINE__ + ["make btype constraint not yet supported for " + ^ (btype_to_string ty) + ^ " (" ^ (btype_to_string rty) ^ ")"]; None end diff --git a/CodeHawk/CHB/bchlib/bCHUtilities.ml b/CodeHawk/CHB/bchlib/bCHUtilities.ml index c788ed5a..8fb8ad64 100644 --- a/CodeHawk/CHB/bchlib/bCHUtilities.ml +++ b/CodeHawk/CHB/bchlib/bCHUtilities.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2019 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 @@ -14,10 +14,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 @@ -70,7 +70,7 @@ let get_date_and_time () = | 4 -> "Thu" | 5 -> "Fri" | 6 -> "Sat" - | _ -> + | _ -> begin ch_error_log#add "invalid argument" @@ -116,7 +116,7 @@ let make_date_and_time_string (tm:Unix.tm) = | 10 -> "Oct" | 11 -> "Nov" | 12 -> "Dec" - | _ -> + | _ -> begin ch_error_log#add "invalid argument" @@ -134,24 +134,23 @@ let make_date_and_time_string (tm:Unix.tm) = | 5 -> "Thu" | 6 -> "Fri" | 7 -> "Sat" - | _ -> + | _ -> begin ch_error_log#add "invalid argument" (LBLOCK [ STR "make_date_and_time_string: Unexpected value of day: "; INT wd]); - raise (Invalid_argument "make_date_and_time") + raise (Invalid_argument "make_date_and_time") end in Printf.sprintf "%s %s %d %d:%d:%d %d" day month md hr min sec yr (* Continuous logging *) - + let activity_log = ref "" -let results_log = ref "" - -let initialize_activity_log s = + +let initialize_activity_log s = let filename = s ^ "_ch_activity_log" in begin file_output#saveFile @@ -159,37 +158,22 @@ let initialize_activity_log s = (LBLOCK [STR "CodeHawk activity log for "; STR s; NL; NL]); activity_log := filename end - -let initialize_results_log s = - let filename = s ^ "_ch_results_log" in - begin - file_output#saveFile - filename - (LBLOCK [STR "CodeHawk results log for "; STR s; NL; NL]); - results_log := filename - end - + let log_activity p = if !activity_log = "" then pr_debug [STR "Warning: Activity log is not initialized"; NL] else let msg = LBLOCK [STR (get_date_and_time ()); STR ": "; p; NL] in file_output#appendToFile !activity_log msg - -let log_result p = - if !results_log = "" then - pr_debug [STR "Warning: Results log is not initialized"; NL] - else - file_output#appendToFile !results_log (LBLOCK [p; NL]) - + let translation_log = mk_logger () let disassembly_log = mk_logger () (* Facilities to manipulate jar files *) - + exception No_file_found of string - + let replace_dot s = let newstring = Bytes.copy (Bytes.of_string s) in for i = 0 to (Bytes.length newstring) - 1 do @@ -197,25 +181,25 @@ let replace_dot s = Bytes.set newstring i '_' done; Bytes.to_string newstring - -let replace_slash s = + +let replace_slash s = if s = "" then s else - if s.[0] = '/' then + if s.[0] = '/' then "_slashfwd_" ^ (String.sub s 1 ((String.length s) - 1)) else s - + let is_file f = try (Unix.stat f).Unix.st_kind = Unix.S_REG with Unix.Unix_error (Unix.ENOENT, _,_) -> false - + let exists_file s: (string * Zip.in_file) -> bool = let s = s ^ ".xml" in function (_,jar) -> - (try - begin ignore (Zip.find_entry jar s) ; true end + (try + begin ignore (Zip.find_entry jar s) ; true end with Not_found -> false) - -let open_path s:(string * Zip.in_file) option = + +let open_path s:(string * Zip.in_file) option = if Filename.check_suffix s ".jar" && is_file s then begin chlog#add "jar file" (LBLOCK [ STR "Opening jar file " ; STR s ]) ; @@ -226,30 +210,30 @@ let open_path s:(string * Zip.in_file) option = chlog#add "jar file" (LBLOCK [ STR "Unable to open jar file " ; STR s ]) ; None end - + let lookup_summary name: (string * Zip.in_file) -> string = let filename = name ^ ".xml" in - function (_, jar) -> + function (_, jar) -> try Zip.read_entry jar (Zip.find_entry jar filename) with Not_found -> raise (No_file_found name) - + let rec fold_directories (f: 'b -> 'a) file : 'b list -> 'a = function | [] -> raise (No_file_found file) | path :: tl -> try f path with No_file_found _ -> fold_directories f file tl - + let rec fold_directories_for_existence (f: 'b -> 'a) file : 'b list -> 'a = function | [] -> false | path :: tl -> f path || fold_directories_for_existence f file tl - + let has_summary_file path c = fold_directories_for_existence (fun path -> exists_file c path) c path - + let get_summary_file path c = fold_directories (fun path -> lookup_summary c path) c path let lookup_file filename: (string * Zip.in_file) -> string = - function (_, jar) -> + function (_, jar) -> try Zip.read_entry jar (Zip.find_entry jar filename) with Not_found -> raise (No_file_found filename) @@ -258,7 +242,7 @@ let get_file_from_jar path c = Some (fold_directories (fun path -> lookup_file c path) c path) with No_file_found _ -> None - + let apply_to_xml_jar f other jar = List.iter (fun e -> @@ -266,29 +250,29 @@ let apply_to_xml_jar f other jar = f e.Zip.filename (Zip.read_entry jar e) else other jar e) (Zip.entries jar) - - - + + + (* facilities to associate strings with sum types *) - - + + let add_to_sumtype_tables - (toTable:('a,string) Hashtbl.t) - (fromTable:(string,'a) Hashtbl.t) - (stype:'a) + (toTable:('a,string) Hashtbl.t) + (fromTable:(string,'a) Hashtbl.t) + (stype:'a) (name:string) = begin Hashtbl.add toTable stype name ; Hashtbl.add fromTable name stype end - + let get_string_from_table (tablename:string) (table:('a, string) Hashtbl.t) (stype:'a) = if Hashtbl.mem table stype then Hashtbl.find table stype else raise (Invalid_argument ("get_string_from_table " ^ tablename)) - + let get_sumtype_from_table (tablename:string) (table:(string, 'a) Hashtbl.t) (name:string) = if Hashtbl.mem table name then @@ -296,23 +280,23 @@ let get_sumtype_from_table else raise (Invalid_argument ("get_sumtype_from_table " ^ tablename ^ ": " ^ name)) - + let is_string_of_sumtype (table:(string, 'a) Hashtbl.t) (name:string) = Hashtbl.fold (fun k _ a -> a || k = name) table false let get_sumtype_table_keys (table:('a, string) Hashtbl.t) = H.fold (fun k _ a -> k::a) table [] - - - + + + (* comparison utilities *) - + let interval_compare (i1:interval_t) (i2:interval_t) = let min1 = i1#getMin in let min2 = i2#getMin in - if min1#lt min2 then -1 + if min1#lt min2 then -1 else if min2#lt min1 then 1 - else + else let max1 = i1#getMax in let max2 = i2#getMax in if max1#lt max2 then -1 @@ -341,12 +325,12 @@ let optvalue_compare (o1:'a option) (o2:'a option) (f:'a -> 'a -> int): int = | (_, Some _) -> 1 | (None,None) -> 0 - + let byte_to_string (b:int) = let l = b mod 16 in let h = b lsr 4 in Printf.sprintf "%x%x" h l - + let hex_string s = let ch = IO.input_string s in let h = ref "" in @@ -356,14 +340,14 @@ let hex_string s = do h := !h ^ (byte_to_string (IO.read_byte ch)) done; !h end - + let has_control_characters s = let found = ref false in - let _ = String.iter (fun c -> + let _ = String.iter (fun c -> if !found then () else if Char.code c = 10 then (* NL *) () - else if (Char.code c) < 32 || (Char.code c) > 126 then + else if (Char.code c) < 32 || (Char.code c) > 126 then found := true) s in !found diff --git a/CodeHawk/CHB/bchlib/bCHUtilities.mli b/CodeHawk/CHB/bchlib/bCHUtilities.mli index 30bf5cc5..abcd7322 100644 --- a/CodeHawk/CHB/bchlib/bCHUtilities.mli +++ b/CodeHawk/CHB/bchlib/bCHUtilities.mli @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. Sipma - Copyright (c) 2021-2023 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 @@ -71,9 +71,7 @@ val timing: unit -> string exception No_file_found of string val initialize_activity_log: string -> unit -val initialize_results_log : string -> unit val log_activity: pretty_t -> unit -val log_result : pretty_t -> unit val translation_log: logger_int val disassembly_log: logger_int diff --git a/CodeHawk/CHB/bchlib/bCHVarDictionary.ml b/CodeHawk/CHB/bchlib/bCHVarDictionary.ml index a52d5bfa..af90df97 100644 --- a/CodeHawk/CHB/bchlib/bCHVarDictionary.ml +++ b/CodeHawk/CHB/bchlib/bCHVarDictionary.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 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 @@ -117,8 +117,8 @@ object (self) | BAllocatedStackFrame | BGlobal -> (tags, []) | BaseVar v -> (tags, [xd#index_variable v]) - | BaseArray (v, t) -> (tags, [xd#index_variable v; bcd#index_typ t]) - | BaseStruct (v, t) -> (tags, [xd#index_variable v; bcd#index_typ t]) + | BaseArray (x, t) -> (tags, [xd#index_xpr x; bcd#index_typ t]) + | BaseStruct (x, t) -> (tags, [xd#index_xpr x; bcd#index_typ t]) | BaseUnknown s -> (tags, [bd#index_string s]) in memory_base_table#add key @@ -133,8 +133,8 @@ object (self) | "a" -> BAllocatedStackFrame | "g" -> BGlobal | "v" -> BaseVar (xd#get_variable (a 0)) - | "b" -> BaseArray (xd#get_variable (a 0), bcd#get_typ (a 1)) - | "s" -> BaseStruct (xd#get_variable (a 0), bcd#get_typ (a 1)) + | "b" -> BaseArray (xd#get_xpr (a 0), bcd#get_typ (a 1)) + | "s" -> BaseStruct (xd#get_xpr (a 0), bcd#get_typ (a 1)) | "u" -> BaseUnknown (bd#get_string (a 0)) | s -> raise_tag_error name s memory_base_mcts#tags @@ -198,18 +198,14 @@ object (self) | FrozenTestValue (v, a1, a2) -> (tags @ [a1; a2], [xd#index_variable v]) | FunctionReturnValue a -> (tags @ [a], []) + | TypeCastValue (iaddr, name, ty, reg) -> + (tags @ [iaddr; name], [bcd#index_typ ty; bd#index_register reg]) | SyscallErrorReturnValue a -> (tags @ [a], []) | FunctionPointer (s1, s2, a) -> (tags @ [a], [bd#index_string s1; bd#index_string s2]) | CallTargetValue t -> (tags, [id#index_call_target t]) | SideEffectValue (a, name, isglobal) -> (tags @ [a ], [bd#index_string name; (if isglobal then 1 else 0)]) - | MemoryAddress (i, o, opts, optty) -> - (tags, - [i; - self#index_memory_offset o; - (match opts with None -> -1 | Some s -> bd#index_string s); - match optty with None -> -1 | Some ty -> bcd#index_typ ty]) | BridgeVariable (a,i) -> (tags @ [a], [i]) | FieldValue (sname,offset,fname) -> (tags, [bd#index_string sname; offset; bd#index_string fname]) @@ -230,16 +226,11 @@ object (self) | "iv" -> InitialMemoryValue (xd#get_variable (a 0)) | "ft" -> FrozenTestValue (xd#get_variable (a 0), t 1, t 2) | "fr" -> FunctionReturnValue (t 1) + | "tc" -> TypeCastValue (t 1, t 2, bcd#get_typ (a 0), bd#get_register (a 1)) | "ev" -> SyscallErrorReturnValue (t 1) | "fp" -> FunctionPointer (bd#get_string (a 0), bd#get_string (a 1), t 1) | "ct" -> CallTargetValue (id#get_call_target (a 0)) | "se" -> SideEffectValue (t 1, bd#get_string (a 0), (a 1) = 1) - | "ma" -> - MemoryAddress ( - (a 0), - self#get_memory_offset (a 1), - (if (a 2) = -1 then None else Some (bd#get_string (a 2))), - (if (a 3) = -1 then None else Some (bcd#get_typ (a 3)))) | "bv" -> BridgeVariable (t 1, a 0) | "fv" -> FieldValue (bd#get_string (a 0), a 1, bd#get_string (a 2)) | "sv" -> SymbolicValue (xd#get_xpr (a 0)) diff --git a/CodeHawk/CHB/bchlib/bCHVariable.ml b/CodeHawk/CHB/bchlib/bCHVariable.ml index b474b7a6..2c316030 100644 --- a/CodeHawk/CHB/bchlib/bCHVariable.ml +++ b/CodeHawk/CHB/bchlib/bCHVariable.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 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 @@ -45,7 +45,6 @@ open XprTypes (* bchlib *) open BCHBasicTypes -open BCHBCTypePretty open BCHBCTypes open BCHBCTypeUtil open BCHCPURegisters @@ -60,10 +59,11 @@ module TR = CHTraceResult (* let x2p = xpr_formatter#pr_expr -let p2s = pretty_to_string let x2s x = p2s (x2p x) *) +let p2s = CHPrettyUtil.pretty_to_string + class assembly_variable_t ~(memrefmgr:memory_reference_manager_int) ~(vard: vardictionary_int) @@ -94,7 +94,10 @@ object (self:'a) | "var" -> stack_offset_to_name offset | "varr" -> realigned_stack_offset_to_name offset | "gv" -> global_offset_to_name size offset - | _ -> basename ^ (memory_offset_to_string offset)) + | _ -> + (match offset with + | NoOffset -> "__pderef_" ^ basename ^ "_" + | _ -> basename ^ (memory_offset_to_string offset))) | RegisterVariable reg -> register_to_string reg | CPUFlagVariable flag -> flag_to_string flag | AuxiliaryVariable a -> @@ -107,6 +110,8 @@ object (self:'a) | FunctionPointer (fname,cname,address) -> "fp_" ^ fname ^ "_" ^ cname ^ "_" ^ address | FunctionReturnValue address -> "rtn_" ^ address + | TypeCastValue (iaddr, name, _, reg) -> + "typecast_" ^ name ^ "_" ^ iaddr ^ "_" ^ (register_to_string reg) | SyscallErrorReturnValue address -> "errval_" ^ address | CallTargetValue tgt -> (match tgt with @@ -131,18 +136,6 @@ object (self:'a) "arg_" ^ (string_of_int n) ^ "_for_call_at_" ^ address | Special s -> "special_" ^ s | RuntimeConstant s -> "rtc_" ^ s - | MemoryAddress (i, offset, opts, optty) -> - (match (opts, optty) with - | (Some s, Some memty) -> - if is_array_type memty || is_struct_type memty then - s - else - "addr_" ^ s - | _ -> - "memaddr_" - ^ (string_of_int i) - ^ "_" - ^ (memory_offset_to_string offset)) | ChifTemp -> "temp" in let name = aux denotation in if has_control_characters name then @@ -175,7 +168,7 @@ object (self:'a) self#get_memref_field_type size suboffset | _ -> None - method get_type = + method get_type: btype_t option = let aux den = match den with | MemoryVariable (i, size, NoOffset) -> self#get_memref_type i size @@ -191,6 +184,7 @@ object (self:'a) | FrozenTestValue _ -> None | FunctionPointer _ -> None | FunctionReturnValue _ -> None + | TypeCastValue (_, _, ty, _) -> Some ty | SyscallErrorReturnValue _ -> None | CallTargetValue _ -> None | SideEffectValue _ -> None @@ -200,11 +194,10 @@ object (self:'a) | BridgeVariable _ -> None | Special _ -> None | RuntimeConstant _ -> None - | MemoryAddress (_, _, _, optty) -> optty | ChifTemp -> None in aux denotation - method to_basevar_reference = + method to_basevar_reference: memory_reference_int option = match denotation with | AuxiliaryVariable a -> (match a with @@ -229,71 +222,71 @@ object (self:'a) match denotation with | AuxiliaryVariable (CallTargetValue _) -> true | _ -> false - method get_calltarget_value = + method get_calltarget_value: call_target_t traceresult = match denotation with | AuxiliaryVariable (CallTargetValue tgt) -> Ok tgt | _ -> - Error - ["get_calltarget_value: " ^ self#get_name ^ " is not a calltarget value"] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable " ^ self#get_name ^ " is not a calltarget value"] method is_global_sideeffect = match denotation with | AuxiliaryVariable (SideEffectValue (_, _, isglobal)) -> isglobal | _ -> false - method get_global_sideeffect_target_address = + method get_global_sideeffect_target_address: doubleword_result = match denotation with | AuxiliaryVariable (SideEffectValue (_, arg, true)) -> let addr_r = string_to_doubleword arg in - tprop addr_r "get_global_sideeffect_target_address" + tprop addr_r (__FILE__ ^ ":" ^ (string_of_int __LINE__)) | _ -> - Error ["get_global_sideeffect_target_address: " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a global sideeffect value: " + ^ self#get_name] - method get_pointed_to_function_name = + method get_pointed_to_function_name: string traceresult = match denotation with | AuxiliaryVariable (FunctionPointer (name, _, _)) -> Ok name | _ -> - Error ["get_pointed_to_function_name: " ^ self#get_name] - - method get_memory_address_meminfo: - (int * memory_offset_t * string option * btype_t option) traceresult = - match denotation with - | AuxiliaryVariable (MemoryAddress (memrefix, memoffset, optname, optty)) -> - Ok (memrefix, memoffset, optname, optty) - | _ -> - Error ["get_memory_address_meminfo: variable is not a memory address: " - ^ (self#get_name)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a function pointer: " ^ self#get_name] method is_frozen_test_value = match denotation with | AuxiliaryVariable (FrozenTestValue _) -> true | _ -> false - method is_in_test_jump_range (a :ctxt_iaddress_t) = + method is_in_test_jump_range (a :ctxt_iaddress_t): bool traceresult = match denotation with | AuxiliaryVariable (FrozenTestValue (_, taddr, jaddr)) -> Ok (taddr < a && a <= jaddr) | _ -> - Error ["is_in_test_jump_range: " ^ a ^ ", " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a frozen test value: " ^ a ^ ", " ^ self#get_name] - method get_frozen_variable = + method get_frozen_variable: + (variable_t * ctxt_iaddress_t * ctxt_iaddress_t) traceresult = match denotation with | AuxiliaryVariable (FrozenTestValue (fv, taddr, jaddr)) -> Ok (fv, taddr, jaddr) | _ -> - Error ["get_frozen_variable: " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a frozen test value: " ^ self#get_name] - method get_call_site = + method get_call_site: ctxt_iaddress_t traceresult = match denotation with | (AuxiliaryVariable (FunctionReturnValue a)) | (AuxiliaryVariable (SideEffectValue (a, _, _))) -> Ok a | _ -> - Error ["get_call_site: " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a function return value or sideeffect value: " + ^ self#get_name] - method get_se_argument_descriptor = + method get_se_argument_descriptor: string traceresult = match denotation with | (AuxiliaryVariable (SideEffectValue (_, name, _))) -> Ok name - | _ -> Error ["get_se_argument_descriptor: " ^ self#get_name] + | _ -> Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a sideeffect value: " ^ self#get_name] method is_auxiliary_variable = match denotation with AuxiliaryVariable _ -> true | _ -> false @@ -320,20 +313,22 @@ object (self:'a) | InitialRegisterValue _ | InitialMemoryValue _ | FunctionReturnValue _ + | TypeCastValue _ | CallTargetValue _ | SideEffectValue _ | FieldValue _ | SymbolicValue _ - | MemoryAddress _ | SignedSymbolicValue _ -> true | _ -> false end | _ -> false - method get_register = + method get_register: register_t traceresult = match denotation with | RegisterVariable r -> Ok r - | _ -> Error ["get_register: " ^ self#get_name] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a register: " ^ self#get_name] method is_initial_register_value = match denotation with @@ -372,7 +367,7 @@ object (self:'a) | _ -> false) | _ -> false - method get_initial_register_value_register = + method get_initial_register_value_register: register_t traceresult = match denotation with | AuxiliaryVariable (InitialRegisterValue (CPURegister _ as reg, 0)) -> Ok reg @@ -389,33 +384,34 @@ object (self:'a) | AuxiliaryVariable (InitialRegisterValue (PowerSPRegister _ as reg, 0)) -> Ok reg | _ -> - Error ["get_initial_register_value_register: " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not an initial register value: " ^ self#get_name] - method get_initial_memory_value_variable = + method get_initial_memory_value_variable: variable_t traceresult = match denotation with | AuxiliaryVariable (InitialMemoryValue v) -> Ok v - | _ -> Error ["get_initial_memory_value_variable: " ^ self#get_name] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not an initial memory value: " ^ self#get_name] method is_memory_variable = match denotation with MemoryVariable _ -> true | _ -> false - method is_memory_address_variable = - match denotation with - | (AuxiliaryVariable (MemoryAddress _)) -> true - | _ -> false - - method get_memory_reference = + method get_memory_reference: memory_reference_int traceresult = match denotation with | MemoryVariable (i, _, _) -> let memref_r = memrefmgr#get_memory_reference i in - tprop memref_r ("get_memory_reference") + tprop memref_r (__FILE__ ^ ":" ^ (string_of_int __LINE__)) | _ -> - Error ["get_memory_reference: " ^ self#get_name] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a memory variable: " ^ self#get_name] - method get_memory_offset = + method get_memory_offset: memory_offset_t traceresult = match denotation with | MemoryVariable (_, _, o) -> Ok o - | _ -> Error ["get_memory_offset: " ^ self#get_name] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a memory variable: " ^ self#get_name] method is_register_variable = match denotation with RegisterVariable _ -> true | _ -> false @@ -485,11 +481,13 @@ object (self:'a) | AuxiliaryVariable (SignedSymbolicValue _) -> true | _ -> false - method get_symbolic_value_expr = + method get_symbolic_value_expr: xpr_t traceresult = match denotation with | AuxiliaryVariable (SymbolicValue x) -> Ok x | AuxiliaryVariable (SignedSymbolicValue (x, _, _)) -> Ok x - | _ -> Error ["get_symbolic_value_expr: " ^ self#get_name] + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a symbolic value: " ^ self#get_name] method toPretty = STR self#get_name @@ -539,11 +537,11 @@ object (self) else let var = new assembly_variable_t ~memrefmgr ~vard ~index ~denotation in begin - H.add vartable index var ; + H.add vartable index var; var end - method get_variable (v:variable_t) = + method get_variable (v:variable_t): assembly_variable_int traceresult = self#get_variable_by_index v#getName#getSeqNumber method get_assembly_variables = H.fold (fun _ v acc -> v::acc) vartable [] @@ -552,7 +550,8 @@ object (self) if H.mem vartable index then Ok (H.find vartable index) else - Error ["get_variable_by_index: " ^ (string_of_int index)] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ (string_of_int index)] method get_variable_type (v: variable_t): btype_t option = tfold_default @@ -562,30 +561,50 @@ object (self) method get_memvar_reference (v: variable_t): memory_reference_int traceresult = tbind - ~msg:"varmgr:get_memvar_reference" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_memory_reference) (self#get_variable v) method get_memval_reference (v: variable_t): memory_reference_int traceresult = tbind - ~msg:"varmgr:get_memval_reference" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun var -> self#get_memvar_reference var) (self#get_initial_memory_value_variable v) method get_memvar_offset (v:variable_t): memory_offset_t traceresult = tbind - ~msg:"varmgr:get_memvar_offset" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_memory_offset) (self#get_variable v) + method add_memvar_offset + (v: variable_t) + (memoff: memory_offset_t): assembly_variable_int traceresult = + tbind + (fun memvarref -> + tbind + (fun memvaroff -> + if is_unknown_offset memvaroff then + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable " ^ (p2s v#toPretty) ^ " has unknown offset"] + else + let newoff = add_offset memvaroff memoff in + Ok (self#make_memory_variable memvarref newoff)) + (self#get_memvar_offset v)) + (self#get_memvar_reference v) + method has_variable_index_offset (v: variable_t): bool = match self#get_memvar_offset v with | Ok (IndexOffset (v, _, _)) -> self#is_register_variable v + | Ok (ArrayIndexOffset (x, _)) -> + (match x with + | XConst (IntConst _) -> false + | _ -> true) | _ -> false method get_memval_offset (v: variable_t): memory_offset_t traceresult = tbind - ~msg:"varmgr:get_memval_offset" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun var -> self#get_memvar_offset var) (self#get_initial_memory_value_variable v) @@ -605,7 +624,7 @@ object (self) method make_memref_from_basevar (v: variable_t): memory_reference_int traceresult = tbind - ~msg:"make_memref_from_basevar_basevar" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun av -> match av#to_basevar_reference with | Some memref -> Ok memref @@ -619,35 +638,23 @@ object (self) | InitialRegisterValue (PowerGPRegister _, _) | InitialRegisterValue (PowerSPRegister _, _) | InitialMemoryValue _ - | FunctionReturnValue _ -> + | FunctionReturnValue _ + | TypeCastValue _ -> Ok (memrefmgr#mk_basevar_reference v) - | MemoryAddress (_, _, _, Some ty) when is_array_type ty -> - Ok (memrefmgr#mk_base_array_reference v ty) - | MemoryAddress (_, _, _, Some ty) when is_struct_type ty -> - Ok (memrefmgr#mk_base_struct_reference v ty) - | MemoryAddress (_, _, _, Some ty) -> - Error [ - "varmgr:make_memref_from_basevar: memory address that is " - ^ "not an array or struct: " - ^ v#getName#getBaseName - ^ " (" ^ (btype_to_string ty) ^ ")"] - | MemoryAddress (_, _, _, None) -> - Error [ - "varmgr:make_memref_from_basevar: memory address without " - ^ "type: " ^ v#getName#getBaseName] | _ -> - Ok (memrefmgr#mk_unknown_reference - ("base_" ^ v#getName#getBaseName))) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to make memref basevar from auxiliary variable: " + ^ v#getName#getBaseName]) | _ -> - Error [ - "varmgr:make_memref_from_basevar: not fixed-value: " - ^ v#getName#getBaseName])) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to make memref basevar from variable: " + ^ v#getName#getBaseName])) (self#get_variable v) - method make_register_variable (reg:register_t) = + method make_register_variable (reg:register_t): assembly_variable_int = self#mk_variable (RegisterVariable reg) - method make_flag_variable (flag: flag_t) = + method make_flag_variable (flag: flag_t): assembly_variable_int = self#mk_variable (CPUFlagVariable flag) method make_global_variable ?(size=4) ?(offset=NoOffset) (n:numerical_t) = @@ -655,13 +662,6 @@ object (self) let memref = memrefmgr#mk_global_reference in self#make_memory_variable ~size memref offset - method make_global_memory_address - ?(optname=None) ?(opttype=None) (n: numerical_t) = - let memref = memrefmgr#mk_global_reference in - let offset = ConstantOffset (n, NoOffset) in - self#mk_variable - (AuxiliaryVariable (MemoryAddress (memref#index, offset, optname, opttype))) - method make_frozen_test_value (var:variable_t) (taddr:ctxt_iaddress_t) (jaddr:ctxt_iaddress_t) = self#mk_variable (AuxiliaryVariable (FrozenTestValue (var, taddr, jaddr))) @@ -678,6 +678,10 @@ object (self) method make_return_value (iaddr:ctxt_iaddress_t) = self#mk_variable (AuxiliaryVariable (FunctionReturnValue iaddr)) + method make_typecast_value + (iaddr: ctxt_iaddress_t) (name: string) (ty: btype_t) (reg: register_t) = + self#mk_variable (AuxiliaryVariable (TypeCastValue (iaddr,name, ty, reg))) + method make_function_pointer_value (fname:string) (cname:string) (address:ctxt_iaddress_t) = self#mk_variable (AuxiliaryVariable (FunctionPointer (fname,cname,address))) @@ -704,80 +708,83 @@ object (self) method make_runtime_constant (name:string) = self#mk_variable (AuxiliaryVariable (RuntimeConstant name)) - method get_initial_memory_value_variable (v: variable_t) = + method get_initial_memory_value_variable (v: variable_t): variable_t traceresult = tbind - ~msg:"varmgr:get_initial_memory_value_variable" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_initial_memory_value_variable) (self#get_variable v) method get_pointed_to_function_name (v: variable_t) = tbind - ~msg:"varmgr:get_pointed_to_function_name" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_pointed_to_function_name) (self#get_variable v) - method get_stack_parameter_index (v: variable_t) = - tfold_default - (fun memref -> + method get_stack_parameter_index (v: variable_t): int option = + tfold + ~ok:(fun memref -> if memref#is_stack_reference then - tfold_default - (fun offset -> + tfold + ~ok:(fun offset -> if is_constant_offset offset then - let four = mkNumerical 4 in - let noffset = get_total_constant_offset offset in - if noffset#gt numerical_zero - && (noffset#modulo four)#equal numerical_zero then - Some ((noffset#div (mkNumerical 4))#toInt) - else - None + tfold + ~ok:(fun numoffset -> + let four = mkNumerical 4 in + if numoffset#gt numerical_zero + && (numoffset#modulo four)#equal numerical_zero then + Some ((numoffset#div four)#toInt) + else + None) + ~error:(fun _ -> None) + (get_total_constant_offset offset) else None) - None + ~error:(fun _ -> None) (self#get_memvar_offset v) else None) - None + ~error:(fun _ -> None) (self#get_memvar_reference v) - method get_register (v: variable_t) = + method get_register (v: variable_t): register_t traceresult = tbind - ~msg:"varmgr:get_register" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_register) (self#get_variable v) method get_call_site (v: variable_t) = tbind - ~msg:"varmgr:get_call_site" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_call_site) (self#get_variable v) method get_se_argument_descriptor (v: variable_t) = tbind - ~msg:"varmgr:get_se_argument_descriptor" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_se_argument_descriptor) (self#get_variable v) method get_initial_register_value_register (v: variable_t) = tbind - ~msg:"varmgr:get_initial_register_value_register" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_initial_register_value_register) (self#get_variable v) method get_frozen_variable (v: variable_t) = tbind - ~msg:"varmgr:get_fozen_variable" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_frozen_variable) (self#get_variable v) method get_calltarget_value (v: variable_t) = tbind - ~msg:"varmgr:get_calltarget_value" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_calltarget_value) (self#get_variable v) method get_symbolic_value_expr (v: variable_t) = tbind - ~msg:"varmgr:get_symbolic_value_expr" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_symbolic_value_expr) (self#get_variable v) @@ -785,22 +792,21 @@ object (self) self#is_global_variable v && (tfold_default is_constant_offset false (self#get_memvar_offset v)) - method get_global_variable_address (v: variable_t) = + method get_global_variable_address (v: variable_t): doubleword_result = if self#has_global_variable_address v then tbind - ~msg:"varmgr:get_global_variable_address" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun offset -> - let goffset = get_total_constant_offset offset in - numerical_to_doubleword goffset) + tbind numerical_to_doubleword (get_total_constant_offset offset)) (self#get_memvar_offset v) else - Error [ - "varmgr:get_global_variable_address: not a global variable: " - ^ v#getName#getBaseName] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Variable is not a global variable: " + ^ v#getName#getBaseName] method get_global_sideeffect_target_address (v: variable_t) = tbind - ~msg:"varmgr:get_global_sideeffect_target_address" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " ^ (p2s v#toPretty)) (fun av -> av#get_global_sideeffect_target_address) (self#get_variable v) @@ -900,12 +906,11 @@ object (self) | _ -> Stdlib.compare var1#index var2#index method is_stack_parameter_variable (v:variable_t) = - (self#is_stack_variable v) - && (self#has_constant_offset v) - && (tfold_default - (fun memoff -> (get_total_constant_offset memoff)#geq numerical_zero) - false - (self#get_memvar_offset v)) + if (self#is_stack_variable v) && (self#has_constant_offset v) then + let memoff_r = tbind get_total_constant_offset (self#get_memvar_offset v) in + tfold_default (fun memoff -> memoff#geq numerical_zero) false memoff_r + else + false method is_realigned_stack_variable (v:variable_t) = (self#is_memory_variable v) @@ -956,19 +961,6 @@ object (self) method is_memory_variable (v: variable_t) = tfold_default (fun av -> av#is_memory_variable) false (self#get_variable v) - method is_memory_address_variable (v: variable_t) = - tfold_default - (fun av -> av#is_memory_address_variable) false (self#get_variable v) - - method get_memory_address_meminfo (v: variable_t) = - if self#is_memory_address_variable v then - let avar = TR.tget_ok (self#get_variable v) in - avar#get_memory_address_meminfo - else - raise - (BCH_failure - (LBLOCK [STR "Not a memory address variable: "; v#toPretty])) - method is_basevar_memory_variable (v: variable_t) = (self#is_memory_variable v) && (let memref_r = self#get_memvar_reference v in @@ -979,15 +971,15 @@ object (self) && (let var_r = self#get_initial_memory_value_variable v in tfold_default self#is_basevar_memory_variable false var_r) - method get_memvar_basevar (v: variable_t) = + method get_memvar_basevar (v: variable_t): variable_t traceresult = tbind - ~msg:"varmgr:get_memvar_basevar" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun memref -> memref#get_external_base) (self#get_memvar_reference v) - method get_memval_basevar (v:variable_t) = + method get_memval_basevar (v:variable_t): variable_t traceresult = tbind - ~msg:"varmgr:get_memval_basevar" + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) (fun var -> self#get_memvar_basevar var) (self#get_initial_memory_value_variable v) diff --git a/CodeHawk/CHB/bchlib/bCHVersion.ml b/CodeHawk/CHB/bchlib/bCHVersion.ml index 6f3f9959..4a7a828f 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_20241218" - ~date:"2024-12-18" + ~version:"0.6.0_20250203" + ~date:"2025-02-03" ~licensee: None ~maxfilesize: None () diff --git a/CodeHawk/CHB/bchlib/bCHXprUtil.ml b/CodeHawk/CHB/bchlib/bCHXprUtil.ml index 9b9c6683..e6593be2 100644 --- a/CodeHawk/CHB/bchlib/bCHXprUtil.ml +++ b/CodeHawk/CHB/bchlib/bCHXprUtil.ml @@ -42,17 +42,18 @@ open Xsimplify let x2p = xpr_formatter#pr_expr -(* returns the largest constant term in the given expression, taking sign into account *) -let rec largest_constant_term (x:xpr_t) = +(* returns the largest constant term in the given expression, taking sign + into account. If no constant terms are present zero is returned. *) +let rec largest_constant_term (x:xpr_t): numerical_t = match x with - XConst (IntConst n) -> n - | XOp (XPlus, [ x1 ; x2 ]) -> + | XConst (IntConst n) -> n + | XOp (XPlus, [x1; x2]) -> let c1 = largest_constant_term x1 in let c2 = largest_constant_term x2 in if c1#gt c2 then c1 else c2 - | XOp (XMinus, [ x1 ; x2 ]) -> + | XOp (XMinus, [x1; x2]) -> let c1 = largest_constant_term x1 in - let c2 = largest_constant_term (XOp (XNeg, [ x2 ])) in + let c2 = largest_constant_term (XOp (XNeg, [x2])) in if c1#gt c2 then c1 else c2 | _ -> numerical_zero @@ -101,39 +102,46 @@ let rec vars_as_positive_terms (x:xpr_t) = | _ -> [] -let get_array_index_offset (xpr: xpr_t) (size: int): (xpr_t * numerical_t) option = +let get_array_index_offset (xpr: xpr_t) (size: int): (xpr_t * xpr_t) option = let xpr = simplify_xpr xpr in + let xzero = int_constant_expr 0 in if size = 1 then - Some (xpr, numerical_zero) + Some (xpr, xzero) else let numsize = mkNumerical size in match xpr with | XConst (IntConst n) -> let (quo, rem) = n#quomod (mkNumerical size) in - Some (num_constant_expr quo, rem) + Some (num_constant_expr quo, num_constant_expr rem) | XOp (XMult, [XConst (IntConst n); XVar v]) when n#equal numsize -> - Some (XVar v, numerical_zero) + Some (XVar v, xzero) + | XOp (XMult, [XConst (IntConst n); XOp ((XXlsh | XXlsb), [XVar v])]) + when n#equal numsize -> + Some (XVar v, xzero) | XOp (XPlus, [XOp (XMult, [XConst (IntConst n1); XVar v]); XConst (IntConst n2)]) when n1#equal numsize -> if n2#equal numerical_zero then - Some (XVar v, numerical_zero) + Some (XVar v, xzero) else let (quo, rem) = n2#quomod numsize in + let xrem = num_constant_expr rem in if quo#equal numerical_zero then - Some (XVar v, rem) + Some (XVar v, xrem) else - Some (XOp (XPlus, [XVar v; num_constant_expr quo]), rem) + Some (XOp (XPlus, [XVar v; num_constant_expr quo]), xrem) | XOp (XMinus, [XOp (XMult, [XConst (IntConst n1); XVar v]); XConst (IntConst n2)]) when n1#equal numsize -> if n2#equal numerical_zero then - Some (XVar v, numerical_zero) + Some (XVar v, xzero) else let (quo, rem) = n2#neg#quomod numsize in + let xrem = num_constant_expr rem in if quo#equal numerical_zero then - Some (XVar v, rem) + Some (XVar v, xrem) else if quo#lt numerical_zero then - Some (XOp (XMinus, [XVar v; num_constant_expr quo#neg]), rem) + Some (XOp (XMinus, [XVar v; num_constant_expr quo#neg]), xrem) else - Some (XOp (XPlus, [XVar v; num_constant_expr quo]), rem) - | _ -> None + Some (XOp (XPlus, [XVar v; num_constant_expr quo]), xrem) + | _ -> + None diff --git a/CodeHawk/CHB/bchlib/bCHXprUtil.mli b/CodeHawk/CHB/bchlib/bCHXprUtil.mli index 0169a3e5..9e4a9d3b 100644 --- a/CodeHawk/CHB/bchlib/bCHXprUtil.mli +++ b/CodeHawk/CHB/bchlib/bCHXprUtil.mli @@ -35,6 +35,8 @@ open CHNumerical open XprTypes +(** returns the largest constant term in the given expression, taking into + account the sign. *) val largest_constant_term : xpr_t -> numerical_t val normalize_offset_expr: xpr_t -> xpr_t @@ -52,4 +54,4 @@ val vars_as_positive_terms: xpr_t -> variable_t list the remaining offset is constant (e.g., to be converted into one or more levels of field offsets. *) -val get_array_index_offset: xpr_t -> int -> (xpr_t * numerical_t) option +val get_array_index_offset: xpr_t -> int -> (xpr_t * xpr_t) option diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMAnalysisResults.ml b/CodeHawk/CHB/bchlibarm32/bCHARMAnalysisResults.ml index ce2dcb81..bd5ae83e 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMAnalysisResults.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMAnalysisResults.ml @@ -55,6 +55,7 @@ module H = Hashtbl let bd = BCHDictionary.bdictionary let bcd = BCHBCDictionary.bcdictionary +let mmap = BCHGlobalMemoryMap.global_memory_map class fn_analysis_results_t (fn:arm_assembly_function_int) = @@ -194,15 +195,17 @@ object (self) let dNode = xmlElement "instr-dictionary" in let iiNode = xmlElement "instructions" in let sfNode = xmlElement "stackframe" in + let grNode = xmlElement "global-references" in (* let bNode = xmlElement "btypes" in *) begin self#write_xml_cfg cNode; self#write_xml_jumptables jjNode; self#write_xml_instructions iiNode; finfo#stackframe#write_xml sfNode; + mmap#write_xml_references faddr vard grNode; (* self#write_xml_btypes bNode; *) id#write_xml dNode; - append [cNode; dNode; iiNode; jjNode; sfNode] + append [cNode; dNode; iiNode; jjNode; sfNode; grNode] end method write_xml_register_types @@ -216,7 +219,13 @@ object (self) bd#write_xml_register inode reg; inode#setAttribute "iaddr" iaddr; (match optty with - | Some ty -> bcd#write_xml_typ inode ty + | Some ty -> + begin + log_result __FILE__ __LINE__ + ["reglhs: " ^ iaddr ^ ": " ^ + (BCHBCTypePretty.btype_to_string ty)]; + bcd#write_xml_typ inode ty + end | _ -> ()); regnode#appendChildren [inode] end) regtypes; diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyFunctions.ml b/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyFunctions.ml index f3c17af6..9250811d 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyFunctions.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyFunctions.ml @@ -259,6 +259,7 @@ object (self) with | Not_found -> let msg = [ + STR (__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": "); STR "Unable to find function with index: "; dw_index_to_pretty index] in begin @@ -272,11 +273,13 @@ object (self) with | BCH_failure _ -> let msg = [ + STR (__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": "); STR "Unable to find function with address: "; faddr#toPretty] in begin pr_debug (msg @ [NL]); - pr_debug [STR "Number of functions present: "; INT (H.length functions); NL]; + pr_debug [ + STR "Number of functions present: "; INT (H.length functions); NL]; raise (BCH_failure (LBLOCK msg)) end @@ -414,8 +417,8 @@ object (self) method add_functions_by_preamble = let instrtable = self#get_live_instructions in - let preambles = H.create 3 in - let preamble_instrs = H.create 3 in + let preambles = H.create 3 in (* instr-bytes -> count *) + let preamble_instrs = H.create 3 in (* instr-bytes -> instruction *) let _ = (* collect preambles of regular functions *) self#itera (fun faddr f -> let instr = f#get_instruction faddr in @@ -457,8 +460,18 @@ object (self) else 10 in let preamble_cutoff = self#get_num_functions / preamble_cutoff_factor in + let _ = + chlog#add + "initialization" + (LBLOCK [STR "preamble cutoff: "; INT preamble_cutoff]) in H.fold (fun k v a -> if v >= preamble_cutoff then k :: a else a) preambles [] in + let _ = + List.iter + (fun p -> + chlog#add + "common preamble" (LBLOCK [(H.find preamble_instrs p)#toPretty])) + commonpreambles in let is_common_preamble bytes = List.fold_left (fun a p -> a || p = bytes) false commonpreambles in let fnsAdded = ref [] in @@ -537,7 +550,6 @@ object (self) dark ^ "\n\n" ^ functionstats method private collect_data_references = - let _ = pverbose [STR (timing ()); STR "collect data references ..."; NL] in let livetable = self#get_live_instructions in let filter = (fun i -> H.mem livetable i#get_address#index) in let table = H.create 11 in @@ -571,6 +583,28 @@ object (self) ch_error_log#add "LDR (literal) from non-code-address" (LBLOCK [va#toPretty; STR " refers to "; a#toPretty]) + | Adr (_, dst, adr) + when adr#is_absolute_address + && not (functions_data#is_in_function_stub va) -> + let a = adr#get_absolute_address in + let nextva = va#add_int 4 in + if elf_header#is_program_address a then + (match get_arm_assembly_instruction nextva with + | Ok nxtinstr -> + (match nxtinstr#get_opcode with + | LoadMultipleIncrementAfter (_, _, src, rl, _) + when dst#get_register = src#get_register -> + for i = 0 to rl#get_register_count do + add (a#add_int (4 * i)) nxtinstr + done + | _ -> + add a instr) + | _ -> + add a instr) + else + ch_error_log#add + "ADR with non-code address" + (LBLOCK [va#toPretty; STR " refers to "; a#toPretty]) | VLoadRegister (_, vd, _, mem) when mem#is_pc_relative_address -> let pcoffset = if instr#is_arm32 then 8 else 4 in let a = mem#get_pc_relative_address va pcoffset in diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyInstructions.ml b/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyInstructions.ml index b9eb1944..592c3885 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyInstructions.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMAssemblyInstructions.ml @@ -37,7 +37,6 @@ open CHXmlDocument (* bchlib *) open BCHBasicTypes open BCHByteUtilities -open BCHConstantDefinitions open BCHDataBlock open BCHDoubleword open BCHFunctionData @@ -264,7 +263,7 @@ let get_instruction (addr: doubleword_int): arm_assembly_instruction_result = ^ ": " ^ (pretty_to_string p)] -(* Return the addresses of valid instructions in the given address range +(* Return the addresses of valid instructions in the given address range (inclusive) *) let get_range_instruction_addrs (startaddr: doubleword_int) (endaddr: doubleword_int): doubleword_int list = @@ -586,6 +585,7 @@ object (self) let firstNew = ref true in let datareftable = H.create (List.length datarefs) in let _ = List.iter (fun (a, refs) -> H.add datareftable a refs) datarefs in + let memorymap = BCHGlobalMemoryMap.global_memory_map in let not_code_to_string nc = match nc with | JumpTable jt -> @@ -657,6 +657,19 @@ object (self) (List.map (fun (a, v) -> let addr = a#to_hex_string in + let datarefstr = + if H.mem datareftable addr then + let datarefs = H.find datareftable addr in + " " + ^ "(refs: " + ^ (String.concat + ", " + (List.map + (fun instr -> + instr#get_address#to_hex_string) datarefs)) + ^ ")" + else + "" in if a#lt !stringend then " " ^ (fixed_length_string addr 10) @@ -671,66 +684,89 @@ object (self) " " ^ (fixed_length_string addr 10) ^ " <0xffffffff>" - else if H.mem datareftable addr then - let datarefs = H.find datareftable addr in + else if functions_data#is_function_entry_point v then + let name = + if functions_data#has_function_name v then + let fndata = functions_data#get_function v in + ":" ^ fndata#get_function_name + else + "" in " " ^ (fixed_length_string addr 10) - ^ " " - ^ (fixed_length_string v#to_hex_string 12) - ^ ("referenced by: " - ^ (String.concat - ", " - (List.map - (fun instr -> - instr#get_address#to_hex_string) datarefs))) + ^ " Faddr:<" + ^ v#to_hex_string + ^ name + ^ ">" + ^ datarefstr + else if memorymap#has_elf_symbol v then + let name = memorymap#get_elf_symbol v in + " " + ^ (fixed_length_string addr 10) + ^ " Sym:<" + ^ v#to_hex_string + ^ ":" + ^ name + ^ ">" + ^ datarefstr + else if elf_header#is_code_address v then + " " + ^ (fixed_length_string addr 10) + ^ " Code:<" + ^ v#to_hex_string + ^ ">" + ^ datarefstr + else if elf_header#is_data_address v then + let s = + match elf_header#get_string_at_address v with + | Some s -> + let len = String.length s in + if len < 50 then + ":\"" ^ s ^ "\"" + else + ":\"" ^ (String.sub s 0 50) ^ "...\"" + | _ -> "" in + " " + ^ (fixed_length_string addr 10) + ^ " Data:<" + ^ v#to_hex_string + ^ s + ^ ">" + ^ datarefstr + else if elf_header#is_uninitialized_data_address v then + " " + ^ (fixed_length_string addr 10) + ^ " Bss:<" + ^ v#to_hex_string + ^ ">" + ^ datarefstr + else if Option.is_some + (elf_header#get_string_at_address a) then + let s = + Option.get (elf_header#get_string_at_address a) in + begin + (" " + ^ (fixed_length_string addr 10) + ^ " String:<" + ^ (fixed_length_string v#to_hex_string 12) + ^ ">: \"" + ^ s + ^ "\"") + ^ datarefstr + end + else if (String.length datarefstr) > 0 then + " " + ^ (fixed_length_string addr 10) + ^ " Value<" + ^ v#to_hex_string + ^ ">" + ^ datarefstr else - match elf_header#get_string_at_address a with - | Some s -> - stringend := a#add_int ((String.length s) + 1); - begin - (" " - ^ (fixed_length_string addr 10) - ^ " String:<" - ^ (fixed_length_string v#to_hex_string 12) - ^ ">: \"" - ^ s - ^ "\"") - end - | _ -> - if functions_data#is_function_entry_point v then - " " - ^ (fixed_length_string addr 10) - ^ " Faddr:<" - ^ v#to_hex_string - ^ ">" - else if has_symbolic_address_name v then - let name = get_symbolic_address_name v in - " " - ^ (fixed_length_string addr 10) - ^ " Sym:<" - ^ v#to_hex_string - ^ ":" - ^ name - ^ ">" - else if elf_header#is_code_address v then - " " - ^ (fixed_length_string addr 10) - ^ " Code:<" - ^ v#to_hex_string - ^ ">" - else if elf_header#is_data_address v then - " " - ^ (fixed_length_string addr 10) - ^ " Data:<" - ^ v#to_hex_string - ^ ">" - else - " " - ^ (fixed_length_string addr 10) - ^ " " - ^ (fixed_length_string v#to_hex_string 14) - ^ " " - ^ (opcode_string a v)) + " " + ^ (fixed_length_string addr 10) + ^ " " + ^ (fixed_length_string v#to_hex_string 14) + ^ " " + ^ (opcode_string a v)) (List.rev !contents))) ^ "\n" ^ (string_repeat "=" 80) ^ "\n") end diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMConditionalExpr.ml b/CodeHawk/CHB/bchlibarm32/bCHARMConditionalExpr.ml index a9b084f0..0972b737 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMConditionalExpr.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMConditionalExpr.ml @@ -49,6 +49,8 @@ open BCHLibTypes open BCHARMTypes open BCHARMOpcodeRecords +module TR = CHTraceResult + (* Conditional execution: conditions @@ -110,56 +112,63 @@ let freeze_variables (add:variable_t -> variable_t -> unit) (testloc:location_int) (condloc:location_int) - (op:arm_operand_int) = + (op:arm_operand_int): xpr_t = let testfloc = get_floc testloc in let condfloc = get_floc condloc in let env = testfloc#f#env in - let opXpr = op#to_expr ~unsigned testfloc in let frozenVars = new VariableCollections.table_t in - let vars = (variables_in_expr opXpr) in - let varsKnown = ref true in - let _ = - List.iter ( - fun v -> - if v#isTmp then - varsKnown := false - else if env#is_function_initial_value v then - () - else if env#is_local_variable v then - let _ = - track_location - testloc#ci - (LBLOCK [ - v#toPretty; NL; - testfloc#inv#toPretty; NL; - condfloc#inv#toPretty]) in - if condfloc#inv#test_var_is_equal v testloc#ci condloc#ci then - let _ = - track_location - condloc#ci - (LBLOCK [ - v#toPretty; NL; - STR " test_var_is_equal"]) in - () - else - let fv = env#mk_frozen_test_value v testloc#ci condloc#ci in - frozenVars#set v fv - else if env#is_unknown_memory_variable v then - varsKnown := false) vars in - let subst v = - if frozenVars#has v then - match testfloc#inv#get_external_exprs v with - | x::_ -> x - | _ -> XVar (Option.get (frozenVars#get v)) - else - XVar v in - if !varsKnown then - begin - List.iter (fun (v, fv) -> add v fv) frozenVars#listOfPairs ; - substitute_expr subst opXpr - end - else - random_constant_expr + TR.tfold + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + random_constant_expr + end) + ~ok:(fun opXpr -> + let vars = (variables_in_expr opXpr) in + let varsKnown = ref true in + let _ = + List.iter ( + fun v -> + if v#isTmp then + varsKnown := false + else if env#is_function_initial_value v then + () + else if env#is_local_variable v then + let _ = + track_location + testloc#ci + (LBLOCK [ + v#toPretty; NL; + testfloc#inv#toPretty; NL; + condfloc#inv#toPretty]) in + if condfloc#inv#test_var_is_equal v testloc#ci condloc#ci then + let _ = + track_location + condloc#ci + (LBLOCK [ + v#toPretty; NL; + STR " test_var_is_equal"]) in + () + else + let fv = env#mk_frozen_test_value v testloc#ci condloc#ci in + frozenVars#set v fv + else if env#is_unknown_memory_variable v then + varsKnown := false) vars in + let subst v = + if frozenVars#has v then + match testfloc#inv#get_external_exprs v with + | x::_ -> x + | _ -> XVar (Option.get (frozenVars#get v)) + else + XVar v in + if !varsKnown then + begin + List.iter (fun (v, fv) -> add v fv) frozenVars#listOfPairs ; + substitute_expr subst opXpr + end + else + random_constant_expr) + (op#to_expr ~unsigned testfloc) let cc_expr diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.ml b/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.ml index 6766ff43..889c73dd 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.ml @@ -1,10 +1,10 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - - 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 @@ -12,10 +12,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,6 +39,7 @@ open CHPretty open CHLogger (* xprlib *) +open XprToPretty open XprTypes (* bchlib *) @@ -56,6 +57,10 @@ open BCHARMTypes module TR = CHTraceResult +let x2p = xpr_formatter#pr_expr +let p2s = CHPrettyUtil.pretty_to_string +let x2s x = p2s (x2p x) + (* commonly used constant values *) let e7 = 128 @@ -70,7 +75,7 @@ let rec _pow2 n = match n with | 0 -> 1 | 1 -> 2 - | n -> + | n -> let b = _pow2 (n / 2) in b * b * (if n mod 2 = 0 then 1 else 2) @@ -139,41 +144,65 @@ let get_it_condition_list (firstcond:int) (mask:int) = thencc::xyz +let get_inverse_cc (cc: arm_opcode_cc_t): arm_opcode_cc_t option = + match cc with + | ACCEqual -> Some ACCNotEqual + | ACCNotEqual -> Some ACCEqual + | ACCCarrySet -> Some ACCCarryClear + | ACCCarryClear -> Some ACCCarrySet + | ACCNegative -> Some ACCNonNegative + | ACCNonNegative -> Some ACCNegative + | ACCOverflow -> Some ACCNoOverflow + | ACCNoOverflow -> Some ACCOverflow + | ACCUnsignedHigher -> Some ACCNotUnsignedHigher + | ACCNotUnsignedHigher -> Some ACCUnsignedHigher + | ACCSignedGE -> Some ACCSignedLT + | ACCSignedLT -> Some ACCSignedGE + | ACCSignedGT -> Some ACCSignedLE + | ACCSignedLE -> Some ACCSignedGT + | _ -> None + + +let has_inverse_cc (cc: arm_opcode_cc_t): bool = + Option.is_some (get_inverse_cc cc) + + let get_string_reference (floc:floc_int) (xpr:xpr_t) = try match xpr with | XConst (IntConst num) -> - log_tfold_default - (mk_tracelog_spec - ~tag:"get_string_reference" - (floc#cia ^": constant: " ^ num#toString)) - (fun address -> + TR.tfold + ~ok:(fun address -> begin match elf_header#get_string_at_address address with | Some str -> begin string_table#add_xref address str floc#fa floc#cia; - (if collect_diagnostics () then - ch_diagnostics_log#add - "add string" (LBLOCK [floc#l#toPretty; STR "; "; STR str])); Some str end | _ -> - begin - (if collect_diagnostics () then - ch_diagnostics_log#add - "no string found" - (LBLOCK [floc#l#toPretty; STR ": "; address#toPretty])); - None - end + None + end) + ~error:(fun e -> + begin + log_error_result + ~msg:"get_string_reference" + __FILE__ __LINE__ ([(p2s floc#l#toPretty) ^ ": " ^ (x2s xpr)] @ e); + None end) - None (numerical_to_doubleword num) | XOp (XPlus, [XVar v; XConst (IntConst num)]) -> if floc#env#has_initialized_string_value v num#toInt then Some (floc#env#get_initialized_string_value v num#toInt) else None - | _ -> None + | _ -> + None with - | _ -> None + | _ -> + begin + log_error_result + ~msg:"get_string_reference" + __FILE__ __LINE__ [(p2s floc#l#toPretty) ^ ": " ^ (x2s xpr)]; + None + end diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.mli b/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.mli index ad12eb29..2fff60af 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.mli +++ b/CodeHawk/CHB/bchlibarm32/bCHARMDisassemblyUtils.mli @@ -39,4 +39,8 @@ val get_interrupt_flags: int -> interrupt_flags_t val get_it_condition_list: int -> int -> (string * arm_opcode_cc_t) list +val get_inverse_cc: arm_opcode_cc_t -> arm_opcode_cc_t option + +val has_inverse_cc: arm_opcode_cc_t -> bool + val get_string_reference: floc_int -> xpr_t -> string option diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMInstructionAggregate.ml b/CodeHawk/CHB/bchlibarm32/bCHARMInstructionAggregate.ml index 6ba8ea68..66b41a8f 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMInstructionAggregate.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMInstructionAggregate.ml @@ -26,6 +26,7 @@ ============================================================================= *) (* chlib *) +open CHNumerical open CHPretty (* chutil *) @@ -39,6 +40,7 @@ open BCHLibTypes (* bchlibarm32 *) open BCHARMAssemblyInstruction open BCHARMAssemblyInstructions +open BCHARMDisassemblyUtils open BCHARMJumptable open BCHARMTypes open BCHDisassembleARMInstruction @@ -46,6 +48,9 @@ open BCHLoadStoreMultipleSequence open BCHThumbITSequence +module TR = CHTraceResult + + let arm_aggregate_kind_to_string (k: arm_aggregate_kind_t) = match k with | ARMJumptable jt -> @@ -56,6 +61,11 @@ let arm_aggregate_kind_to_string (k: arm_aggregate_kind_t) = ^ " target addresses" | ThumbITSequence it -> it#toString | LDMSTMSequence s -> s#toString + | PseudoLDRSB (i1, _, _) -> "Pseudo LDRSB at " ^ i1#get_address#to_hex_string + | PseudoLDRSH (i1, _, _) -> "Pseudo LDRSH at " ^ i1#get_address#to_hex_string + | ARMPredicateAssignment (inverse, op) -> + let inv = if inverse then " (inverse)" else "" in + "predicate assignment to " ^ op#toString ^ inv | BXCall (_, i2) -> "BXCall at " ^ i2#get_address#to_hex_string @@ -115,6 +125,21 @@ object (self) | BXCall _ -> true | _ -> false + method is_pseudo_ldrsh = + match self#kind with + | PseudoLDRSH _ -> true + | _ -> false + + method is_pseudo_ldrsb = + match self#kind with + | PseudoLDRSH _ -> true + | _ -> false + + method is_predicate_assign = + match self#kind with + | ARMPredicateAssignment _ -> true + | _ -> false + method write_xml (_node: xml_element_int) = () method toCHIF (_faddr: doubleword_int) = [] @@ -125,7 +150,7 @@ object (self) INT (List.length self#instrs); STR " with anchor "; self#anchor#toPretty; - STR " and instructions: "; + STR ": "; STR (arm_aggregate_kind_to_string self#kind)] end @@ -191,6 +216,46 @@ let make_bx_call_aggregate ~anchor:bxinstr +let make_pseudo_ldrsh_aggregate + (ldrhinstr: arm_assembly_instruction_int) + (lslinstr: arm_assembly_instruction_int) + (asrinstr: arm_assembly_instruction_int): arm_instruction_aggregate_int = + let kind = PseudoLDRSH (ldrhinstr, lslinstr, asrinstr) in + make_arm_instruction_aggregate + ~kind + ~instrs:[ldrhinstr; lslinstr; asrinstr] + ~entry:ldrhinstr + ~exitinstr:asrinstr + ~anchor:asrinstr + + +let make_pseudo_ldrsb_aggregate + (ldrbinstr: arm_assembly_instruction_int) + (lslinstr: arm_assembly_instruction_int) + (asrinstr: arm_assembly_instruction_int): arm_instruction_aggregate_int = + let kind = PseudoLDRSB (ldrbinstr, lslinstr, asrinstr) in + make_arm_instruction_aggregate + ~kind + ~instrs:[ldrbinstr; lslinstr; asrinstr] + ~entry:ldrbinstr + ~exitinstr:asrinstr + ~anchor:asrinstr + + +let make_predassign_aggregate + (inverse: bool) + (mov1: arm_assembly_instruction_int) + (mov2: arm_assembly_instruction_int) + (dstop: arm_operand_int): arm_instruction_aggregate_int = + let kind = ARMPredicateAssignment (inverse, dstop) in + make_arm_instruction_aggregate + ~kind + ~instrs:[mov1; mov2] + ~entry:mov1 + ~exitinstr:mov2 + ~anchor:mov2 + + let disassemble_arm_instructions (ch: pushback_stream_int) (iaddr: doubleword_int) (n: int) = for _i = 1 to n do @@ -296,30 +361,199 @@ let identify_bx_call | _ -> None +(* format of pseudo LDRSH (in ARM) + + An LDRH combined with LSL 16, ASR 16 converts into (effectively) an + LDRSH: + + LDRH Rx, mem + LSL Rx, Rx, #0x10 + ASR Rx, Rx, #0x10 + *) +let identify_pseudo_ldrsh + (_ch: pushback_stream_int) + (instr: arm_assembly_instruction_int): + (arm_assembly_instruction_int + * arm_assembly_instruction_int + * arm_assembly_instruction_int) option = + let sixteen = CHNumerical.mkNumerical 16 in + match instr#get_opcode with + | ArithmeticShiftRight (_, ACCAlways, rd, rs, imm, _) + when imm#is_immediate + && imm#to_numerical#equal sixteen + && (rd#get_register = rs#get_register) -> + let addr = instr#get_address in + let lslinstr_r = get_arm_assembly_instruction (addr#add_int (-4)) in + let ldrhinstr_r = get_arm_assembly_instruction (addr#add_int (-8)) in + (match (TR.to_option lslinstr_r, TR.to_option ldrhinstr_r) with + | (Some lslinstr, Some ldrhinstr) -> + if + (match lslinstr#get_opcode with + | LogicalShiftLeft (_, ACCAlways, rd1, rs1, imm, _) + when imm#is_immediate + && imm#to_numerical#equal sixteen + && (rd1#get_register = rd#get_register) + && (rs1#get_register = rd#get_register) -> true + | _ -> false) + && (match ldrhinstr#get_opcode with + | LoadRegisterHalfword (ACCAlways, rd2, _, _, _, _) + when rd2#get_register = rd#get_register -> true + | _ -> false) + then + Some (TR.tget_ok ldrhinstr_r, TR.tget_ok lslinstr_r, instr) + else + None + | _ -> None) + | _ -> None + + +(* format of pseudo LDRSB (in ARM) + + An LDRH combined with LSL 16, ASR 16 converts into (effectively) an + LDRSH: + + LDRB Rx, mem + LSL Rx, Rx, #0x18 + ASR Rx, Rx, #0x18 + *) +let identify_pseudo_ldrsb + (_ch: pushback_stream_int) + (instr: arm_assembly_instruction_int): + (arm_assembly_instruction_int + * arm_assembly_instruction_int + * arm_assembly_instruction_int) option = + let twentyfour = CHNumerical.mkNumerical 24 in + match instr#get_opcode with + | ArithmeticShiftRight (_, ACCAlways, rd, rs, imm, _) + when imm#is_immediate + && imm#to_numerical#equal twentyfour + && (rd#get_register = rs#get_register) -> + let addr = instr#get_address in + let lslinstr_r = get_arm_assembly_instruction (addr#add_int (-4)) in + let ldrbinstr_r = get_arm_assembly_instruction (addr#add_int (-8)) in + (match (TR.to_option lslinstr_r, TR.to_option ldrbinstr_r) with + | (Some lslinstr, Some ldrbinstr) -> + if + (match lslinstr#get_opcode with + | LogicalShiftLeft (_, ACCAlways, rd1, rs1, imm, _) + when imm#is_immediate + && imm#to_numerical#equal twentyfour + && (rd1#get_register = rd#get_register) + && (rs1#get_register = rd#get_register) -> true + | _ -> false) + && (match ldrbinstr#get_opcode with + | LoadRegisterByte (ACCAlways, rd2, _, _, _, _) + when rd2#get_register = rd#get_register -> true + | _ -> false) + then + Some (ldrbinstr, lslinstr, instr) + else + None + | _ -> None) + | _ -> None + + +(* format of predicate assignment (in ARM): assigns the result of a test as a + 0/1 value to a register + + MOVNE Rx, #0 + MOVEQ Rx, #1 + *) +let identify_predicate_assignment + (_ch: pushback_stream_int) + (instr: arm_assembly_instruction_int): + (bool + * arm_assembly_instruction_int + * arm_assembly_instruction_int + * arm_operand_int) option = + let is_zero imm = imm#to_numerical#equal numerical_zero in + let is_one imm = imm#to_numerical#equal numerical_one in + let is_zero_or_one imm = (is_zero imm) || (is_one imm) in + match instr#get_opcode with + | Move (false, c2, rd, imm2, _, _) + when imm2#is_immediate && (is_zero_or_one imm2) && (has_inverse_cc c2) -> + let rdreg = rd#get_register in + let addr = instr#get_address in + let movinstr_r = get_arm_assembly_instruction (addr#add_int (-4)) in + (match TR.to_option movinstr_r with + | Some movinstr -> + (match movinstr#get_opcode with + | Move (false, c1, rd, imm1, _, _) + when imm1#is_immediate + && (is_zero_or_one imm1) + && (rd#get_register = rdreg) + && (not (imm1#to_numerical#equal imm2#to_numerical)) + && (has_inverse_cc c1) + && ((Option.get (get_inverse_cc c1)) = c2) -> + let inverse = is_zero imm2 in + Some (inverse, movinstr, instr, rd) + | _ -> None) + | _ -> None) + | _ -> None + + let identify_arm_aggregate (ch: pushback_stream_int) (instr: arm_assembly_instruction_int): arm_instruction_aggregate_int option = - match identify_jumptable ch instr with - | Some (instrs, jt) -> - let anchor = List.nth instrs ((List.length instrs) - 1) in - let entry = List.hd instrs in - let exitinstr = anchor in - Some (make_arm_jumptable_aggregate ~jt ~instrs ~entry ~exitinstr ~anchor) - | _ -> - match identify_it_sequence ch instr with - | Some its -> - let instrs = its#instrs in - let entry = List.hd instrs in - let exitinstr = List.hd (List.rev instrs) in - Some (make_it_sequence_aggregate - ~its ~instrs ~entry ~exitinstr ~anchor:entry) - | _ -> - match identify_ldmstm_sequence ch instr with - | Some ldmstmseq -> - Some (make_ldm_stm_sequence_aggregate ldmstmseq) - | _ -> - match identify_bx_call ch instr with - | Some (movinstr, bxinstr) -> - Some (make_bx_call_aggregate movinstr bxinstr) - | _ -> None + let result = + match identify_jumptable ch instr with + | Some (instrs, jt) -> + let anchor = List.nth instrs ((List.length instrs) - 1) in + let entry = List.hd instrs in + let exitinstr = anchor in + Some (make_arm_jumptable_aggregate ~jt ~instrs ~entry ~exitinstr ~anchor) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_it_sequence ch instr with + | Some its -> + let instrs = its#instrs in + let entry = List.hd instrs in + let exitinstr = List.hd (List.rev instrs) in + Some (make_it_sequence_aggregate + ~its ~instrs ~entry ~exitinstr ~anchor:entry) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_ldmstm_sequence ch instr with + | Some ldmstmseq -> + Some (make_ldm_stm_sequence_aggregate ldmstmseq) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_bx_call ch instr with + | Some (movinstr, bxinstr) -> + Some (make_bx_call_aggregate movinstr bxinstr) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_pseudo_ldrsh ch instr with + | Some (ldrhinstr, lslinstr, asrinstr) -> + Some (make_pseudo_ldrsh_aggregate ldrhinstr lslinstr asrinstr) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_pseudo_ldrsb ch instr with + | Some (ldrbinstr, lslinstr, asrinstr) -> + Some (make_pseudo_ldrsb_aggregate ldrbinstr lslinstr asrinstr) + | _ -> None in + let result = + match result with + | Some _ -> result + | _ -> + match identify_predicate_assignment ch instr with + | Some (inverse, mov1, mov2, dstop) -> + Some (make_predassign_aggregate inverse mov1 mov2 dstop) + | _ -> None in + result diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMJumptable.ml b/CodeHawk/CHB/bchlibarm32/bCHARMJumptable.ml index bcd30bf0..1b315804 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMJumptable.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMJumptable.ml @@ -528,7 +528,7 @@ let is_ldrls_jumptable let indexreg = indexregop#get_register in let cmptestf = cmp_reg_imm_test indexreg in let addr = ldrinstr#get_address in - let optcmpinstr = find_instr cmptestf [(-4)] addr in + let optcmpinstr = find_instr cmptestf [(-4); (-16)] addr in (match optcmpinstr with | Some cmpinstr -> let branchtestf instr = diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.ml b/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.ml index 70bf4cba..4dab9874 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 @@ -35,41 +35,53 @@ open BCHARMLoopStructure open BCHARMOpcodeRecords open BCHARMTypes +module TR = CHTraceResult -let get_arm_op_metrics (f:arm_assembly_function_int) (finfo:function_info_int) = + +let get_arm_op_metrics (f:arm_assembly_function_int) (_finfo:function_info_int) = let faddr = f#get_address in let reads = ref 0 in let qreads = ref 0 in let writes = ref 0 in let qwrites = ref 0 in - let is_memory_op op = + let count_memory_ops (op: arm_operand_int): int = + match op#get_kind with + | ARMMemMultiple (_, _, n, _) -> n + | ARMOffsetAddress _ -> 1 + | _ -> 0 in + + let count_unknown_reads floc (op: arm_operand_int): int = match op#get_kind with - | ARMMemMultiple _ - | ARMOffsetAddress _ -> true - | _ -> false in - let is_loc_unknown floc (op: arm_operand_int) = + | ARMMemMultiple _ -> + let (lhs_rl, _) = op#to_multiple_lhs floc in + List.fold_left (fun acc lhs_r -> + if Result.is_error lhs_r then acc + 1 else acc) 0 lhs_rl + | ARMOffsetAddress _ -> + if Result.is_error (op#to_lhs floc) then 1 else 0 + | _ -> 0 in + + let count_unknown_writes floc (op: arm_operand_int): int = match op#get_kind with | ARMMemMultiple _ -> - let (vlist, _) = op#to_multiple_lhs floc in - (match vlist with - | v::_ -> v#isTmp || (finfo#env#is_unknown_memory_variable v) - | _ -> true) + let rhs_rl = op#to_multiple_expr floc in + List.fold_left (fun acc rhs_r -> + if Result.is_error rhs_r then acc + 1 else acc) 0 rhs_rl | ARMOffsetAddress _ -> - let (v, _) = op#to_lhs floc in - v#isTmp || (finfo#env#is_unknown_memory_variable v) - | _ -> false in - let add_read floc (op: arm_operand_int) = - if is_memory_op op then - begin - reads := !reads + 1; - if is_loc_unknown floc op then qreads := !qreads + 1 - end in - let add_write floc (op: arm_operand_int) = - if is_memory_op op then - begin - writes := !writes + 1; - if is_loc_unknown floc op then qwrites := !qwrites + 1 - end in + if Result.is_error (op#to_expr floc) then 1 else 0 + | _ -> 0 in + + let add_reads floc (op: arm_operand_int) = + begin + reads := !reads + (count_memory_ops op); + qreads := !qreads + (count_unknown_reads floc op) + end in + + let add_writes floc (op: arm_operand_int) = + begin + writes := !writes + (count_memory_ops op); + qwrites := !qwrites + (count_unknown_writes floc op) + end in + let _ = f#iteri (fun _ ctxtiaddr instr -> let ops = get_arm_operands instr#get_opcode in @@ -80,14 +92,15 @@ let get_arm_op_metrics (f:arm_assembly_function_int) (finfo:function_info_int) = let floc = get_floc loc in List.iter (fun (op: arm_operand_int) -> match op#get_mode with - | RD -> add_read floc op - | WR -> add_write floc op + | RD -> add_reads floc op + | WR -> add_writes floc op | RW -> begin - add_read floc op; - add_write floc op + add_reads floc op; + add_writes floc op end) ops) in - (!reads,!qreads,!writes,!qwrites) + (!reads, !qreads, !writes, !qwrites) + let get_arm_stackpointer_metrics (f: arm_assembly_function_int) (_finfo: function_info_int) = @@ -104,28 +117,29 @@ let get_arm_stackpointer_metrics esptop := !esptop + 1 else match range#singleton with Some _ -> () | _ -> esprange := !esprange + 1) in - (!esptop,!esprange) + (!esptop, !esprange) let get_arm_memory_access_metrics (f: arm_assembly_function_int) (finfo: function_info_int) = let (reads,qreads,writes,qwrites) = get_arm_op_metrics f finfo in let (esptop,esprange) = get_arm_stackpointer_metrics f finfo in - { mmem_reads = reads ; - mmem_qreads = qreads ; - mmem_writes = writes ; - mmem_qwrites = qwrites ; - mmem_esptop = esptop ; + { mmem_reads = reads; + mmem_qreads = qreads; + mmem_writes = writes; + mmem_qwrites = qwrites; + mmem_esptop = esptop; mmem_esprange = esprange } + let get_arm_cfg_metrics (f: arm_assembly_function_int) (_env: function_environment_int) = let _ = record_arm_loop_levels f#get_address in - { mcfg_instrs = f#get_instruction_count ; - mcfg_bblocks = f#get_block_count ; - mcfg_loops = get_arm_loop_count_from_table f ; - mcfg_loopdepth = get_arm_loop_depth_from_table f ; - mcfg_complexity = 0 ; + { mcfg_instrs = f#get_instruction_count; + mcfg_bblocks = f#get_block_count; + mcfg_loops = get_arm_loop_count_from_table f; + mcfg_loopdepth = get_arm_loop_depth_from_table f; + mcfg_complexity = 0; mcfg_vc_complexity = 0.0 } diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.mli b/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.mli index c7d1dfe7..60a77e2a 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.mli +++ b/CodeHawk/CHB/bchlibarm32/bCHARMMetrics.mli @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMOpcodeRecords.ml b/CodeHawk/CHB/bchlibarm32/bCHARMOpcodeRecords.ml index eeae6d10..be8b1962 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMOpcodeRecords.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMOpcodeRecords.ml @@ -1665,7 +1665,22 @@ let is_opcode_conditional (opc: arm_opcode_t): bool = let arm_opcode_to_string ?(width=12) (opc:arm_opcode_t) = let formatter = new string_formatter_t width in let default () = (get_record opc).ida_asm formatter in - default () + let fnsdata = BCHFunctionData.functions_data in + match opc with + | BranchLink (ACCAlways, tgt) when tgt#is_absolute_address -> + let tgtaddr = tgt#get_absolute_address in + if fnsdata#has_function_name tgtaddr then + let name = (fnsdata#get_function tgtaddr)#get_function_name in + (fixed_length_string "BL" width) + ^ " <" + ^ tgtaddr#to_hex_string + ^ ":" + ^ name + ^ ">" + else + default() + | _ -> + default () let get_operands_written (opc:arm_opcode_t) = diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMOperand.ml b/CodeHawk/CHB/bchlibarm32/bCHARMOperand.ml index 8d493e96..9b45cf1d 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMOperand.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMOperand.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 @@ -33,18 +33,17 @@ open CHPretty (* chutil *) open CHLogger open CHPrettyUtil +open CHTraceResult (* xprlib *) open Xprt open XprTypes -open XprToPretty open Xsimplify (* bchlib *) open BCHBasicTypes open BCHBCTypes open BCHBCTypeUtil -open BCHConstantDefinitions open BCHCPURegisters open BCHDoubleword open BCHImmediate @@ -61,14 +60,10 @@ open BCHARMTypes module TR = CHTraceResult -let x2p = xpr_formatter#pr_expr +(* let x2p = XprToPretty.xpr_formatter#pr_expr *) let p2s = pretty_to_string -let log_error (tag: string) (msg: string): tracelogspec_t = - mk_tracelog_spec ~tag:("arm_operand:" ^ tag) msg - - let arm_operand_mode_to_string = function RD -> "RD" | WR -> "WR" | RW -> "RW" @@ -236,8 +231,10 @@ object (self:'a) | _ -> raise (BCH_failure - (LBLOCK [STR "Operand is not a register list: "; - self#toPretty])) + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Operand is not a register list: "; + self#toPretty])) method get_register_list = match kind with @@ -245,8 +242,10 @@ object (self:'a) | _ -> raise (BCH_failure - (LBLOCK [STR "Operand is not a register list: "; - self#toPretty])) + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Operand is not a register list: "; + self#toPretty])) method get_register_op_list: 'a list = match kind with @@ -256,7 +255,9 @@ object (self:'a) raise (BCH_failure (LBLOCK [ - STR "Operand is not a register list: "; self#toPretty])) + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Operand is not a register list: "; + self#toPretty])) method get_extension_register_op_list: 'a list = match kind with @@ -317,6 +318,7 @@ object (self:'a) raise (BCH_failure (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; STR "Operand cannot be converted to a generic register: "; self#toPretty])) @@ -338,61 +340,56 @@ object (self:'a) (BCH_failure (LBLOCK [STR "Operand is not an immediate value: " ; self#toPretty])) - method to_address (floc: floc_int): xpr_t = + method to_address (floc: floc_int): xpr_t traceresult = match kind with | ARMOffsetAddress (r, align, offset, isadd, _iswback, isindex, _) -> let env = floc#f#env in - let memoff = + let xoffset_r = if isindex then match (offset, isadd) with - | (ARMImmOffset i, true) -> int_constant_expr i - | (ARMImmOffset i, false) -> int_constant_expr (-i) + | (ARMImmOffset i, true) -> Ok (int_constant_expr i) + | (ARMImmOffset i, false) -> Ok (int_constant_expr (-i)) | (ARMIndexOffset (indexreg, indexoffset), true) -> let indexvar = env#mk_arm_register_variable indexreg in - XOp (XPlus, [XVar indexvar; int_constant_expr indexoffset]) + Ok (XOp (XPlus, [XVar indexvar; int_constant_expr indexoffset])) | (ARMShiftedIndexOffset (indexreg, srt, indexoffset), true) -> let indexvar = env#mk_arm_register_variable indexreg in let xoffset = int_constant_expr indexoffset in (match srt with - | ARMImmSRT (_, 0)-> XOp (XPlus, [XVar indexvar; xoffset]) + | ARMImmSRT (_, 0)-> Ok (XOp (XPlus, [XVar indexvar; xoffset])) | ARMImmSRT (SRType_LSL, 2) -> let shifted = XOp (XMult, [XVar indexvar; int_constant_expr 4]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | ARMImmSRT (SRType_ASR, 1) -> let shifted = XOp (XDiv, [XVar indexvar; int_constant_expr 2]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | ARMImmSRT (SRType_ASR, 2) -> let shifted = XOp (XDiv, [XVar indexvar; int_constant_expr 4]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | ARMImmSRT (SRType_ASR, 3) -> let shifted = XOp (XDiv, [XVar indexvar; int_constant_expr 8]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | ARMRegSRT (SRType_LSL, srtreg) -> let shiftvar = env#mk_arm_register_variable srtreg in let shifted = XOp (XLsl, [XVar indexvar; XVar shiftvar]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | ARMRegSRT (SRType_ASR, srtreg) -> let shiftvar = env#mk_arm_register_variable srtreg in let shifted = XOp (XAsr, [XVar indexvar; XVar shiftvar]) in - XOp (XPlus, [shifted; xoffset]) + Ok (XOp (XPlus, [shifted; xoffset])) | _ -> - begin - (if collect_diagnostics () then - ch_diagnostics_log#add - "operand#to_address" - (LBLOCK [STR "ARMShiftedIndexOffset: "; self#toPretty])); - random_constant_expr - end) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "register shift: " + ^ (register_shift_to_string srt) + ^ " not yet supported"]) | _ -> - begin - (if collect_diagnostics () then - ch_diagnostics_log#add - "operand#to_address" - (LBLOCK [STR "memoff: "; self#toPretty])); - random_constant_expr - end + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "arm memory offset: " + ^ (arm_memory_offset_to_string offset) + ^ " not yet supported with isadd: " + ^ (if isadd then "true" else "false")] else - zero_constant_expr in + Ok zero_constant_expr in let rvar = env#mk_arm_register_variable r in let rvarx = if align > 1 then @@ -401,25 +398,25 @@ object (self:'a) else XVar rvar in (* memory addresses are not rewritten to preserve the structure of the - data accessed (in case of an non-optimizing compiler) *) - let addr = XOp (XPlus, [rvarx; memoff]) in - (* floc#inv#rewrite_expr addr *) - simplify_xpr addr - | ARMLiteralAddress dw -> num_constant_expr dw#to_numerical + data accessed (in case of a non-optimizing compiler) *) + TR.tmap + (fun memoff -> simplify_xpr (XOp (XPlus, [rvarx; memoff]))) + xoffset_r + + | ARMLiteralAddress dw -> Ok (num_constant_expr dw#to_numerical) | _ -> - begin - (if collect_diagnostics () then - ch_diagnostics_log#add - "operand#to_address" - (LBLOCK [STR "Other address: "; self#toPretty])); - random_constant_expr - end - - method to_updated_offset_address (floc: floc_int): (int * xpr_t) TR.traceresult = + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Address for " ^ (p2s self#toPretty) + ^ " not yet supported"] + + method to_updated_offset_address (floc: floc_int): (int * xpr_t) traceresult = match kind with | ARMOffsetAddress (_r, _align, offset, isadd, _iswback, isindex, _) -> if isindex then - Ok (0, self#to_address floc) + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun addr -> (0, addr)) + (self#to_address floc) else let optinc = match (offset, isadd) with @@ -428,174 +425,127 @@ object (self:'a) | _ -> None in (match optinc with | None -> - Error [ - "to_updated_offset_address: offset type " - ^ (arm_memory_offset_to_string offset) - ^ "not covered for offset address update"] + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "offset type " + ^ (arm_memory_offset_to_string offset) + ^ "not covered for offset address update"] | Some inc -> - let addr = - XOp (XPlus, [self#to_address floc; int_constant_expr inc]) in - Ok (inc, floc#inv#rewrite_expr addr)) + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun addr -> + let a = XOp (XPlus, [addr; int_constant_expr inc]) in + (inc, floc#inv#rewrite_expr a)) + (self#to_address floc)) | _ -> - Error [ - "to_updated_offset_address: not applicable to operand kind: " + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not applicable to operand kind: " ^ (p2s self#toPretty)] - method to_variable (floc:floc_int): variable_t = + method to_variable (floc:floc_int): variable_t traceresult = let env = floc#f#env in match kind with | ARMReg r | ARMWritebackReg (_, r, _) -> - env#mk_arm_register_variable r + Ok (env#mk_arm_register_variable r) | ARMDoubleReg (r1, r2) -> - env#mk_arm_double_register_variable r1 r2 - | ARMExtensionReg r -> env#mk_arm_extension_register_variable r + Ok (env#mk_arm_double_register_variable r1 r2) + | ARMExtensionReg r -> + Ok (env#mk_arm_extension_register_variable r) | ARMDoubleExtensionReg (r1, r2) -> - env#mk_arm_double_extension_register_variable r1 r2 - | ARMSpecialReg r -> env#mk_arm_special_register_variable r + Ok (env#mk_arm_double_extension_register_variable r1 r2) + | ARMSpecialReg r -> + Ok (env#mk_arm_special_register_variable r) | ARMLiteralAddress dw -> - (match floc#env#mk_global_variable dw#to_numerical with - | Error e -> - raise - (BCH_failure - (LBLOCK [ - floc#l#toPretty; - STR ": to-variable"; - STR (String.concat "; " e)])) - | Ok v -> v) + TR.tprop + (floc#env#mk_global_variable dw#to_numerical) + (__FILE__ ^ ":" ^ (string_of_int __LINE__)) | ARMOffsetAddress (r, align, offset, isadd, _iswback, _isindex, size) -> - let (var, trace) = - (match offset with - | ARMImmOffset _ -> - let rvar = env#mk_arm_register_variable r in - let memoff = - match (offset,isadd) with - | (ARMImmOffset i, true) -> mkNumerical i - | (ARMImmOffset i, false) -> (mkNumerical i)#neg - | _ -> - raise - (BCH_failure - (LBLOCK [ - STR "to_variable: offset not implemented: "; - self#toPretty])) in - (floc#get_memory_variable_1 ~size ~align rvar memoff, - [STR "ARMImmOffset"; STR "memory-variable-1"]) - | ARMShiftedIndexOffset _ -> - let rvar = env#mk_arm_register_variable r in - (match (offset, isadd) with - | (ARMShiftedIndexOffset (ivar, srt, i), true) -> - let optscale = - match srt with - | ARMImmSRT (SRType_LSL, 2) -> Some 4 - | ARMImmSRT (SRType_LSL, 0) -> Some 1 - | _ -> None in - (match optscale with - | Some scale -> - let ivar = env#mk_arm_register_variable ivar in - if scale = 1 then - let rx = floc#inv#rewrite_expr (XVar rvar) in - let ivax = floc#inv#rewrite_expr (XVar ivar) in - let xoffset = simplify_xpr (XOp (XPlus, [rx; ivax])) in - (match xoffset with - | XConst (IntConst n) -> - let v = - (match floc#env#mk_global_variable ~size n with - | Error e -> - raise - (BCH_failure - (LBLOCK [ - floc#l#toPretty; - STR ": to-variable"; - STR (String.concat "; " e)])) - | Ok v -> v) in - (v, [STR "ARMShiftedIndexOffset"; STR "explicit"]) - | XVar v when floc#f#env#is_memory_address_variable v -> - log_tfold_default - (log_error "ARMShiftedIndexOffset" (p2s v#toPretty)) - (fun v -> - (v, [STR "ARMShiftedIndexOffset"; - v#toPretty])) - (env#mk_unknown_memory_variable "operand", - [STR "ARMShiftedIndexOffset"; - self#toPretty; - STR "; rx: "; - x2p rx; - STR ": ivax: "; - x2p ivax]) - (floc#f#env#mk_memory_address_deref_variable v) - | XOp (XPlus, [XVar basevar; XVar memoffset]) -> - let optmemvaraddr = floc#decompose_memvar_address xoffset in - (match optmemvaraddr with - | Some (memref, memoffset) - when BCHMemoryReference.is_constant_offset memoffset -> - (env#mk_index_offset_memory_variable memref memoffset, - [STR "ARMShiftedIndexOffset (decomposed)"; - self#toPretty; - STR "; memref: "; - memref#toPretty; - STR "; memoffset: "; - BCHMemoryReference.memory_offset_to_pretty memoffset]) - | _ -> - (env#mk_unknown_memory_variable "operand", - [STR "ARMShiftedIndexOffset (sum)"; - self#toPretty; - STR "; basevar: "; - basevar#toPretty; - STR "; memoffset: "; - memoffset#toPretty])) - | _ -> - (env#mk_unknown_memory_variable "operand", - [STR "ARMShiftedIndexOffset"; - self#toPretty; - STR "; rx: "; - x2p rx; - STR ": ivax: "; - x2p ivax])) - else - (floc#get_memory_variable_3 - ~size rvar ivar scale (mkNumerical i), - [STR "ARMShiftedIndexOffset"; - self#toPretty; - STR ": "; - STR "memory-variable-3"]) - | _ -> - (env#mk_unknown_memory_variable "operand", - [STR "ARMShiftedIndexOffset"; STR "no scale"; self#toPretty])) + (match offset with + | ARMImmOffset _ -> + let rvar = env#mk_arm_register_variable r in + let numoffset_r = + match (offset, isadd) with + | (ARMImmOffset i, true) -> Ok (mkNumerical i) + | (ARMImmOffset i, false) -> Ok (mkNumerical i)#neg + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Immediate offset not yet implemented for offset " + ^ (arm_memory_offset_to_string offset)] in + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun memoff -> + floc#get_memory_variable_numoffset ~size ~align rvar memoff) + numoffset_r + + | ARMIndexOffset (ri, i) -> + let rvar = env#mk_arm_register_variable r in + let ivar = env#mk_arm_register_variable ri in + if isadd then + let rx = floc#inv#rewrite_expr (XVar rvar) in + let ivax = floc#inv#rewrite_expr (XVar ivar) in + let xoffset = simplify_xpr (XOp (XPlus, [rx; ivax])) in + (match (xoffset, i) with + | (XConst (IntConst n), 0) -> + floc#env#mk_global_variable ~size n | _ -> - (env#mk_unknown_memory_variable "operand", - [STR "ARMShiftedIndexOffset"; STR "unsupported"; self#toPretty])) - | _ -> - (env#mk_unknown_memory_variable "operand", - [STR "ARMOffsetAddress"; STR "unsupported"; self#toPretty])) in - let _ = - if (env#is_unknown_memory_variable var) || var#isTemporary then - if (List.length trace) > 0 then - chlog#add - "unknown memory location" - (LBLOCK ( - [floc#l#toPretty; STR ". "] - @ [List.hd trace] - @ [STR ": "] - @ (List.tl trace))) + floc#get_memory_variable_varoffset + ~size rvar ivar (mkNumerical i)) else - chlog#add - "unknown memory location - no info" - (LBLOCK [floc#l#toPretty]) in - var + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Index offset with is_add false not yet supported: " + ^ (p2s self#toPretty)] + + | ARMShiftedIndexOffset _ -> + let rvar = env#mk_arm_register_variable r in + (match (offset, isadd) with + | (ARMShiftedIndexOffset (ivar, srt, i), true) -> + let optscale = + match srt with + | ARMImmSRT (SRType_LSL, 3) -> Some 8 + | ARMImmSRT (SRType_LSL, 2) -> Some 4 + | ARMImmSRT (SRType_LSL, 0) -> Some 1 + | _ -> None in + (match optscale with + | Some scale -> + let ivar = env#mk_arm_register_variable ivar in + if scale = 1 then + let rx = floc#inv#rewrite_expr (XVar rvar) in + let ivax = floc#inv#rewrite_expr (XVar ivar) in + let xoffset = simplify_xpr (XOp (XPlus, [rx; ivax])) in + (match (xoffset, i) with + | (XConst (IntConst n), 0) -> + floc#env#mk_global_variable ~size n + | _ -> + floc#get_memory_variable_varoffset + ~size rvar ivar (mkNumerical i)) + else + floc#get_memory_variable_scaledoffset + ~size rvar ivar scale (mkNumerical i) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Scaled memory offset with register shift " + ^ (register_shift_to_string srt) + ^ " not yet supported"]) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Shifted Index Offset with isadd: false: " + ^ (p2s self#toPretty) + ^ " not yet supported"])) + | ARMShiftedReg (r, ARMImmSRT (SRType_LSL, 0)) -> - env#mk_arm_register_variable r + Ok (env#mk_arm_register_variable r) + | _ -> - raise - (BCH_failure - (LBLOCK [ - STR "Operand:to_variable not yet implemented for: "; - self#toPretty])) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "ARMOffsetAddress: " ^ (p2s self#toPretty) + ^ " not yet supported"] - method to_multiple_variable (floc:floc_int): variable_t list = + method to_multiple_variable (floc:floc_int): (variable_t traceresult list) = let env = floc#f#env in match kind with - | ARMRegList rl -> List.map env#mk_arm_register_variable rl + | ARMRegList rl -> + List.map (fun r -> Ok (env#mk_arm_register_variable r)) rl | ARMExtensionRegList rl -> - List.map env#mk_arm_extension_register_variable rl + List.map (fun r -> Ok (env#mk_arm_extension_register_variable r)) rl | ARMMemMultiple (r, _, n, size) -> let rvar = env#mk_arm_register_variable r in let rec loop i l = @@ -603,159 +553,134 @@ object (self:'a) l else let offset = mkNumerical ((i - 1) * size) in - loop (i - 1) ((floc#get_memory_variable_1 rvar offset) :: l) in - loop n [] + loop (i - 1) ((floc#get_memory_variable_numoffset rvar offset) :: l) in + (loop n []) | _ -> - raise - (BCH_failure - (LBLOCK [STR "to-multiple-variable not applicable: "; - self#toPretty])) + [Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not applicable to " ^ (p2s self#toPretty)]] - method to_expr ?(unsigned=false) (floc:floc_int): xpr_t = + method to_expr ?(unsigned=false) (floc:floc_int): xpr_t traceresult = match kind with | ARMImmediate imm -> let imm = if unsigned then imm#to_unsigned else imm in - (match imm#to_doubleword with - | Some dw -> - if has_symbolic_address_name dw then - let name = get_symbolic_address_name dw in - let var = - floc#f#env#mk_global_memory_address - ~optname:(Some name) imm#to_numerical in - XVar var - else - num_constant_expr imm#to_numerical - | _ -> num_constant_expr imm#to_numerical) - | ARMFPConstant _ -> XConst XRandom - | ARMReg _ | ARMWritebackReg _ -> XVar (self#to_variable floc) - | ARMDoubleReg _ -> XVar (self#to_variable floc) - | ARMSpecialReg _ -> XVar (self#to_variable floc) - | ARMExtensionReg _ -> XVar (self#to_variable floc) - | ARMDoubleExtensionReg _ -> XVar (self#to_variable floc) - | ARMExtensionRegElement _ -> XConst XRandom - | ARMOffsetAddress _ -> XVar (self#to_variable floc) + Ok (num_constant_expr imm#to_numerical) + | ARMFPConstant _ -> + Ok (XConst XRandom) + | ARMReg _ | ARMWritebackReg _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) + | ARMDoubleReg _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) + | ARMSpecialReg _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) + | ARMExtensionReg _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) + | ARMDoubleExtensionReg _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) + | ARMExtensionRegElement _ -> + Ok (XConst XRandom) + | ARMOffsetAddress _ -> + TR.tmap (fun v -> XVar v) (self#to_variable floc) | ARMAbsolute a when elf_header#is_program_address a -> - num_constant_expr a#to_numerical + Ok (num_constant_expr a#to_numerical) | ARMLiteralAddress a -> - if elf_header#is_program_address a then - let dw = elf_header#get_program_value a in - if has_symbolic_address_name dw then - let name = get_symbolic_address_name dw in - let ty = get_symbolic_address_type_by_name name in - if is_struct_type ty || is_array_type ty then - let var = - floc#f#env#mk_global_memory_address - ~optname:(Some name) ~opttype:(Some ty) dw#to_numerical in - XVar var - else - num_constant_expr (elf_header#get_program_value a)#to_numerical - else - num_constant_expr (elf_header#get_program_value a)#to_numerical + if elf_header#is_readonly_address a then + Ok (num_constant_expr (elf_header#get_program_value a)#to_numerical) else - begin - ch_error_log#add - "literal address not found" - (LBLOCK [floc#l#toPretty; STR ": "; a#toPretty]); - XConst (XRandom) - end + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Literal (read-only) address not found: " + ^ (p2s a#toPretty)] | ARMAbsolute a -> - begin - ch_error_log#add - "absolute address" - (LBLOCK [STR "Address "; a#toPretty; STR " not found"]); - num_constant_expr a#to_numerical - end + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Absolute address " ^ (p2s a#toPretty) ^ " not found"] | ARMShiftedReg (r, ARMImmSRT (SRType_LSL, 0)) -> - let env = floc#f#env in - XVar (env#mk_arm_register_variable r) + Ok (XVar (floc#env#mk_arm_register_variable r)) | ARMShiftedReg (r, ARMImmSRT (SRType_LSR, n)) -> - let env = floc#f#env in - XOp - (XLsr, - [XVar (env#mk_arm_register_variable r); int_constant_expr n]) + let vreg = floc#env#mk_arm_register_variable r in + Ok (XOp (XLsr, [XVar vreg; int_constant_expr n])) | ARMShiftedReg (r, ARMImmSRT (SRType_ASR, n)) -> - let env = floc#f#env in - XOp - (XAsr, - [XVar (env#mk_arm_register_variable r); int_constant_expr n]) + let vreg = floc#env#mk_arm_register_variable r in + Ok (XOp (XAsr, [XVar vreg; int_constant_expr n])) | ARMShiftedReg (r, ARMImmSRT (SRType_LSL, n)) -> - let env = floc#f#env in - XOp - (XLsl, - [XVar (env#mk_arm_register_variable r); int_constant_expr n]) + let vreg = floc#env#mk_arm_register_variable r in + Ok (XOp (XLsl, [XVar vreg; int_constant_expr n])) | ARMShiftedReg (r, ARMRegSRT (SRType_LSL, sr)) -> - let env = floc#f#env in - let shiftv = - XOp (XBAnd, - [XVar (env#mk_arm_register_variable sr); - int_constant_expr 7]) in - XOp (XLsl, [XVar (env#mk_arm_register_variable r); shiftv]) - | ARMShiftedReg _ -> - let _ = - chlog#add - "shifted-reg unknown" - (LBLOCK [self#toPretty]) in - XConst (XRandom) + let vsreg = floc#env#mk_arm_register_variable sr in + let vreg = floc#env#mk_arm_register_variable r in + let shiftv = XOp (XBAnd, [XVar vsreg; int_constant_expr 7]) in + Ok (XOp (XLsl, [XVar vreg; shiftv])) + | ARMShiftedReg (_, srt) -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Shifted reg: " ^ (register_shift_to_string srt) + ^ " not yet supported"] | ARMRegBitSequence (r, lsb, widthm1) -> - let regvar = XVar (floc#env#mk_arm_register_variable r) in + let xreg = XVar (floc#env#mk_arm_register_variable r) in (match (lsb, widthm1) with | (8, 7) -> - XOp (XXbyte, [int_constant_expr 1; regvar]) + Ok (XOp (XXbyte, [int_constant_expr 1; xreg])) | _ -> let mask = Int.shift_left 1 (widthm1+1) in if lsb = 0 then - XOp (XBAnd, [regvar; int_constant_expr mask]) + Ok (XOp (XBAnd, [xreg; int_constant_expr mask])) else - let shiftedreg = XOp (XLsr, [regvar; int_constant_expr lsb]) in - XOp (XBAnd, [shiftedreg; int_constant_expr mask])) + let shiftedreg = XOp (XLsr, [xreg; int_constant_expr lsb]) in + Ok (XOp (XBAnd, [shiftedreg; int_constant_expr mask]))) | _ -> - raise - (BCH_failure - (LBLOCK [ - STR "Operand:to_expr not yet implemented for: "; - self#toPretty])) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Operand: " ^ (p2s self#toPretty) + ^ " not yet supported"] - method to_multiple_expr (floc:floc_int): xpr_t list = + method to_multiple_expr (floc:floc_int): (xpr_t traceresult list) = match kind with | ARMRegList _ -> let rlops = self#get_register_op_list in - List.map (fun (op: 'a) -> op#to_expr floc) rlops + List.map (fun (op:'a) -> op#to_expr floc) rlops + | ARMExtensionRegList _ -> let rlops = self#get_extension_register_op_list in - List.map (fun (op: 'a) -> op#to_expr floc) rlops + List.map (fun (op:'a) -> op#to_expr floc) rlops + | _ -> - raise - (BCH_failure - (LBLOCK [ - STR "to-multiple-expr not applicable: "; - self#toPretty])) + [Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Operand cannot produce multiple expressions: " + ^ (p2s self#toPretty)]] - method to_lhs (floc:floc_int) = + method to_lhs (floc:floc_int): (variable_t * cmd_t list) traceresult = match kind with | ARMImmediate _ -> - raise - (BCH_failure - (LBLOCK [STR "Immediate cannot be a lhs: "; - self#toPretty])) - | ARMReg _ | ARMWritebackReg _ -> (self#to_variable floc, []) - | ARMDoubleReg _ -> (self#to_variable floc, []) - | ARMExtensionReg _ -> (self#to_variable floc, []) - | ARMDoubleExtensionReg _ -> (self#to_variable floc, []) - | ARMOffsetAddress _ -> (self#to_variable floc, []) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Immediate cannot be a lhs: " + ^ (p2s self#toPretty)] + + | ARMReg _ + | ARMWritebackReg _ -> + TR.tmap (fun v -> (v, [])) (self#to_variable floc) + | ARMDoubleReg _ -> + TR.tmap (fun v -> (v, [])) (self#to_variable floc) + | ARMExtensionReg _ -> + TR.tmap (fun v -> (v, [])) (self#to_variable floc) + | ARMDoubleExtensionReg _ -> + TR.tmap (fun v -> (v, [])) (self#to_variable floc) + | ARMOffsetAddress _ -> + TR.tmap (fun v -> (v, [])) (self#to_variable floc) | _ -> - raise - (BCH_failure - (LBLOCK [STR "Lhs not implemented for "; self#toPretty])) + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Lhs not implemented for " ^ (p2s self#toPretty)] - method to_multiple_lhs (floc: floc_int) = + method to_multiple_lhs (floc: floc_int): + (variable_t traceresult list * cmd_t list) = match kind with - | ARMRegList _ - | ARMMemMultiple _ -> (self#to_multiple_variable floc, []) + | ARMRegList _ -> + let rlops = self#get_register_op_list in + (List.map (fun (op:'a) -> op#to_variable floc) rlops, []) + + | ARMExtensionRegList _ -> + let rlops = self#get_extension_register_op_list in + (List.map (fun (op:'a) -> op#to_variable floc) rlops, []) + | _ -> - raise - (BCH_failure - (LBLOCK [STR "to_multiple_lhs not available for "; - self#toPretty])) + ([Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Not an operand kind with multiple lhs: " + ^ (p2s self#toPretty)]], []) method is_immediate = match kind with ARMImmediate _ -> true | _ -> false diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.ml b/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.ml index 4c124731..fc33b7b1 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2023-2024 Aarno Labs, LLC + Copyright (c) 2023-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 @@ -29,6 +29,9 @@ (* chlib *) open CHLanguage +(* chutil *) +open CHTraceResult + (* xprlib *) open XprTypes @@ -41,7 +44,7 @@ open BCHARMTypes module H = Hashtbl type testdatatype_t = - | Tst_instrx_data of variable_t list * xpr_t list + | Tst_instrx_data of variable_t traceresult list * xpr_t traceresult list | Tst_instrx_tags of string list | Tst_chif_conditionxprs of arm_assembly_instruction_int * arm_assembly_instruction_int * xpr_t list @@ -74,8 +77,8 @@ object method submit_instrx_data (iaddr: doubleword_int) - (vars: variable_t list) - (xprs: xpr_t list) = + (vars: variable_t traceresult list) + (xprs: xpr_t traceresult list) = if H.mem testdata "instrx_data" then H.add (H.find testdata "instrx_data") diff --git a/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.mli b/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.mli index e0d38109..72b942e1 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.mli +++ b/CodeHawk/CHB/bchlibarm32/bCHARMTestSupport.mli @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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/CHB/bchlibarm32/bCHARMTypes.mli b/CodeHawk/CHB/bchlibarm32/bCHARMTypes.mli index 3c4cbd95..dae4ee32 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHARMTypes.mli +++ b/CodeHawk/CHB/bchlibarm32/bCHARMTypes.mli @@ -184,13 +184,13 @@ class type arm_operand_int = method to_numerical: numerical_t method to_register: register_t method to_multiple_register: register_t list - method to_address: floc_int -> xpr_t - method to_variable: floc_int -> variable_t - method to_multiple_variable: floc_int -> variable_t list - method to_expr: ?unsigned:bool -> floc_int -> xpr_t - method to_multiple_expr: floc_int -> xpr_t list - method to_lhs: floc_int -> variable_t * cmd_t list - method to_multiple_lhs: floc_int -> variable_t list * cmd_t list + method to_address: floc_int -> xpr_t traceresult + method to_variable: floc_int -> variable_t traceresult + method to_multiple_variable: floc_int -> variable_t traceresult list + method to_expr: ?unsigned:bool -> floc_int -> xpr_t traceresult + method to_multiple_expr: floc_int -> xpr_t traceresult list + method to_lhs: floc_int -> (variable_t * cmd_t list) traceresult + method to_multiple_lhs: floc_int -> (variable_t traceresult list) * cmd_t list method to_updated_offset_address: floc_int -> (int * xpr_t) traceresult method to_btype: btype_t @@ -1523,6 +1523,15 @@ type arm_aggregate_kind_t = | ARMJumptable of arm_jumptable_int | ThumbITSequence of thumb_it_sequence_int | LDMSTMSequence of ldm_stm_sequence_int + | PseudoLDRSH of + arm_assembly_instruction_int + * arm_assembly_instruction_int + * arm_assembly_instruction_int + | PseudoLDRSB of + arm_assembly_instruction_int + * arm_assembly_instruction_int + * arm_assembly_instruction_int + | ARMPredicateAssignment of bool * arm_operand_int | BXCall of arm_assembly_instruction_int * arm_assembly_instruction_int @@ -1546,6 +1555,9 @@ class type arm_instruction_aggregate_int = method is_it_sequence: bool method is_ldm_stm_sequence: bool method is_bx_call: bool + method is_pseudo_ldrsh: bool + method is_pseudo_ldrsb: bool + method is_predicate_assign: bool (* i/o *) method write_xml: xml_element_int -> unit @@ -2011,9 +2023,12 @@ class type testsupport_int = method request_instrx_data: unit method requested_instrx_data: bool method submit_instrx_data: - doubleword_int -> variable_t list -> xpr_t list -> unit + doubleword_int + -> variable_t traceresult list + -> xpr_t traceresult list -> unit method retrieve_instrx_data: - string -> (variable_t list * xpr_t list) traceresult + string + -> (variable_t traceresult list * xpr_t traceresult list) traceresult (** {1 Instrx tags} Instrx tags submitted is identified by the address of the instruction. diff --git a/CodeHawk/CHB/bchlibarm32/bCHConstructARMFunction.ml b/CodeHawk/CHB/bchlibarm32/bCHConstructARMFunction.ml index 8a56b0c6..99e86ff6 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHConstructARMFunction.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHConstructARMFunction.ml @@ -237,32 +237,33 @@ let get_successors | Branch (ACCAlways, op, _) | BranchExchange (ACCAlways, op) when op#is_register -> let floc = get_floc_by_address faddr instr#get_address in - let opxpr = op#to_expr floc in - let opxpr = floc#inv#rewrite_expr opxpr in - (match opxpr with - | XConst (IntConst n) -> - let tgt = - if (n#modulo (mkNumerical 2))#equal numerical_one then - n#sub numerical_one - else - n in - log_tfold_default - (mk_tracelog_spec - ~tag:"construct-function" - (floc#cia ^ ": constant: " ^ n#toString)) - (fun addr -> - if !arm_assembly_instructions#is_code_address addr then - [addr] - else - let floc = get_floc_by_address faddr instr#get_address in - begin - floc#f#set_unknown_jumptarget - instr#get_address#to_hex_string; - [] - end) + TR.tfold + ~ok:(fun opxpr -> + let opxpr = floc#inv#rewrite_expr opxpr in + match opxpr with + | XConst (IntConst n) -> + let tgt = + if (n#modulo (mkNumerical 2))#equal numerical_one then + n#sub numerical_one + else + n in + let addr = numerical_mod_to_doubleword tgt in + if !arm_assembly_instructions#is_code_address addr then + [addr] + else + let floc = get_floc_by_address faddr instr#get_address in + begin + floc#f#set_unknown_jumptarget + instr#get_address#to_hex_string; + [] + end + | _ -> []) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; [] - (numerical_to_doubleword tgt) - | _ -> []) + end) + (op#to_expr floc) (* no information available, give up *) | Branch _ | BranchExchange _ -> @@ -308,8 +309,10 @@ let construct_arm_assembly_block let newfnentries = new DoublewordCollections.set_t in let set_block_entry (a: doubleword_int) = - TR.titer (fun instr -> - instr#set_block_entry) (get_arm_assembly_instruction a) in + TR.titer + ~ok:(fun instr -> instr#set_block_entry) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + (get_arm_assembly_instruction a) in let get_instr = get_arm_assembly_instruction in let has_next_instr = @@ -560,7 +563,8 @@ let construct_arm_assembly_function List.iter (fun a -> if doneset#has a then () else workset#add a) l in let set_block_entry (baddr: doubleword_int) = TR.titer - (fun instr -> instr#set_block_entry) + ~ok:(fun instr -> instr#set_block_entry) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) (get_arm_assembly_instruction baddr) in let blocks = ref [] in let rec add_block (baddr: doubleword_int) = diff --git a/CodeHawk/CHB/bchlibarm32/bCHFnARMDictionary.ml b/CodeHawk/CHB/bchlibarm32/bCHFnARMDictionary.ml index 48c4ffad..3d535ca6 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHFnARMDictionary.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHFnARMDictionary.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 @@ -35,6 +35,7 @@ open CHPretty open CHIndexTable open CHLogger open CHPrettyUtil +open CHTraceResult open CHXmlDocument (* xprlib *) @@ -104,8 +105,8 @@ object (self) ] method index_sp_offset (o:(int * interval_t)) = - let (level,offset) = o in - let key = ([],[level; xd#index_interval offset]) in + let (level, offset) = o in + let key = ([], [level; xd#index_interval offset]) in sp_offset_table#add key method get_sp_offset (index:int) = @@ -124,6 +125,13 @@ object (self) (instr:arm_assembly_instruction_int) (floc:floc_int) = let varinv = floc#varinv in + let e16_c = int_constant_expr e16 in + let e32_c = int_constant_expr e32 in + let log_dc_error_result (file: string) (line: int) (e: string list) = + if BCHSystemSettings.system_settings#collect_data then + log_error_result ~msg:(p2s floc#l#toPretty) file line e + else + () in let rewrite_expr ?(restrict:int option) (x: xpr_t): xpr_t = try let xpr = floc#inv#rewrite_expr x in @@ -209,8 +217,11 @@ object (self) raise (BCH_failure (LBLOCK [STR "Empty tag list in add_instr_condition"])) in + let argslen = List.length args in let xtag = (List.hd tags) ^ "xx" in - let tags = xtag :: ((List.tl tags) @ ["ic"; "icr"]) in + let ictag = "ic:" ^ (string_of_int argslen) in + let icrtag = "icr:" ^ (string_of_int (argslen + 1)) in + let tags = xtag :: ((List.tl tags) @ [ictag; icrtag]) in let xneg = XOp (XLNot, [x]) in let xneg = simplify_xpr xneg in let args = args @ [xd#index_xpr x; xd#index_xpr xneg] in @@ -259,6 +270,9 @@ object (self) | _ -> -1) | _ -> -1 in + let get_rdef_r (x_r: xpr_t traceresult): int = + TR.tfold_default get_rdef (-1) x_r in + let get_all_rdefs (xpr: xpr_t): int list = let vars = floc#env#variables_in_expr xpr in List.fold_left (fun acc v -> @@ -273,6 +287,9 @@ object (self) vix :: newacc) [] varinvs in newixs @ acc) [] vars in + let get_all_rdefs_r (x_r: xpr_t traceresult): int list = + TR.tfold_default get_all_rdefs [] x_r in + let get_rdef_memvar (v: variable_t): int = let symvar = floc#f#env#mk_symbolic_variable v in let varinvs = varinv#get_var_reaching_defs symvar in @@ -280,6 +297,9 @@ object (self) | [vinv] -> vinv#index | _ -> -1 in + let get_rdef_memvar_r (v_r: variable_t traceresult): int = + TR.tfold_default get_rdef_memvar (-1) v_r in + let get_def_use (v: variable_t): int = let symvar = floc#f#env#mk_symbolic_variable v in let varinvs = varinv#get_var_def_uses symvar in @@ -287,6 +307,9 @@ object (self) | [vinv] -> vinv#index | _ -> -1 in + let get_def_use_r (v_r: variable_t traceresult): int = + TR.tfold_default get_def_use (-1) v_r in + let get_def_use_high (v: variable_t): int = let symvar = floc#f#env#mk_symbolic_variable v in let varinvs = varinv#get_var_def_uses_high symvar in @@ -294,30 +317,72 @@ object (self) | [vinv] -> vinv#index | _ -> -1 in + let get_def_use_high_r (v_r: variable_t traceresult): int = + TR.tfold_default get_def_use_high (-1) v_r in + + let index_variable (v_r: variable_t traceresult): int = + TR.tfold + ~ok:xd#index_variable + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; -2 end) + v_r in + + let index_xpr (x_r: xpr_t traceresult): int = + TR.tfold + ~ok:xd#index_xpr + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; -2 end) + x_r in + let add_base_update (tags: string list) (args: int list) - (v: variable_t) + (v: variable_t traceresult) (inc: int) - (x: xpr_t): (string list) * (int list) = + (x: xpr_t traceresult): (string list) * (int list) = let _ = if (List.length tags) = 0 then raise (BCH_failure - (LBLOCK [STR "Empty tag list in add_base_update"])) in + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Empty tag list"])) in let xtag = (List.hd tags) ^ "vtlxdh" in - let uses = [get_def_use v] in - let useshigh = [get_def_use_high v] in - let tags = xtag :: ((List.tl tags) @ ["bu"]) in + let uses = [get_def_use_r v] in + let useshigh = [get_def_use_high_r v] in + let argslen = List.length args in + let vbutag = "vbu:" ^ (string_of_int argslen) in + let xbutag = "xbu:" ^ (string_of_int (argslen + 3)) in + let tags = xtag :: ((List.tl tags) @ [vbutag; xbutag]) in let args = args - @ [xd#index_variable v; + @ [index_variable v; bcd#index_typ t_unknown; inc; - xd#index_xpr x] + index_xpr x] @ uses @ useshigh in (tags, args) in + let add_return_value + (tags: string list) + (args: int list) + (rv: xpr_t traceresult) + (rrv: xpr_t traceresult): (string list) * (int list) = + let _ = + if (List.length tags) = 0 then + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Empty tag list"])) in + let rdefs = [get_rdef_r rv] @ (get_all_rdefs_r rrv) in + let xtag = (List.hd tags) ^ "xx" ^ (string_repeat "r" (List.length rdefs)) in + let argslen = List.length args in + let returntag = "return:" ^ (string_of_int argslen) in + let tags = xtag :: ((List.tl tags) @ [returntag]) in + let args = args @ [index_xpr rv; index_xpr rrv] @ rdefs in + (tags, args)in + let mk_instrx_data ?(vars: variable_t list = []) ?(types: btype_t list = []) @@ -327,9 +392,11 @@ object (self) ?(useshigh: int list = []) ?(integers: int list = []) () = + (* let _ = if testsupport#requested_instrx_data then testsupport#submit_instrx_data instr#get_address vars xprs in + *) let varcount = List.length vars in let xprcount = List.length xprs in let rdefcount = List.length rdefs in @@ -374,6 +441,62 @@ object (self) @ flagrdefs @ integers) in + let mk_instrx_data_r + ?(vars_r: variable_t traceresult list = []) + ?(types: btype_t list = []) + ?(xprs_r: xpr_t traceresult list = []) + ?(rdefs: int list = []) + ?(uses: int list = []) + ?(useshigh: int list = []) + ?(integers: int list = []) + () = + let _ = + if testsupport#requested_instrx_data then + testsupport#submit_instrx_data instr#get_address vars_r xprs_r in + let varcount = List.length vars_r in + let xprcount = List.length xprs_r in + let rdefcount = List.length rdefs in + let defusecount = List.length uses in + let defusehighcount = List.length useshigh in + let flagrdefcount = List.length flagrdefs in + let integercount = List.length integers in + let varstring = string_repeat "v" varcount in + let typestring = string_repeat "t" varcount in + let xprstring = string_repeat "x" xprcount in + let rdefstring = string_repeat "r" rdefcount in + let defusestring = string_repeat "d" defusecount in + let defusehighstring = string_repeat "h" defusehighcount in + let flagrdefstring = string_repeat "f" flagrdefcount in + let integerstring = string_repeat "l" integercount in + let tagstring = + "ar:" + ^ varstring + ^ typestring + ^ xprstring + ^ rdefstring + ^ defusestring + ^ defusehighstring + ^ flagrdefstring + ^ integerstring in + let varargs = List.map index_variable vars_r in + let xprargs = List.map index_xpr xprs_r in + let typeargs = + let types = + if (List.length types) < varcount then + List.map (fun _ -> t_unknown) vars_r + else + types in + List.map bcd#index_typ types in + (tagstring, + varargs + @ typeargs + @ xprargs + @ rdefs + @ uses + @ useshigh + @ flagrdefs + @ integers) in + let add_optional_instr_condition (tagstring: string) (args: int list) @@ -387,7 +510,7 @@ object (self) add_instr_condition [tagstring] args tcond | _ -> (tagstring :: ["uc"], args) in - let add_optional_subsumption (tags: string list) = + let add_optional_subsumption (tags: string list): string list = match instr#is_in_aggregate with | Some va -> tags @ ["subsumed"; va#to_hex_string] | _ -> tags in @@ -403,17 +526,22 @@ object (self) agginstr#get_address#to_hex_string :: acc) [] agg#instrs in tags @ ("subsumes" :: deps) in - let add_bx_call_defs - ?(xprs: xpr_t list = []) + let add_bx_call_defs_r + ?(xprs_r: xpr_t traceresult list = []) ?(rdefs: int list = []) (tags: string list) (args: int list): (string list * int list) = let tagstring = List.hd tags in - let xprcount = List.length xprs in + let xprcount = List.length xprs_r in let rdefcount = List.length rdefs in let tagstring = tagstring ^ (string_repeat "x" xprcount) in let tagstring = tagstring ^ (string_repeat "r" rdefcount) in - let args = args @ (List.map xd#index_xpr xprs) @ rdefs in + (* move the call target index (into the interface dictionary) to the + end of args list, so it is not interpreted as an expression *) + let args_calltgt_ix = List.hd (List.rev args) in + let args_proper = List.rev (List.tl (List.rev args)) in + let args = args_proper @ (List.map index_xpr xprs_r) @ rdefs in + let args = args @ [args_calltgt_ix] in let tags = (tagstring :: (List.tl tags)) @ ["bx-call"] in (tags, args) in @@ -460,34 +588,43 @@ object (self) let callinstr_key (): (string list * int list) = let callargs = floc#get_call_arguments in let _ = check_for_functionptr_args callargs in - let (xprs, xvars, rdefs) = - List.fold_left (fun (xprs, xvars, rdefs) (p, x) -> - let xvar = + let (xprs, xvars, rdefs, _) = + List.fold_left (fun (xprs, xvars, rdefs, index) (p, x) -> + let xvar_r = if is_register_parameter p then let regarg = TR.tget_ok (get_register_parameter_register p) in let pvar = floc#f#env#mk_register_variable regarg in - XVar pvar + Ok (XVar pvar) else if is_stack_parameter p then - let p_offset = TR.tget_ok (get_stack_parameter_offset p) in - let sp = (sp_r RD)#to_expr floc in - XOp (XPlus, [sp; int_constant_expr p_offset]) + let p_offset_r = get_stack_parameter_offset p in + let sp_r = (sp_r RD)#to_expr floc in + TR.tmap2 (fun p_offset sp -> + XOp (XPlus, [sp; int_constant_expr p_offset])) + p_offset_r sp_r else - raise - (BCH_failure - (LBLOCK [ - floc#l#toPretty; - STR ": Parameter type not recognized in call "; - STR "instruction"])) in + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Parameter type not recognized in call instruction"] in let xx = rewrite_expr ?restrict:(Some 4) x in + (* let xx = - let optmemvar = floc#decompose_memvar_address xx in - match optmemvar with - | Some (memref, memoff) -> - XOp ((Xf "addressofvar"), - [XVar (floc#f#env#mk_index_offset_memory_variable memref memoff)]) - | _ -> xx in - let rdef = get_rdef xvar in - (xx :: xprs, xvar :: xvars, rdef :: rdefs)) ([], [], []) callargs in + if is_pointer ptype then + let _ = floc#memrecorder#record_argument xx index in + match get_string_reference floc xx with + | Some _ -> xx + | _ -> + match xx with + | XVar _ -> xx + | _ -> + TR.tfold_default + (fun v -> XOp ((Xf "addressofvar"), [(XVar v)])) + xx + (floc#get_var_at_address ~btype:ptype xx) + else + xx in + *) + let rdef = get_rdef_r xvar_r in + (xx :: xprs, xvar_r :: xvars, rdef :: rdefs, index + 1)) + ([], [], [], 1) callargs in let (vrd, rtype) = let fintf = floc#get_call_target#get_function_interface in let rtype = get_fts_returntype fintf in @@ -512,10 +649,10 @@ object (self) let newixs = List.filter (fun ix -> not (List.mem ix acc)) rdefs in acc @ newixs) [] xprs in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] + mk_instrx_data_r + ~vars_r:[Ok vrd] ~types:[rtype] - ~xprs:((List.rev xprs) @ (List.rev xvars)) + ~xprs_r:((List.rev (List.map (fun x -> Ok x) xprs)) @ (List.rev xvars)) ~rdefs:((List.rev rdefs) @ xrdefs) ~uses:[get_def_use vrd] ~useshigh:[get_def_use_high vrd] @@ -524,7 +661,8 @@ object (self) if instr#is_inlined_call then tagstring :: ["call"; "inlined"] else - tagstring :: ["call"; string_of_int (List.length callargs)] in + tagstring + :: ["call"; "argcount:" ^ (string_of_int (List.length callargs))] in let args = args @ [ixd#index_call_target floc#get_call_target#get_target] in (tags, args) in @@ -537,12 +675,12 @@ object (self) if agg#is_jumptable then let jt = agg#jumptable in let indexregop = jt#index_operand in - let xrn = indexregop#to_expr floc in - let xxrn = rewrite_expr xrn in - let rdefs = (get_rdef xrn) :: (get_all_rdefs xxrn) in + let xrn_r = indexregop#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let rdefs = (get_rdef_r xrn_r) :: (get_all_rdefs_r xxrn_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xxrn] + mk_instrx_data_r + ~xprs_r:[xrn_r; xxrn_r] ~rdefs:rdefs () in let tags = tagstring :: ["agg-jt"] in @@ -555,29 +693,35 @@ object (self) STR "Aggregate for Add not recognized at "; iaddr#toPretty])) | Add (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XPlus, [xrn; xrm]) in - let xxrn = rewrite_expr xrn in - let xxrm = rewrite_expr xrm in - let rresult = rewrite_expr ?restrict:(Some 4) result in - let _ = ignore (get_string_reference floc rresult) in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in - let uses = get_def_use vrd in - let useshigh = get_def_use_high vrd in - let optmemvar = floc#decompose_memvar_address rresult in - let rresult = - match optmemvar with - | Some (memref, memoff) -> - let memvar = - floc#f#env#mk_index_offset_memory_variable memref memoff in - XOp ((Xf "addressofvar"), [XVar memvar]) - | _ -> rresult in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult; xxrn; xxrm] + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XPlus, [xrn; xrm])) xrn_r xrm_r in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rresult_r = TR.tmap (rewrite_expr ?restrict:(Some 4)) result_r in + let _ = + TR.tfold_default + (fun r -> ignore (get_string_reference floc r)) () rresult_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = get_def_use_r vrd_r in + let useshigh = get_def_use_high_r vrd_r in + (* + let rresult_r = + TR.tmap + (fun rresult -> + TR.tfold_default + (fun v -> XOp ((Xf "addressofvar"), [(XVar v)])) + rresult + (floc#get_var_at_address rresult)) + rresult_r in + *) + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r; xxrn_r; xxrm_r] ~rdefs:rdefs ~uses:[uses] ~useshigh:[useshigh] @@ -587,19 +731,22 @@ object (self) (tags, args) | AddCarry (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XPlus, [xrn; xrm]) in - let rresult = rewrite_expr result in - let _ = ignore (get_string_reference floc rresult) in - let rdefs = [get_rdef xrn; get_rdef xrm] in - let uses = get_def_use vrd in - let useshigh = get_def_use_high vrd in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XPlus, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let _ = + TR.tfold_default + (fun r -> ignore (get_string_reference floc r)) () rresult_r in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = get_def_use_r vrd_r in + let useshigh = get_def_use_high_r vrd_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] ~rdefs:rdefs ~uses:[uses] ~useshigh:[useshigh] @@ -608,15 +755,17 @@ object (self) (tags, args) | Adr (c, rd, imm) -> - let vrd = rd#to_variable floc in - let ximm = imm#to_expr floc in - let _ = ignore (get_string_reference floc ximm) in - let uses = get_def_use vrd in - let useshigh = get_def_use_high vrd in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[ximm] + let vrd_r = rd#to_variable floc in + let ximm_r = imm#to_expr floc in + let _ = + TR.tfold_default + (fun x -> ignore (get_string_reference floc x)) () ximm_r in + let uses = get_def_use_r vrd_r in + let useshigh = get_def_use_high_r vrd_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[ximm_r] ~uses:[uses] ~useshigh:[useshigh] () in @@ -625,163 +774,201 @@ object (self) (tags, args) | ArithmeticShiftRight (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = - match xrm with - | XConst (IntConst n) when n#toInt = 2 -> - XOp (XDiv, [xrn; XConst (IntConst (mkNumerical 4))]) - | _ -> XOp (XAsr, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 + (fun xrn xrm -> + match xrm with + | XConst (IntConst n) when n#toInt = 2 -> + XOp (XDiv, [xrn; XConst (IntConst (mkNumerical 4))]) + | _ -> XOp (XAsr, [xrn; xrm])) + xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in + let tags = add_optional_subsumption tags in (tags, args) | BitFieldClear (c, rd, _, _, _) -> - let vrd = rd#to_variable floc in - let xrd = rd#to_expr floc in - let rdefs = [get_rdef xrd] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrd] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrd_r = rd#to_expr floc in + let rdefs = [get_rdef_r xrd_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrd_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitFieldInsert (c, rd, rn, _, _, _) -> - let vrd = rd#to_variable floc in - let xrd = rd#to_expr floc in - let xrn = rn#to_expr floc in - let rdefs = [get_rdef xrd; get_rdef xrn] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrd; xrn] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrd_r = rd#to_expr floc in + let xrn_r = rn#to_expr floc in + let rdefs = [get_rdef_r xrd_r; get_rdef_r xrn_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrd_r; xrn_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseAnd (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBAnd, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XBAnd, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseBitClear (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBAnd, [xrn; XOp (XBNot, [xrm])]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 + (fun xrn xrm -> XOp (XBAnd, [xrn; XOp (XBNot, [xrm])])) + xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseExclusiveOr (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBXor, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XBXor, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseNot (_, c, rd, rm, _) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let result = XOp (XBNot, [xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrm] @ (get_all_rdefs rresult) in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let result_r = TR.tmap (fun xrm -> XOp (XBNot, [xrm])) xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseOr (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBOr, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XBOr, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in - let _ = ignore (get_string_reference floc rresult) in + let _ = + TR.tfold_default + (fun r -> ignore (get_string_reference floc r)) () rresult_r in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | BitwiseOrNot (_, c, rd, rn, rm) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xrmn = XOp (XBNot, [xrm]) in - let result = XOp (XBOr, [xrn; xrmn]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xrmn_r = TR.tmap (fun xrm -> XOp (XBNot, [xrm])) xrm_r in + let result_r = + TR.tmap2 + (fun xrn xrmn -> XOp (XBOr, [xrn; xrmn])) xrn_r xrmn_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; xrmn; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; xrmn_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) @@ -792,24 +979,24 @@ object (self) if agg#is_jumptable then let jt = agg#jumptable in let indexregop = jt#index_operand in - let xrn = indexregop#to_expr floc in - let xxrn = rewrite_expr xrn in - let rdefs = (get_rdef xrn) :: (get_all_rdefs xxrn) in + let xrn_r = indexregop#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let rdefs = (get_rdef_r xrn_r) :: (get_all_rdefs_r xxrn_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xxrn] - ~rdefs:rdefs + mk_instrx_data_r + ~xprs_r:[xrn_r; xxrn_r] + ~rdefs () in let tags = tagstring :: ["agg-jt"] in let tags = add_subsumption_dependents agg tags in (tags, args) else if agg#is_bx_call then let (tags, args) = callinstr_key() in - let xtgt = tgt#to_expr floc in - let xxtgt = rewrite_expr xtgt in - let rdefs = (get_rdef xtgt) :: (get_all_rdefs xxtgt) in + let xtgt_r = tgt#to_expr floc in + let xxtgt_r = TR.tmap rewrite_expr xtgt_r in + let rdefs = (get_rdef_r xtgt_r) :: (get_all_rdefs_r xxtgt_r) in let (tags, args) = - add_bx_call_defs ~xprs:[xtgt; xxtgt] ~rdefs tags args in + add_bx_call_defs_r ~xprs_r:[xtgt_r; xxtgt_r] ~rdefs tags args in let tags = add_subsumption_dependents agg tags in (tags, args) else @@ -829,13 +1016,13 @@ object (self) if agg#is_jumptable then let jt = agg#jumptable in let indexregop = jt#index_operand in - let xrn = indexregop#to_expr floc in - let xxrn = rewrite_expr xrn in - let rdefs = (get_rdef xrn) :: (get_all_rdefs xxrn) in + let xrn_r = indexregop#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let rdefs = (get_rdef_r xrn_r) :: (get_all_rdefs_r xxrn_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xxrn] - ~rdefs:rdefs + mk_instrx_data_r + ~xprs_r:[xrn_r; xxrn_r] + ~rdefs () in let tags = tagstring :: ["agg-jt"] in let tags = add_subsumption_dependents agg tags in @@ -850,7 +1037,7 @@ object (self) when is_cond_conditional c && tgt#is_absolute_address && floc#has_test_expr -> - let xtgt = tgt#to_expr floc in + let xtgt_r = tgt#to_expr floc in let txpr = floc#get_test_expr in let fxpr = simplify_xpr (XOp (XLNot, [txpr])) in let csetter = floc#f#get_associated_cc_setter floc#cia in @@ -872,43 +1059,39 @@ object (self) | _ -> "0x0" in let rdefs = (get_all_rdefs txpr) @ (get_all_rdefs tcond) in let (tagstring, args) = - mk_instrx_data - ~xprs:[txpr; fxpr; tcond; fcond; xtgt] - ~rdefs:rdefs + mk_instrx_data_r + ~xprs_r:[Ok txpr; Ok fxpr; Ok tcond; Ok fcond; xtgt_r] + ~rdefs () in let (tags, args) = (tagstring :: ["TF"; csetter; bytestr], args) in let tags = add_optional_subsumption tags in (tags, args) | Branch (_, tgt, _) -> - let xtgt = tgt#to_expr floc in - let xxtgt = rewrite_expr xtgt in - let rdefs = (get_rdef xtgt) :: (get_all_rdefs xxtgt) in + let xtgt_r = tgt#to_expr floc in + let xxtgt_r = TR.tmap rewrite_expr xtgt_r in + let rdefs = (get_rdef_r xtgt_r) :: (get_all_rdefs_r xxtgt_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xtgt; xxtgt] - ~rdefs - () in + mk_instrx_data_r ~xprs_r:[xtgt_r; xxtgt_r] ~rdefs () in let tags = add_optional_subsumption [tagstring] in (tags, args) | BranchExchange (c, tgt) when tgt#is_register && tgt#get_register = ARLR -> let r0_op = arm_register_op AR0 RD in - let xr0 = r0_op#to_expr floc in - let xxr0 = rewrite_expr xr0 in - let rdefs = [get_rdef xr0] @ (get_all_rdefs xxr0) in - let (tagstring, args) = - mk_instrx_data ~xprs:[xr0; xxr0] ~rdefs:rdefs () in + let xr0_r = r0_op#to_expr floc in + let xxr0_r = TR.tmap rewrite_expr xr0_r in + let (tagstring, args) = mk_instrx_data_r () in let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = add_return_value tags args xr0_r xxr0_r in (tags, args) | BranchExchange (c, tgt) -> - let xtgt = tgt#to_expr floc in - let xxtgt = rewrite_expr xtgt in - let rdefs = (get_rdef xtgt) :: (get_all_rdefs xxtgt) in + let xtgt_r = tgt#to_expr floc in + let xxtgt_r = TR.tmap rewrite_expr xtgt_r in + let rdefs = (get_rdef_r xtgt_r) :: (get_all_rdefs_r xxtgt_r) in let (tagstring, args) = - mk_instrx_data ~xprs:[xtgt; xxtgt] ~rdefs () in + mk_instrx_data_r ~xprs_r:[xtgt_r; xxtgt_r] ~rdefs () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) @@ -916,125 +1099,135 @@ object (self) | BranchLinkExchange _ when floc#has_call_target && floc#get_call_target#is_signature_valid -> - callinstr_key() + callinstr_key () - | BranchLink (_, tgt) - | BranchLinkExchange (_, tgt) -> - let xtgt = tgt#to_expr floc in + | BranchLink (c, tgt) + | BranchLinkExchange (c, tgt) -> + let xtgt_r = tgt#to_expr floc in + let xxtgt_r = TR.tmap rewrite_expr xtgt_r in let args = List.map (fun r -> arm_register_op r RD) [AR0; AR1; AR2; AR3] in - let argxprs = + let argxprs_r = List.map (fun (a: arm_operand_int) -> a#to_expr floc) args in - let rdef = get_rdef xtgt in - let rargxprs = List.map rewrite_expr argxprs in - (["a:xxxxxr"], - ((xd#index_xpr xtgt) :: (List.map xd#index_xpr rargxprs)) @ [rdef]) + let rdefs = (get_rdef_r xtgt_r) :: (get_all_rdefs_r xxtgt_r) in + let (tagstring, args) = + mk_instrx_data_r ~xprs_r:(xxtgt_r :: argxprs_r) ~rdefs () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | ByteReverseWord(c, rd, rm, _) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let xrmm = rewrite_expr xrm in - let rdefs = [get_rdef xrm] @ (get_all_rdefs xrmm) in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; xrmm] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let xrmm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r xrmm_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; xrmm_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | ByteReversePackedHalfword (c, rd, rm, _) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let xrmm = rewrite_expr xrm in - let rdefs = [get_rdef xrm] @ (get_all_rdefs xrmm) in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; xrmm] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let xrmm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r xrmm_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; xrmm_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | Compare (c, rn, rm, _) -> - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xresult = XOp (XMinus, [xrn; xrm]) in - let xresult = rewrite_expr xresult in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs xresult) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xresult_r = + TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrn; xrm])) xrn_r xrm_r in + let result_r = TR.tmap rewrite_expr xresult_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r result_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xrm; xresult] - ~rdefs:rdefs - () in + mk_instrx_data_r ~xprs_r:[xrn_r; xrm_r; result_r] ~rdefs () in let (tags, args) = add_optional_instr_condition tagstring args c in let tags = add_optional_subsumption tags in (tags, args) | CompareBranchNonzero (rn, tgt) -> - let xrn = rn#to_expr floc in - let xtgt = tgt#to_expr floc in - let txpr = XOp (XNe, [xrn; int_constant_expr 0]) in - let fxpr = XOp (XEq, [xrn; int_constant_expr 0]) in - let tcond = rewrite_expr txpr in - let fcond = rewrite_expr fxpr in - let rdefs = [get_rdef xrn] @ (get_all_rdefs tcond) in - let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; txpr; fxpr; tcond; fcond; xtgt] - ~rdefs:rdefs + let xrn_r = rn#to_expr floc in + let xtgt_r = tgt#to_expr floc in + let txpr_r = + TR.tmap (fun xrn -> XOp (XNe, [xrn; zero_constant_expr])) xrn_r in + let fxpr_r = + TR.tmap (fun xrn -> XOp (XEq, [xrn; zero_constant_expr])) xrn_r in + let tcond_r = TR.tmap rewrite_expr txpr_r in + let fcond_r = TR.tmap rewrite_expr fxpr_r in + let rdefs = [get_rdef_r xrn_r] @ (get_all_rdefs_r tcond_r) in + let (tagstring, args) = + mk_instrx_data_r + ~xprs_r:[xrn_r; txpr_r; fxpr_r; tcond_r; fcond_r; xtgt_r] + ~rdefs () in let (tags, args) = (tagstring :: ["TF"], args) in (tags, args) | CompareBranchZero (rn, tgt) -> - let xrn = rn#to_expr floc in - let xtgt = tgt#to_expr floc in - let txpr = XOp (XEq, [xrn; int_constant_expr 0]) in - let fxpr = XOp (XNe, [xrn; int_constant_expr 0]) in - let tcond = rewrite_expr txpr in - let fcond = rewrite_expr fxpr in - let rdefs = [get_rdef xrn] @ (get_all_rdefs tcond) in - let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; txpr; fxpr; tcond; fcond; xtgt] - ~rdefs:rdefs + let xrn_r = rn#to_expr floc in + let xtgt_r = tgt#to_expr floc in + let txpr_r = + TR.tmap (fun xrn -> XOp (XEq, [xrn; zero_constant_expr])) xrn_r in + let fxpr_r = + TR.tmap (fun xrn -> XOp (XNe, [xrn; zero_constant_expr])) xrn_r in + let tcond_r = TR.tmap rewrite_expr txpr_r in + let fcond_r = TR.tmap rewrite_expr fxpr_r in + let rdefs = [get_rdef_r xrn_r] @ (get_all_rdefs_r tcond_r) in + let (tagstring, args) = + mk_instrx_data_r + ~xprs_r:[xrn_r; txpr_r; fxpr_r; tcond_r; fcond_r; xtgt_r] + ~rdefs () in let (tags, args) = (tagstring :: ["TF"], args) in (tags, args) | CompareNegative (c, rn, rm) -> - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xresult = XOp (XPlus, [xrn; xrm]) in - let xresult = rewrite_expr xresult in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs xresult) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xresult_r = + TR.tmap2 (fun xrn xrm -> XOp (XPlus, [xrn; xrm])) xrn_r xrm_r in + let xresult_r = TR.tmap rewrite_expr xresult_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r xresult_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xrm; xresult] - ~rdefs:rdefs - () in + mk_instrx_data_r ~xprs_r:[xrn_r; xrm_r; xresult_r] ~rdefs () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | CountLeadingZeros (c, rd, rm) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let xxrm = rewrite_expr xrm in - let rdefs = [get_rdef xrm] @ (get_all_rdefs xxrm) in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; xxrm] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r xxrm_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; xxrm_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) @@ -1064,16 +1257,18 @@ object (self) (match optpredicate with | Some p -> let p = if inverse then XOp (XLNot, [p]) else p in - let lhs = dstop#to_variable floc in + let lhs_r = dstop#to_variable floc in let rdefs = get_all_rdefs p in let xp = rewrite_expr p in + let uses = [get_def_use_r lhs_r] in + let useshigh = [get_def_use_high_r lhs_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[lhs] - ~xprs:[p; xp] - ~rdefs:rdefs - ~uses:[get_def_use lhs] - ~useshigh:[get_def_use_high lhs] + mk_instrx_data_r + ~vars_r:[lhs_r] + ~xprs_r:[Ok p; Ok xp] + ~rdefs + ~uses + ~useshigh () in ([tagstring], args) | _ -> @@ -1110,106 +1305,159 @@ object (self) | IfThen _ -> ([], []) - | LoadMultipleDecrementAfter (_, _, base, rl, _) -> - let reglhss = rl#to_multiple_variable floc in + | LoadMultipleDecrementAfter (wback, c, base, rl, _) -> + let reglhs_rl = rl#to_multiple_variable floc in let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let (memreads, _) = + let (memreads_r, _) = List.fold_left - (fun (acc, off) _reglhs -> - let memop = arm_reg_deref ~with_offset:off basereg RD in - let memrhs = memop#to_expr floc in - (acc @ [memrhs], off + 4)) ([], 4 -(4 * regcount)) reglhss in - let xtag = - "a:" - ^ (string_repeat "v" regcount) - ^ (string_repeat "x" regcount) - ^ "x" in (* base expression *) - ([xtag], - (List.map xd#index_variable reglhss) - @ (List.map xd#index_xpr memreads) - @ [xd#index_xpr (base#to_expr floc)]) - - | LoadMultipleDecrementBefore (_, _, base, rl, _) -> - let reglhss = rl#to_multiple_variable floc in + (fun (acc, off) _reglhs -> + let memop = arm_reg_deref ~with_offset:off basereg RD in + let memrhs_r = memop#to_expr floc in + (acc @ [memrhs_r], off + 4)) ([], 4 -(4 * regcount)) reglhs_rl in + let rdefs = List.map get_rdef_r (baserhs_r :: memreads_r) in + let uses = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let wbackresults_r = + if wback then + let decrem = int_constant_expr (4 * regcount) in + let baseresult_r = + TR.tmap + (fun baserhs -> XOp (XMinus, [baserhs; decrem])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] + else + [baserhs_r; baserhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(baselhs_r :: reglhs_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ memreads_r) + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | LoadMultipleDecrementBefore (wback, c, base, rl, _) -> + let reglhs_rl = rl#to_multiple_variable floc in let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let (memreads, _) = + let (memreads_r, _) = List.fold_left (fun (acc, off) _reglhs -> let memop = arm_reg_deref ~with_offset:off basereg RD in - let memrhs = memop#to_expr floc in - (acc @ [memrhs], off + 4)) ([], -(4 * regcount)) reglhss in - let xtag = - "a:" - ^ (string_repeat "v" regcount) - ^ (string_repeat "x" regcount) - ^ "x" in (* base expression *) - ([xtag], - (List.map xd#index_variable reglhss) - @ (List.map xd#index_xpr memreads) - @ [xd#index_xpr (base#to_expr floc)]) - - | LoadMultipleIncrementAfter _ when (Option.is_some instr#is_in_aggregate) -> - (match instr#is_in_aggregate with - | Some va -> - let ctxtva = (make_i_location floc#l va)#ci in - ("a:" :: ["subsumed"; ctxtva], []) - | _ -> (["a:"], [])) + let memrhs_r = memop#to_expr floc in + (acc @ [memrhs_r], off + 4)) ([], -(4 * regcount)) reglhs_rl in + let rdefs = List.map get_rdef_r (baserhs_r :: memreads_r) in + let uses = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let wbackresults_r = + if wback then + let decrem = int_constant_expr (4 * regcount) in + let baseresult_r = + TR.tmap + (fun baserhs -> XOp (XMinus, [baserhs; decrem])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] + else + [baserhs_r; baserhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(baselhs_r :: reglhs_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ memreads_r) + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | LoadMultipleIncrementAfter (wback, c, base, rl, _) -> - let reglhss = rl#to_multiple_variable floc in + let lhsvars_rl = rl#to_multiple_variable floc in let basereg = base#get_register in - let baselhs = base#to_variable floc in - let baserhs = base#to_expr floc in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let (memreads, _) = + let (rhsexprs_r, _) = List.fold_left - (fun (acc, off) _reglhs -> + (fun (acc, off) _lhsvar -> let memop = arm_reg_deref ~with_offset:off basereg RD in - let memrhs = memop#to_expr floc in - (acc @ [memrhs], off + 4)) ([], 0) reglhss in - let rdefs = List.map get_rdef (baserhs :: memreads) in - let uses = List.map get_def_use_high (baselhs :: reglhss) in - let useshigh = List.map get_def_use_high (baselhs :: reglhss) in - let wbackresults = - if wback then - let increm = int_constant_expr (4 * regcount) in - let baseresult = XOp (XPlus, [baserhs; increm]) in - let rbaseresult = rewrite_expr baseresult in - [baseresult; rbaseresult] - else - [baserhs; baserhs] in - let (tagstring, args) = - mk_instrx_data - ~vars:(baselhs :: reglhss) - ~xprs:((baserhs :: wbackresults) @ memreads) - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + let memrhs_r = memop#to_expr floc in + (acc @ [memrhs_r], off + 4)) ([], 0) lhsvars_rl in + let xaddrs_r = + List.init + rl#get_register_count + (fun i -> + let xaddr_r = + TR.tmap + (fun baserhs -> XOp (XPlus, [baserhs; int_constant_expr (i + 4)])) + baserhs_r in + TR.tmap rewrite_expr xaddr_r) in + let rdefs = List.map get_rdef_r (baserhs_r :: rhsexprs_r) in + let uses = List.map get_def_use_high_r (baselhs_r :: lhsvars_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: lhsvars_rl) in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(baselhs_r :: lhsvars_rl) + ~xprs_r:(baserhs_r :: (rhsexprs_r @ xaddrs_r)) + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in + let tags = add_optional_subsumption tags in + let (tags, args) = + if wback then + let inc = 4 * regcount in + let xinc = int_constant_expr inc in + let baseresult_r = + TR.tmap (fun baserhs -> XOp (XPlus, [baserhs; xinc])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + add_base_update tags args baselhs_r inc rbaseresult_r + else + (tags, args) in (tags, args) - | LoadMultipleIncrementBefore (_, _, base, rl, _) -> - let reglhss = rl#to_multiple_variable floc in + | LoadMultipleIncrementBefore (wback, c, base, rl, _) -> + let reglhs_rl = rl#to_multiple_variable floc in let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let (memreads, _) = + let (memreads_r, _) = List.fold_left (fun (acc, off) _reglhs -> let memop = arm_reg_deref ~with_offset:off basereg RD in - let memrhs = memop#to_expr floc in - (acc @ [memrhs], off + 4)) ([], 4) reglhss in - let xtag = - "a:" - ^ (string_repeat "v" regcount) - ^ (string_repeat "x" regcount) - ^ "x" in (* base expression *) - ([xtag], - (List.map xd#index_variable reglhss) - @ (List.map xd#index_xpr memreads) - @ [xd#index_xpr (base#to_expr floc)]) + let memrhs_r = memop#to_expr floc in + (acc @ [memrhs_r], off + 4)) ([], 4) reglhs_rl in + let rdefs = List.map get_rdef_r (baserhs_r :: memreads_r) in + let uses = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: reglhs_rl) in + let wbackresults_r = + if wback then + let increm = int_constant_expr (4 * regcount) in + let baseresult_r = + TR.tmap + (fun baserhs -> XOp (XPlus, [baserhs; increm])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] + else + [baserhs_r; baserhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(baselhs_r :: reglhs_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ memreads_r) + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | LoadRegister _ when instr#is_aggregate_anchor -> let iaddr = instr#get_address in @@ -1217,14 +1465,11 @@ object (self) if agg#is_jumptable then let jt = agg#jumptable in let indexregop = jt#index_operand in - let xrn = indexregop#to_expr floc in - let xxrn = rewrite_expr xrn in - let rdefs = (get_rdef xrn) :: (get_all_rdefs xxrn) in + let xrn_r = indexregop#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let rdefs = (get_rdef_r xrn_r) :: (get_all_rdefs_r xxrn_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrn; xxrn] - ~rdefs - () in + mk_instrx_data_r ~xprs_r:[xrn_r; xxrn_r] ~rdefs () in let tags = tagstring :: ["agg-jt"] in let tags = add_subsumption_dependents agg tags in (tags, args) @@ -1236,306 +1481,452 @@ object (self) iaddr#toPretty])) | LoadRegister (c, rt, rn, rm, mem, _) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in let rdefs = - [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let xrmem = rewrite_expr xmem in - let _ = ignore (get_string_reference floc xrmem) in + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let xrmem_r = TR.tmap rewrite_expr xmem_r in let _ = - floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_unknown in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + TR.tfold_default + (fun xrmem -> ignore (get_string_reference floc xrmem)) () xrmem_r in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let tags = add_optional_subsumption tags in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDR")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in (tags, args) | LoadRegisterByte (c, rt, rn, rm, mem, _) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = XOp (XXlsb, [mem#to_expr floc]) in - let xrmem = rewrite_expr xmem in + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in let rdefs = - [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:1 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let tags = add_optional_subsumption tags in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRB")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in + let tags = + match instr#is_in_aggregate with + | Some dw when (get_aggregate dw)#is_pseudo_ldrsb -> + add_subsumption_dependents (get_aggregate dw) tags + | _ -> tags in (tags, args) | LoadRegisterDual (c, rt, rt2, rn, rm, mem, mem2) -> - let vrt = rt#to_variable floc in - let vrt2 = rt2#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let vmem = mem#to_variable floc in - let vmem2 = mem#to_variable floc in - let xmem = mem#to_expr floc in - let xrmem = rewrite_expr xmem in - let xmem2 = mem2#to_expr floc in - let xrmem2 = rewrite_expr xmem2 in - let xaddr1 = mem#to_address floc in - let xaddr2 = mem#to_address floc in + let vrt_r = rt#to_variable floc in + let vrt2_r = rt2#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let vmem_r = mem#to_variable floc in + let vmem2_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let xmem2_r = mem2#to_expr floc in + let xrmem2_r = TR.tmap rewrite_expr xmem2_r in + let xaddr1_r = mem#to_address floc in + let xaddr2_r = mem#to_address floc in let rdefs = [ - get_rdef xrn; - get_rdef xrm; - get_rdef_memvar vmem; - get_rdef_memvar vmem2] in - let uses = [get_def_use vrt; get_def_use vrt2] in - let useshigh = [get_def_use_high vrt; get_def_use_high vrt2] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vrt2; vmem; vmem2] - ~xprs:[xrn; xrm; xmem; xrmem; xmem2; xrmem2; xaddr1; xaddr2] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + get_rdef_r xrn_r; + get_rdef_r xrm_r; + get_rdef_memvar_r vmem_r; + get_rdef_memvar_r vmem2_r] in + let uses = [get_def_use_r vrt_r; get_def_use_r vrt2_r] in + let useshigh = [get_def_use_high_r vrt_r; get_def_use_high_r vrt2_r] in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xaddr1_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xaddr2_r + ~var_r:vmem2_r + ~size:4 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vrt2_r; vmem_r; vmem2_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xmem2_r; + xrmem2_r; xaddr1_r; xaddr2_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRB")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in (tags, args) | LoadRegisterExclusive (c, rt, rn, rm, mem) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in let rdefs = - [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let xrmem = rewrite_expr xmem in - let _ = ignore (get_string_reference floc xrmem) in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let _ = + TR.tfold_default + (fun xrmem -> ignore (get_string_reference floc xrmem)) () xrmem_r in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xaddr_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDREX")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in (tags, args) | LoadRegisterHalfword (c, rt, rn, rm, mem, _) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in - let xrmem = rewrite_expr xmem in + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in let rdefs = - [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let _ = + floc#memrecorder#record_load_r + ~signed:false + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:2 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRH")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in + let tags = + match instr#is_in_aggregate with + | Some dw when (get_aggregate dw)#is_pseudo_ldrsh -> + add_subsumption_dependents (get_aggregate dw) tags + | _ -> tags in (tags, args) | LoadRegisterSignedByte (c, rt, rn, rm, mem, _) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in - let xrmem = rewrite_expr xmem in + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r= mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in let rdefs = - [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let _ = + floc#memrecorder#record_load_r + ~signed:true + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:1 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRSB")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in (tags, args) | LoadRegisterSignedHalfword (c, rt, rn, rm, mem, _) -> - let vrt = rt#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in - let xrmem = rewrite_expr xmem in - let rdefs = [get_rdef xrn; get_rdef xrm; get_rdef_memvar vmem] in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrm; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + let vrt_r = rt#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_memvar_r vmem_r] in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let _ = + floc#memrecorder#record_load_r + ~signed:true + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:2 + ~vtype:t_unknown in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrm_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRSH")) - (fun (inc, xaddr) -> add_base_update tags args vrn inc xaddr) - (tags, args) - addr_r + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else (tags, args) in (tags, args) | LogicalShiftLeft (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XLsl, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XLsl, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in let tags = add_optional_subsumption tags in (tags, args) | LogicalShiftRight (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XLsr, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XLsr, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) + | Move _ when instr#is_aggregate_anchor -> + let finfo = floc#f in + let ctxtiaddr = floc#l#ci in + if finfo#has_associated_cc_setter ctxtiaddr then + let testiaddr = finfo#get_associated_cc_setter ctxtiaddr in + let testloc = ctxt_string_to_location faddr testiaddr in + let testaddr = testloc#i in + let testinstr = + fail_tvalue + (trerror_record + (LBLOCK [ + STR "FnDictionary: predicate assignment"; floc#ia#toPretty])) + (get_arm_assembly_instruction testaddr) in + let agg = get_aggregate floc#ia in + (match agg#kind with + | ARMPredicateAssignment (inverse, dstop) -> + let (_, optpredicate, _) = + arm_conditional_expr + ~condopc:instr#get_opcode + ~testopc:testinstr#get_opcode + ~condloc:floc#l + ~testloc:testloc in + let (tags, args) = + (match optpredicate with + | Some p -> + let p = if inverse then XOp (XLNot, [p]) else p in + let lhs_r = dstop#to_variable floc in + let rdefs = get_all_rdefs p in + let xp = rewrite_expr p in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[lhs_r] + ~xprs_r:[Ok p; Ok xp] + ~rdefs + ~uses:[get_def_use_r lhs_r] + ~useshigh:[get_def_use_high_r lhs_r] + () in + ([tagstring], args) + | _ -> + ([], [])) in + let dependents = + List.map (fun d -> + (make_i_location floc#l d#get_address)#ci) agg#instrs in + let tags = tags @ ["subsumes"] @ dependents in + (tags, args) + | _ -> + ([], [])) + else + ([], []) + | Move _ when (Option.is_some instr#is_in_aggregate) -> (match instr#is_in_aggregate with | Some va -> @@ -1548,326 +1939,474 @@ object (self) (["nop"], []) | Move (_, c, rd, rm, _, _) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let result = rewrite_expr ?restrict:(Some 4) xrm in - let rdefs = (get_rdef xrm) :: (get_all_rdefs result) in - let _ = ignore (get_string_reference floc result) in + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let result_r = TR.tmap (rewrite_expr ?restrict:(Some 4)) xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r result_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let _ = + TR.tfold_default + (fun result -> ignore (get_string_reference floc result)) + () result_r in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; result] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; result_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | MoveRegisterCoprocessor (_, _, _, dst, _, _, _) -> - let vdst = dst#to_variable floc in - (["a:v"], [xd#index_variable vdst]) + | MoveRegisterCoprocessor (c, _, _, rt, _, _, _) -> + let vrt_r = rt#to_variable floc in + let (tagstring, args) = mk_instrx_data_r ~vars_r:[vrt_r] () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) - | MoveToCoprocessor (_, _, _, rt, _, _, _) -> - let src = rt#to_expr floc in - let rsrc = rewrite_expr src in - (["a:xx"], [xd#index_xpr src; xd#index_xpr rsrc]) + | MoveToCoprocessor (c, _, _, rt, _, _, _) -> + let xrt_r = rt#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let (tagstring, args) = mk_instrx_data_r ~xprs_r:[xrt_r; xxrt_r] () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | MoveTop (c, rd, imm) -> - let vrd = rd#to_variable floc in - let ximm = imm#to_expr floc in - let xrd = rd#to_expr floc in - let ximm16 = XOp (XMult, [ximm; int_constant_expr e16]) in - let xrdm16 = XOp (XXlsh, [xrd]) in - let result = XOp (XPlus, [xrdm16; ximm16]) in - let rresult = rewrite_expr result in - let _ = ignore (get_string_reference floc rresult) in - let rdefs = [get_rdef xrd] in - let uses = get_def_use vrd in - let useshigh = get_def_use_high vrd in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[ximm; xrd; xrdm16; result; rresult] - ~rdefs:rdefs - ~uses:[uses] - ~useshigh:[useshigh] + let vrd_r = rd#to_variable floc in + let ximm_r = imm#to_expr floc in + let xrd_r = rd#to_expr floc in + let ximm16_r = + TR.tmap (fun ximm -> XOp (XMult, [ximm; e16_c])) ximm_r in + let xrdm16_r = TR.tmap (fun xrd -> XOp (XXlsh, [xrd])) xrd_r in + let result_r = + TR.tmap2 + (fun xrdm16 ximm16 -> XOp (XPlus, [xrdm16; ximm16])) + xrdm16_r ximm16_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let _ = + TR.tfold_default + (fun r -> ignore (get_string_reference floc r)) () rresult_r in + let rdefs = [get_rdef_r xrd_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[ximm_r; xrd_r; xrdm16_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | MoveTwoRegisterCoprocessor (_, _, _, rt, rt2, _) -> - let v1 = rt#to_variable floc in - let v2 = rt2#to_variable floc in - (["a:vv"], [xd#index_variable v1; xd#index_variable v2]) + | MoveTwoRegisterCoprocessor (c, _, _, rt, rt2, _) -> + let vrt1_r = rt#to_variable floc in + let vrt2_r = rt2#to_variable floc in + let (tagstring, args) = mk_instrx_data_r ~vars_r:[vrt1_r; vrt2_r] () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | Multiply(_, c, rd, rn, rm) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XMult, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] - () in - let (tags, args) = add_optional_instr_condition tagstring args c in - (tags, args) - - | MultiplyAccumulate (_, _, rd, rn, rm, ra) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xra = ra#to_expr floc in - let xprd = XOp (XMult, [xrn; xrm]) in - let xrprd = rewrite_expr xprd in - let xrhs = XOp (XPlus, [xprd; xra]) in - let xrrhs = rewrite_expr xrhs in - (["a:vxxxxxxx"], - [xd#index_variable vrd; - xd#index_xpr xrn; - xd#index_xpr xrm; - xd#index_xpr xra; - xd#index_xpr xprd; - xd#index_xpr xrprd; - xd#index_xpr xrhs; - xd#index_xpr xrrhs]) - - | MultiplySubtract (_, rd, rn, rm, ra) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xra = ra#to_expr floc in - let xprod = XOp (XMult, [xrn; xrm]) in - let xxprod = rewrite_expr xprod in - let xdiff = XOp (XMinus, [xra; xprod]) in - let xxdiff = rewrite_expr xdiff in - (["a:vxxxxxxx"], - [xd#index_variable vrd; - xd#index_xpr xrn; - xd#index_xpr xrm; - xd#index_xpr xra; - xd#index_xpr xprod; - xd#index_xpr xxprod; - xd#index_xpr xdiff; - xd#index_xpr xxdiff]) + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | MultiplyAccumulate (_, c, rd, rn, rm, ra) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xra_r = ra#to_expr floc in + let xprd_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let xrprd_r = TR.tmap rewrite_expr xprd_r in + let xrhs_r = + TR.tmap2 (fun xprd xra -> XOp (XPlus, [xprd; xra])) xprd_r xra_r in + let xrrhs_r = TR.tmap rewrite_expr xrhs_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_r xra_r] + @ (get_all_rdefs_r xrrhs_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; xra_r; xprd_r; xrprd_r; xrhs_r; xrrhs_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | MultiplySubtract (c, rd, rn, rm, ra) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xra_r = ra#to_expr floc in + let xprod_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let xxprod_r = TR.tmap rewrite_expr xprod_r in + let xdiff_r = + TR.tmap2 (fun xra xprod -> XOp (XMinus, [xra; xprod])) xra_r xprod_r in + let xxdiff_r = TR.tmap rewrite_expr xdiff_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_r xra_r] + @ (get_all_rdefs_r xxdiff_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; xra_r; xprod_r; xxprod_r; xdiff_r; xxdiff_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | Pop (c, sp, rl, _) -> - let splhs = sp#to_variable floc in - let sprhs = sp#to_expr floc in + let splhs_r = sp#to_variable floc in + let sprhs_r = sp#to_expr floc in let regcount = rl#get_register_count in - let spresult = XOp (XPlus, [sprhs; int_constant_expr (regcount * 4)]) in - let rspresult = rewrite_expr spresult in - let lhsvars = + let spresult_r = + TR.tmap + (fun sprhs -> XOp (XPlus, [sprhs; int_constant_expr (regcount * 4)])) + sprhs_r in + let rspresult_r = TR.tmap rewrite_expr spresult_r in + let lhsvars_r = List.map (fun (op: arm_operand_int) -> op#to_variable floc) rl#get_register_op_list in let rhsops = List.map (fun offset -> arm_sp_deref ~with_offset:offset RD) (List.init rl#get_register_count (fun i -> 4 * i)) in - let rhsexprs = + let rhsexprs_r = List.map (fun (x: arm_operand_int) -> x#to_expr floc) rhsops in - let xaddrs = + let xaddrs_r = List.init rl#get_register_count (fun i -> - let xaddr = XOp (XPlus, [sprhs; int_constant_expr (i * 4)]) in - rewrite_expr xaddr) in - let rrhsexprs = List.map rewrite_expr rhsexprs in - let (r0rdefs, xr0) = + let xaddr_r = + TR.tmap + (fun sprhs -> XOp (XPlus, [sprhs; int_constant_expr (i * 4)])) + sprhs_r in + TR.tmap rewrite_expr xaddr_r) in + let rrhsexprs_r = List.map (TR.tmap rewrite_expr) rhsexprs_r in + let rdefs = List.map get_rdef_r (sprhs_r :: rhsexprs_r) in + let uses = List.map get_def_use_r (splhs_r :: lhsvars_r) in + let useshigh = List.map get_def_use_high_r (splhs_r :: lhsvars_r) in + let xprs_r = + (sprhs_r :: spresult_r :: rspresult_r :: rrhsexprs_r) @ xaddrs_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(splhs_r :: lhsvars_r) + ~xprs_r + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = if rl#includes_pc then let r0_op = arm_register_op AR0 RD in - let xr0 = r0_op#to_expr floc in - let xxr0 = rewrite_expr xr0 in - ([get_rdef xr0] @ (get_all_rdefs xxr0), Some xxr0) + let xr0_r = r0_op#to_expr floc in + let xxr0_r = TR.tmap rewrite_expr xr0_r in + add_return_value tags args xr0_r xxr0_r else - ([], None) in - let rdefs = List.map get_rdef (sprhs :: rhsexprs) in - let uses = List.map get_def_use (splhs :: lhsvars) in - let useshigh = List.map get_def_use_high (splhs :: lhsvars) in - let xprs = - (sprhs :: spresult :: rspresult :: rrhsexprs) - @ xaddrs - @ (match xr0 with Some x -> [x] | _ -> []) in - let (tagstring, args) = - mk_instrx_data - ~vars:(splhs :: lhsvars) - ~xprs - ~rdefs:(rdefs @ r0rdefs) - ~uses:uses - ~useshigh:useshigh - () in - let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) in (tags, args) - | PreloadData (_, _, base, mem) -> - let xbase = base#to_expr floc in - let xmem = mem#to_expr floc in - (["a:xx"], [xd#index_xpr xbase; xd#index_xpr xmem]) + | PreloadData (_, c, base, mem) -> + let xbase_r = base#to_expr floc in + let xmem_r = mem#to_expr floc in + let (tagstring, args) = mk_instrx_data_r ~xprs_r:[xbase_r; xmem_r] () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | Push (c, sp, rl, _) -> - let splhs = sp#to_variable floc in - let sprhs = sp#to_expr floc in - let rhsexprs = + let splhs_r = sp#to_variable floc in + let sprhs_r = sp#to_expr floc in + let rhsexprs_rl = List.map (fun (op: arm_operand_int) -> op#to_expr floc) rl#get_register_op_list in - let rrhsexprs = List.map rewrite_expr rhsexprs in - let regcount = List.length rhsexprs in + let rrhsexprs_rl = List.map (TR.tmap rewrite_expr) rhsexprs_rl in + let regcount = rl#get_register_count in let lhsops = List.map (fun offset -> arm_sp_deref ~with_offset:offset WR) - (List.init - rl#get_register_count (fun i -> ((-4*regcount) + (4*i)))) in - let lhsvars = List.map (fun v -> v#to_variable floc) lhsops in - let rdefs = List.map get_rdef (sprhs :: rhsexprs) in - let uses = List.map get_def_use (splhs :: lhsvars) in - let useshigh = List.map get_def_use_high (splhs :: lhsvars) in - let spresult = XOp (XMinus, [sprhs; int_constant_expr (regcount * 4)]) in - let rspresult = rewrite_expr spresult in + (List.init regcount (fun i -> ((- (4 * regcount)) + (4 * i)))) in + let lhsvars_rl = List.map (fun v -> v#to_variable floc) lhsops in + let rdefs = List.map get_rdef_r (sprhs_r :: rhsexprs_rl) in + let uses = List.map get_def_use_r (splhs_r :: lhsvars_rl) in + let useshigh = List.map get_def_use_high_r (splhs_r :: lhsvars_rl) in + let spresult_r = + TR.tmap + (fun sprhs -> + XOp (XMinus, [sprhs; int_constant_expr (regcount * 4)])) + sprhs_r in + let rspresult_r = TR.tmap rewrite_expr spresult_r in let xaddrs = List.init - rl#get_register_count + regcount (fun i -> - let xaddr = XOp (XPlus, [rspresult; int_constant_expr (i * 4)]) in - rewrite_expr xaddr) in - let (tagstring, args) = - mk_instrx_data - ~vars:(splhs :: lhsvars) - ~xprs:((sprhs :: spresult :: rspresult :: rrhsexprs) @ xaddrs) - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + let xaddr_r = + TR.tmap + (fun rspresult -> + XOp (XPlus, [rspresult; int_constant_expr (i * 4)])) + rspresult_r in + TR.tmap rewrite_expr xaddr_r) in + let xprs_r = + (sprhs_r :: spresult_r :: rspresult_r :: rrhsexprs_rl) @ xaddrs in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(splhs_r :: lhsvars_rl) + ~xprs_r + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | ReverseSubtract (_, c, rd, rn, rm, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XMinus, [xrm; xrn]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in - let uses = [get_def_use vrd] in - let useshigh = [get_def_use_high vrd] in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrm; xrn])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh - () in - let (tags, args) = add_optional_instr_condition tagstring args c in - (tags, args) - - | SignedBitFieldExtract (_, rd, rn) -> - let lhs = rd#to_variable floc in - let rhs = rn#to_expr floc in - let rrhs = rewrite_expr rhs in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr rhs; xd#index_xpr rrhs]) - - | SelectBytes (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr xrn; xd#index_xpr xrm]) - - | SignedDivide (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XDiv, [rhs1; rhs2]) in - let rresult = rewrite_expr result in - (["a:vxxxx"], - [xd#index_variable lhs; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr result; - xd#index_xpr rresult]) - - | SignedExtendByte (_, rd, rm, _) -> - let lhs = rd#to_variable floc in - let rhs = rm#to_expr floc in - let xrhs = rewrite_expr rhs in - (["a:vxx"], [xd#index_variable lhs; xd#index_xpr rhs; xd#index_xpr xrhs]) - - | SignedExtendHalfword (_, rd, rm, _) -> - let lhs = rd#to_variable floc in - let rhs = rm#to_expr floc in - let xrhs = rewrite_expr rhs in - (["a:vxx"], [xd#index_variable lhs; xd#index_xpr rhs; xd#index_xpr xrhs]) - - | SignedMostSignificantWordMultiply (_, rd, rn, rm, _) -> - let lhs = rd#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMult, [rhs1; rhs2]) in - let result = XOp (XDiv, [result; int_constant_expr e32]) in - let rresult = rewrite_expr result in - (["a:vxxxx"], - [xd#index_variable lhs; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr result; - xd#index_xpr rresult]) - - | SignedMostSignificantWordMultiplyAccumulate (_, rd, rn, rm, ra, _) -> - let lhs = rd#to_variable floc in - let lhsra = ra#to_variable floc in - let rhsra = ra#to_expr floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMult, [rhs1; rhs2]) in - let result = XOp (XDiv, [result; int_constant_expr e32]) in - let rresult = rewrite_expr result in - (["a:vvxxxxx"], - [xd#index_variable lhs; - xd#index_variable lhsra; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr rhsra; - xd#index_xpr result; - xd#index_xpr rresult]) - - | SignedMultiplyLong (_, _, rdlo, rdhi, rn, rm) -> - let lhslo = rdlo#to_variable floc in - let lhshi = rdhi#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMult, [rhs1; rhs2]) in - let rresult = rewrite_expr result in - (["a:vvxxxx"], - [xd#index_variable lhslo; - xd#index_variable lhshi; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr result; - xd#index_xpr rresult]) + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SelectBytes (c, rd, rn, rm) -> + let lhs_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = [get_def_use_r lhs_r] in + let useshigh = [get_def_use_high_r lhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[lhs_r] + ~xprs_r:[xrn_r; xrm_r; xxrn_r; xxrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedBitFieldExtract (c, rd, rn) -> + let lhs_r = rd#to_variable floc in + let rhs_r = rn#to_expr floc in + let rrhs_r = TR.tmap rewrite_expr rhs_r in + let rdefs = [get_rdef_r rhs_r] in + let uses = [get_def_use_r lhs_r] in + let useshigh = [get_def_use_high_r lhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[lhs_r] + ~xprs_r:[rhs_r; rrhs_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedDivide (c, rd, rn, rm) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XDiv, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedExtendByte (c, rd, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r xxrm_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; xxrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedExtendHalfword (c, rd, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r xxrm_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; xxrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedMostSignificantWordMultiply (c, rd, rn, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let result_r = + TR.tmap (fun r -> XOp (XDiv, [r; e32_c])) result_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedMostSignificantWordMultiplyAccumulate (c, rd, rn, rm, ra, _) -> + let vrd_r = rd#to_variable floc in + let xra_r = ra#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let xra32_r = TR.tmap (fun xra -> XOp (XMult, [xra; e32_c])) xra_r in + let result_r = + TR.tmap2 (fun r a -> XOp (XPlus, [r; a])) result_r xra32_r in + let result_r = TR.tmap (fun r -> XOp (XDiv, [r; e32_c])) result_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xra_r; get_rdef_r xrn_r; get_rdef_r xrm_r] + @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; xra_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | SignedMultiplyLong (_, c, rdlo, rdhi, rn, rm) -> + let vlo_r = rdlo#to_variable floc in + let vhi_r = rdhi#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let result_r = TR.tmap rewrite_expr result_r in + let loresult_r = TR.tmap (fun r -> XOp (XMod, [r; e32_c])) result_r in + let hiresult_r = TR.tmap (fun r -> XOp (XDiv, [r; e32_c])) result_r in + let loresultr_r = TR.tmap rewrite_expr loresult_r in + let hiresultr_r = TR.tmap rewrite_expr hiresult_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r result_r) in + let uses = [get_def_use_r vlo_r; get_def_use_r vhi_r] in + let useshigh = [get_def_use_high_r vlo_r; get_def_use_high_r vhi_r] in + let xprs_r = + [xrn_r; xrm_r; loresult_r; hiresult_r; loresultr_r; hiresultr_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vlo_r; vhi_r] + ~xprs_r + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | SignedMultiplyWordB (c, rd, rn, rm) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xe16 = int_constant_expr BCHDoubleword.e16 in - let result = XOp (XMult, [xrn; XOp (XMod, [xrm; xe16])]) in - let xxrn = rewrite_expr xrn in - let xxrm = rewrite_expr xrm in - let rresult = rewrite_expr ?restrict:(Some 4) result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in - let uses = [get_def_use vrd] in - let useshigh = [get_def_use_high vrd] in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 + (fun xrn xrm -> XOp (XMult, [xrn; XOp (XMod, [xrm; e16_c])])) + xrn_r xrm_r in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rresult_r = TR.tmap (rewrite_expr ?restrict:(Some 4)) result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult; xxrn; xxrm] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r; xxrn_r; xxrm_r] ~rdefs ~uses ~useshigh @@ -1876,21 +2415,61 @@ object (self) (tags, args) | SignedMultiplyWordT (c, rd, rn, rm) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xe16 = int_constant_expr BCHDoubleword.e16 in - let result = XOp (XMult, [xrn; XOp (XShiftrt, [xrm; xe16])]) in - let xxrn = rewrite_expr xrn in - let xxrm = rewrite_expr xrm in - let rresult = rewrite_expr ?restrict:(Some 4) result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in - let uses = [get_def_use vrd] in - let useshigh = [get_def_use_high vrd] in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 + (fun xrn xrm -> XOp (XMult, [xrn; XOp (XShiftrt, [xrm; e16_c])])) + xrn_r xrm_r in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rresult_r = TR.tmap (rewrite_expr ?restrict:(Some 4)) result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult; xxrn; xxrm] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r; xxrn_r; xxrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | StoreMultipleDecrementAfter (wback, c, base, rl, _) -> + let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in + let regcount = rl#get_register_count in + let rhss_rl = rl#to_multiple_expr floc in + let rrhss_rl = List.map (TR.tmap rewrite_expr) rhss_rl in + let (memlhss_rl, _) = + List.fold_left + (fun (acc, off) _reg -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + let memlhs_r = memop#to_variable floc in + (acc @ [memlhs_r], off + 4)) + ([], 4 - (4 * regcount)) rl#get_register_op_list in + let rdefs = List.map get_rdef_r (baserhs_r :: rrhss_rl) in + let uses = List.map get_def_use_r (baselhs_r :: memlhss_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: memlhss_rl) in + let wbackresults_r = + if wback then + let decrem = int_constant_expr (4 * regcount) in + let baseresult_r = + TR.tmap (fun baserhs -> XOp (XMinus, [baserhs; decrem])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] + else + [baserhs_r; baserhs_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(baselhs_r :: memlhss_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ rrhss_rl) ~rdefs ~uses ~useshigh @@ -1900,42 +2479,37 @@ object (self) | StoreMultipleDecrementBefore (wback, c, base, rl, _) -> let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let baselhs = base#to_variable floc in - let baserhs = base#to_expr floc in - let rhss = rl#to_multiple_expr floc in - let rrhss = List.map rewrite_expr rhss in - let (memlhss, _) = + let rhss_rl = rl#to_multiple_expr floc in + let rrhss_rl = List.map (TR.tmap rewrite_expr) rhss_rl in + let (memlhss_rl, _) = List.fold_left (fun (acc, off) _reg -> let memop = arm_reg_deref ~with_offset:off basereg WR in - let memlhs = memop#to_variable floc in - let memop1 = arm_reg_deref ~with_offset:(off+1) basereg WR in - let memlhs1 = memop1#to_variable floc in - let memop2 = arm_reg_deref ~with_offset:(off+2) basereg WR in - let memlhs2 = memop2#to_variable floc in - let memop3 = arm_reg_deref ~with_offset:(off+3) basereg WR in - let memlhs3 = memop3#to_variable floc in - (acc @ [memlhs; memlhs1; memlhs2; memlhs3], off + 4)) - ([], -(4 * regcount)) rl#get_register_op_list in - let rdefs = List.map get_rdef (baserhs :: rhss) in - let uses = List.map get_def_use_high (baselhs :: memlhss) in - let useshigh = List.map get_def_use_high (baselhs :: memlhss) in - let wbackresults = + let memlhs_r = memop#to_variable floc in + (acc @ [memlhs_r], off + 4)) + ([], - (4 * regcount)) rl#get_register_op_list in + let rdefs = List.map get_rdef_r (baserhs_r :: rrhss_rl) in + let uses = List.map get_def_use_r (baselhs_r :: memlhss_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: memlhss_rl) in + let wbackresults_r = if wback then let decrem = int_constant_expr (4 * regcount) in - let baseresult = XOp (XMinus, [baserhs; decrem]) in - let rbaseresult = rewrite_expr baseresult in - [baseresult; rbaseresult] + let baseresult_r = + TR.tmap (fun baserhs -> XOp (XMinus, [baserhs; decrem])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] else - [baserhs; baserhs] in + [baserhs_r; baserhs_r] in let (tagstring, args) = - mk_instrx_data - ~vars:(baselhs :: memlhss) - ~xprs:((baserhs :: wbackresults) @ rhss @ rrhss) - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + mk_instrx_data_r + ~vars_r:(baselhs_r :: memlhss_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ rrhss_rl) + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) @@ -1949,26 +2523,26 @@ object (self) let dstop = seq#dstreg in let size = seq#registers#get_register_count * 4 in let srcfloc = get_floc (make_i_location floc#l (iaddr#add_int (-4))) in - let xsrc = srcop#to_expr srcfloc in - let xdst = dstop#to_expr floc in - let xxsrc = rewrite_floc_expr srcfloc xsrc in - let xxdst = rewrite_expr ?restrict:(Some 4) xdst in - let xxdst = - let optmemvar = floc#decompose_memvar_address xxdst in - match optmemvar with - | Some (memref, memoff) -> - let memvar = - floc#f#env#mk_index_offset_memory_variable memref memoff in - XOp ((Xf "addressofvar"), [XVar memvar]) - | _ -> xxdst in - let rdefs = [(get_rdef xsrc); (get_rdef xdst)] in + let xsrc_r = srcop#to_expr srcfloc in + let xdst_r = dstop#to_expr floc in + let xxsrc_r = TR.tmap (rewrite_floc_expr srcfloc) xsrc_r in + let xxdst_r = TR.tmap (rewrite_expr ?restrict:(Some 4)) xdst_r in + let xxdst_r = + TR.tmap + (fun v -> XOp ((Xf "addressofvar"), [(XVar v)])) + (TR.tbind (fun x -> floc#get_var_at_address x) xxdst_r) in + let rdefs = [(get_rdef_r xsrc_r); (get_rdef_r xdst_r)] in let _ = - match get_string_reference srcfloc xxsrc with - | Some _ -> register_function_prototype "strcpy" - | _ -> register_function_prototype "memcpy" in + TR.tfold_default + (fun xxsrc -> + match get_string_reference srcfloc xxsrc with + | Some _ -> register_function_prototype "strcpy" + | _ -> register_function_prototype "memcpy") + () + xxsrc_r in let (tagstring, args) = - mk_instrx_data - ~xprs:[xdst; xsrc; xxdst; xxsrc] + mk_instrx_data_r + ~xprs_r:[xdst_r; xsrc_r; xxdst_r; xxsrc_r] ~integers:[size] ~rdefs () in @@ -1984,85 +2558,69 @@ object (self) | StoreMultipleIncrementAfter (wback, c, base, rl, _, _) -> let basereg = base#get_register in - let baselhs = base#to_variable floc in - let baserhs = base#to_expr floc in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let rhss = rl#to_multiple_expr floc in - let rrhss = List.map rewrite_expr rhss in - let (memlhss, _) = + let rhss_rl = rl#to_multiple_expr floc in + let rrhss_rl = List.map (TR.tmap rewrite_expr) rhss_rl in + let (memlhss_rl, _) = List.fold_left (fun (acc, off) _reg -> let memop = arm_reg_deref ~with_offset:off basereg WR in - let memlhs = memop#to_variable floc in - (acc @ [memlhs], off + 4)) ([], 0) rl#get_register_op_list in - let rdefs = List.map get_rdef (baserhs :: rrhss) in - let uses = List.map get_def_use (baselhs :: memlhss) in - let useshigh = List.map get_def_use_high (baselhs :: memlhss) in - let wbackresults = + let memlhs_r = memop#to_variable floc in + (acc @ [memlhs_r], off + 4)) ([], 0) rl#get_register_op_list in + let rdefs = List.map get_rdef_r (baserhs_r :: rrhss_rl) in + let uses = List.map get_def_use_r (baselhs_r :: memlhss_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: memlhss_rl) in + let wbackresults_r = if wback then let increm = int_constant_expr (4 * regcount) in - let baseresult = XOp (XPlus, [baserhs; increm]) in - let rbaseresult = rewrite_expr baseresult in - [baseresult; rbaseresult] + let baseresult_r = + TR.tmap (fun baserhs -> XOp (XPlus, [baserhs; increm])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] else - [baserhs; baserhs] in + [baserhs_r; baserhs_r] in let (tagstring, args) = - mk_instrx_data - ~vars:(baselhs :: memlhss) - ~xprs:((baserhs :: wbackresults) @ rrhss) - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + mk_instrx_data_r + ~vars_r:(baselhs_r :: memlhss_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ rrhss_rl) + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | StoreMultipleIncrementBefore (_, _, base, rl, _) -> + | StoreMultipleIncrementBefore (wback, c, base, rl, _) -> let basereg = base#get_register in + let baselhs_r = base#to_variable floc in + let baserhs_r = base#to_expr floc in let regcount = rl#get_register_count in - let rhss = rl#to_multiple_expr floc in - let rrhss = List.map rewrite_expr rhss in - let (memlhss, _) = + let rhss_rl = rl#to_multiple_expr floc in + let rrhss_rl = List.map (TR.tmap rewrite_expr) rhss_rl in + let (memlhss_rl, _) = List.fold_left - (fun (acc, off) _reg -> - let memop = arm_reg_deref ~with_offset:off basereg WR in - let memlhs = memop#to_variable floc in - (acc @ [memlhs], off + 4)) ([], 4) rl#get_register_op_list in - let xtag = - "a:" - ^ (string_repeat "v" regcount) - ^ (string_repeat "x" regcount) - ^ "x" in (* base expression *) - ([xtag], - (List.map xd#index_variable memlhss) - @ (List.map xd#index_xpr rrhss) - @ [xd#index_xpr (base#to_expr floc)]) - - | StoreRegister (c, rt, rn, rm, mem, _) -> - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xrt = rt#to_expr floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xxrt = rewrite_expr xrt in - let rdefs = [get_rdef xrn; get_rdef xrm; get_rdef xrt; get_rdef xxrt] in - let uses = [get_def_use vmem] in - let useshigh = [get_def_use_high vmem] in - let (vars, uses, useshigh) = - if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - ([vmem; vrn], - uses @ [get_def_use vrn], - useshigh @ [get_def_use_high vrn]) + (fun (acc, off) _reg -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + let memlhs_r = memop#to_variable floc in + (acc @ [memlhs_r], off + 4)) ([], 4) rl#get_register_op_list in + let rdefs = List.map get_rdef_r (baserhs_r :: rrhss_rl) in + let uses = List.map get_def_use_r (baselhs_r :: memlhss_rl) in + let useshigh = List.map get_def_use_high_r (baselhs_r :: memlhss_rl) in + let wbackresults_r = + if wback then + let increm = int_constant_expr (4 * regcount) in + let baseresult_r = + TR.tmap (fun baserhs -> XOp (XPlus, [baserhs; increm])) baserhs_r in + let rbaseresult_r = TR.tmap rewrite_expr baseresult_r in + [baseresult_r; rbaseresult_r] else - ([vmem], uses, useshigh) in - let _ = - floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_unknown ~xpr:xxrt in + [baserhs_r; baserhs_r] in let (tagstring, args) = - mk_instrx_data - ~vars - ~xprs:[xrn; xrm; xrt; xxrt; xaddr] + mk_instrx_data_r + ~vars_r:(baselhs_r :: memlhss_rl) + ~xprs_r:((baserhs_r :: wbackresults_r) @ rrhss_rl) ~rdefs ~uses ~useshigh @@ -2070,225 +2628,343 @@ object (self) let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | StoreRegisterByte (c, rt, rn, rm, mem, _) -> - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xrt = XOp (XXlsb, [rt#to_expr floc]) in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xxrt = rewrite_expr xrt in - let rdefs = [get_rdef xrn; get_rdef xrm; get_rdef xrt; get_rdef xxrt] in - let uses = [get_def_use vmem] in - let useshigh = [get_def_use_high vmem] in - let (vars, uses, useshigh) = + | StoreRegister (c, rt, rn, rm, mem, _) -> + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xrt_r = rt#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let rdefs = + [get_rdef_r xrn_r; + get_rdef_r xrm_r; + get_rdef_r xrt_r; + get_rdef_r xxrt_r] in + let uses = [get_def_use_r vmem_r] in + let useshigh = [get_def_use_high_r vmem_r] in + let xprs_r = [xrn_r; xrm_r; xrt_r; xxrt_r; xaddr_r] in + let vars_r = [vmem_r] in + let _ = + floc#memrecorder#record_store_r + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown + ~xpr_r:xxrt_r in + let (tagstring, args) = + mk_instrx_data_r ~vars_r ~xprs_r ~rdefs ~uses ~useshigh () in + let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - ([vmem; vrn], - uses @ [get_def_use vrn], - useshigh @ [get_def_use_high vrn]) + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) else - ([vmem], uses, useshigh) in + (tags, args) in + (tags, args) + + | StoreRegisterByte (c, rt, rn, rm, mem, _) -> + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xrt_r = rt#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let rdefs = + [get_rdef_r xrn_r; + get_rdef_r xrm_r; + get_rdef_r xrt_r; + get_rdef_r xxrt_r] in + let uses = [get_def_use_r vmem_r] in + let useshigh = [get_def_use_high_r vmem_r] in let _ = - floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:1 ~vtype:t_unknown ~xpr:xxrt in - let (tagstring, args) = - mk_instrx_data - ~vars - ~xprs:[xrn; xrm; xrt; xxrt; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + floc#memrecorder#record_store_r + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:1 + ~vtype:t_unknown + ~xpr_r:xxrt_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vmem_r] + ~xprs_r:[xrn_r; xrm_r; xrt_r; xxrt_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = + if mem#is_offset_address_writeback then + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) + else + (tags, args) in (tags, args) | StoreRegisterDual (c, rt, rt2, rn, rm, mem, mem2) -> - let vmem = mem#to_variable floc in - let vmem2 = mem2#to_variable floc in - let xaddr1 = mem#to_address floc in - let xaddr2 = mem2#to_address floc in - let xrt = rt#to_expr floc in - let xxrt = rewrite_expr xrt in - let xrt2 = rt2#to_expr floc in - let xxrt2 = rewrite_expr xrt2 in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vmem_r = mem#to_variable floc in + let vmem2_r = mem2#to_variable floc in + let xaddr1_r = mem#to_address floc in + let xaddr2_r = mem2#to_address floc in + let xrt_r = rt#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let xrt2_r = rt2#to_expr floc in + let xxrt2_r = TR.tmap rewrite_expr xrt2_r in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xprs_r = + [xrn_r; xrm_r; xrt_r; xxrt_r; xrt2_r; xxrt2_r; xaddr1_r; xaddr2_r] in + let vars_r = [vmem_r; vmem2_r] in + let uses = [get_def_use_r vmem_r; get_def_use_r vmem2_r] in + let useshigh = [get_def_use_high_r vmem_r; get_def_use_high_r vmem2_r] in + let _ = + floc#memrecorder#record_store_r + ~addr_r:xaddr1_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown + ~xpr_r:xxrt_r in + let _ = + floc#memrecorder#record_store_r + ~addr_r:xaddr2_r + ~var_r:vmem2_r + ~size:4 + ~vtype:t_unknown + ~xpr_r:xxrt2_r in let rdefs = [ - get_rdef xrn; - get_rdef xrm; - get_rdef xrt; - get_rdef xxrt; - get_rdef xrt2; - get_rdef xxrt2] in - let uses = [get_def_use vmem; get_def_use vmem2] in - let useshigh = [get_def_use_high vmem; get_def_use_high vmem2] in + get_rdef_r xrn_r; + get_rdef_r xrm_r; + get_rdef_r xrt_r; + get_rdef_r xxrt_r; + get_rdef_r xrt2_r; + get_rdef_r xxrt2_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vmem; vmem2] - ~xprs:[xrn; xrm; xrt; xxrt; xrt2; xxrt2; xaddr1; xaddr2] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh - () in + mk_instrx_data_r ~vars_r ~xprs_r ~rdefs ~uses ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = + if mem#is_offset_address_writeback then + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) + else + (tags, args) in (tags, args) | StoreRegisterExclusive (c, rd, rt, rn, mem) -> - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let vrd = rd#to_variable floc in - let xrt = rt#to_expr floc in - let xrn = rn#to_expr floc in - let xxrt = rewrite_expr xrt in - let rdefs = [get_rdef xrn; get_rdef xrt; get_rdef xxrt] in - let uses = [get_def_use vmem; get_def_use vrd] in - let useshigh = [get_def_use vmem; get_def_use vrd] in + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let vrd_r = rd#to_variable floc in + let xrt_r = rt#to_expr floc in + let xrn_r = rn#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrt_r; get_rdef_r xxrt_r] in + let uses = [get_def_use_r vmem_r; get_def_use_r vrd_r] in + let useshigh = [get_def_use_r vmem_r; get_def_use_r vrd_r] in let _ = - floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_unknown ~xpr:xxrt in - let (tagstring, args) = - mk_instrx_data - ~vars:[vmem; vrd] - ~xprs:[xrn; xrt; xxrt; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + floc#memrecorder#record_store_r + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:4 + ~vtype:t_unknown + ~xpr_r:xxrt_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vmem_r; vrd_r] + ~xprs_r:[xrn_r; xrt_r; xxrt_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | StoreRegisterHalfword (c, rt, rn, rm, mem, _) -> - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xrt = XOp (XXlsh, [rt#to_expr floc]) in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xxrt = rewrite_expr xrt in - let rdefs = [get_rdef xrn; get_rdef xrm; get_rdef xrt; get_rdef xxrt] in - let uses = [get_def_use vmem] in - let useshigh = [get_def_use_high vmem] in - let (vars, uses, useshigh) = - if mem#is_offset_address_writeback then - let vrn = rn#to_variable floc in - ([vmem; vrn], - uses @ [get_def_use vrn], - useshigh @ [get_def_use_high vrn]) - else - ([vmem], uses, useshigh) in + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xrt_r = rt#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xxrt_r = TR.tmap rewrite_expr xrt_r in + let xxaddr_r = TR.tmap rewrite_expr xaddr_r in + let rdefs = + [get_rdef_r xrn_r; + get_rdef_r xrm_r; + get_rdef_r xrt_r; + get_rdef_r xxrt_r] in + let uses = [get_def_use_r vmem_r] in + let useshigh = [get_def_use_high_r vmem_r] in let _ = - floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:2 ~vtype:t_unknown ~xpr:xxrt in - let (tagstring, args) = - mk_instrx_data - ~vars - ~xprs:[xrn; xrm; xrt; xxrt; xaddr] + floc#memrecorder#record_store_r + ~addr_r:xxaddr_r + ~var_r:vmem_r + ~size:2 + ~vtype:t_unknown + ~xpr_r:xxrt_r in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vmem_r] + ~xprs_r:[xrn_r; xrm_r; xrt_r; xxrt_r; xaddr_r] ~rdefs ~uses ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in + let (tags, args) = + if mem#is_offset_address_writeback then + let vrn_r = rn#to_variable floc in + TR.tfold + ~ok:(fun (inc, xaddr) -> + add_base_update tags args vrn_r inc (Ok xaddr)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + (tags, args) + end) + (mem#to_updated_offset_address floc) + else + (tags, args) in (tags, args) | Subtract (_, c, rd, rn, rm, _, _) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XMinus, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in - let uses = get_def_use vrd in - let usehigh = get_def_use_high vrd in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[uses] - ~useshigh:[usehigh] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | SubtractCarry (_, _, rd, rn, rm, _) -> - let lhs = rd#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMinus, [rhs1; rhs2]) in - let rresult = rewrite_expr result in - (["a:vxxxx"], - [xd#index_variable lhs; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr result; - xd#index_xpr rresult]) + | SubtractCarry (_, c, rd, rn, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) - | SupervisorCall (_, _) -> + | SupervisorCall (c, _) -> let r7 = arm_register_op AR7 RD in - let xr7 = r7#to_expr floc in - (["a:x"], [xd#index_xpr xr7]) + let xr7_r = r7#to_expr floc in + let rdefs = [get_rdef_r xr7_r] in + let (tagstring, args) = mk_instrx_data_r ~xprs_r:[xr7_r] ~rdefs () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | Swap (c, rt, rt2, rn, mem) -> - let vrt = rt#to_variable floc in - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xrt2 = rt2#to_expr floc in - let xxrt2 = rewrite_expr xrt2 in - let xrn = rn#to_expr floc in - let xmem = mem#to_expr floc in + let vrt_r = rt#to_variable floc in + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xrt2_r = rt2#to_expr floc in + let xxrt2_r = TR.tmap rewrite_expr xrt2_r in + let xrn_r = rn#to_expr floc in + let xmem_r = mem#to_expr floc in let rdefs = - [get_rdef xrt2; get_rdef xrn; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let xrmem = rewrite_expr xmem in - let _ = ignore (get_string_reference floc xrmem) in + [get_rdef_r xrt2_r; get_rdef_r xrn_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let _ = + TR.tfold_default + (fun xrmem -> ignore (get_string_reference floc xrmem)) () xrmem_r in let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrt2; xxrt2; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrt2_r; xxrt2_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | SwapByte (c, rt, rt2, rn, mem) -> - let vrt = rt#to_variable floc in - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xrt2 = rt2#to_expr floc in - let xxrt2 = rewrite_expr xrt2 in - let xrn = rn#to_expr floc in - let xmem = mem#to_expr floc in + let vrt_r = rt#to_variable floc in + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xrt2_r = rt2#to_expr floc in + let xxrt2_r = TR.tmap rewrite_expr xrt2_r in + let xrn_r = rn#to_expr floc in + let xmem_r = mem#to_expr floc in let rdefs = - [get_rdef xrt2; get_rdef xrn; get_rdef_memvar vmem] - @ (get_all_rdefs xmem) in - let uses = [get_def_use vrt] in - let useshigh = [get_def_use_high vrt] in - let xrmem = rewrite_expr xmem in - let _ = ignore (get_string_reference floc xrmem) in + [get_rdef_r xrt2_r; get_rdef_r xrn_r; get_rdef_memvar_r vmem_r] + @ (get_all_rdefs_r xmem_r) in + let uses = [get_def_use_r vrt_r] in + let useshigh = [get_def_use_high_r vrt_r] in + let xrmem_r = TR.tmap rewrite_expr xmem_r in + let _ = + TR.tfold_default + (fun xrmem -> ignore (get_string_reference floc xrmem)) () xrmem_r in let (tagstring, args) = - mk_instrx_data - ~vars:[vrt; vmem] - ~xprs:[xrn; xrt2; xxrt2; xmem; xrmem; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + mk_instrx_data_r + ~vars_r:[vrt_r; vmem_r] + ~xprs_r:[xrn_r; xrt2_r; xxrt2_r; xmem_r; xrmem_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | TableBranchByte (_, _, rm, _) -> let iaddr = instr#get_address in - let xrm = rm#to_expr floc in - let xxrm = rewrite_expr xrm in - let rdefs = (get_rdef xrm) :: (get_all_rdefs xxrm) in + let xrm_r = rm#to_expr floc in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r xxrm_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrm; xxrm] - ~rdefs - () in + mk_instrx_data_r ~xprs_r:[xrm_r; xxrm_r] ~rdefs () in let tags = tagstring :: ["agg-jt"] in let agg = (!arm_assembly_instructions)#get_aggregate iaddr in let tags = add_subsumption_dependents agg tags in @@ -2296,422 +2972,548 @@ object (self) | TableBranchHalfword (_, _, rm, _) -> let iaddr = instr#get_address in - let xrm = rm#to_expr floc in - let xxrm = rewrite_expr xrm in - let rdefs = (get_rdef xrm) :: (get_all_rdefs xxrm) in + let xrm_r = rm#to_expr floc in + let xxrm_r = TR.tmap rewrite_expr xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r xxrm_r) in let (tagstring, args) = - mk_instrx_data - ~xprs:[xrm; xxrm] - ~rdefs - () in + mk_instrx_data_r ~xprs_r:[xrm_r; xxrm_r] ~rdefs () in let tags = tagstring :: ["agg-jt"] in let agg = (!arm_assembly_instructions)#get_aggregate iaddr in let tags = add_subsumption_dependents agg tags in (tags, args) - | Test (_, rn, rm, _) -> - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (["a:xx"], [xd#index_xpr xrn; xd#index_xpr xrm]) + | Test (c, rn, rm, _) -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XBAnd, [xrn; xrm])) xrn_r xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r result_r) in + let (tagstring, args) = + mk_instrx_data_r ~xprs_r:[xrm_r; xrn_r; result_r] ~rdefs () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) - | UnsignedDivide (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr xrn; xd#index_xpr xrm]) + | TestEquivalence (c, rn, rm) -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XBXor, [xrn; xrm])) xrn_r xrm_r in + let rdefs = (get_rdef_r xrm_r) :: (get_all_rdefs_r result_r) in + let (tagstring, args) = + mk_instrx_data_r ~xprs_r:[xrm_r; xrn_r; result_r] ~rdefs () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) - | UnsignedAdd8 (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr xrn; xd#index_xpr xrm]) + | UnsignedAdd8 (c, rd, rn, rm) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rdefs = [get_rdef_r xrm_r; get_rdef_r xrn_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | UnsignedBitFieldExtract (c, rd, rn) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xxrn = rewrite_expr xrn in - let rdefs = [get_rdef xrn] @ (get_all_rdefs xxrn) in + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xxrn_r = TR.tmap rewrite_expr xrn_r in + let rdefs = [get_rdef_r xrn_r] @ (get_all_rdefs_r xxrn_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xxrn_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | UnsignedDivide (c, rd, rn, rm) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xxrn] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r] + ~rdefs + ~uses + ~useshigh () in - let (tags, args) = - match c with - | ACCAlways -> ([tagstring], args) - | c when is_cond_conditional c && floc#has_test_expr -> - let tcond = rewrite_expr floc#get_test_expr in - add_instr_condition [tagstring] args tcond - | _ -> (tagstring :: ["uc"], args) in - (tags, args) - - | UnsignedExtendAddByte (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr rhs1; xd#index_xpr rhs2]) - - | UnsignedExtendAddHalfword (_, rd, rn, rm) -> - let lhs = rd#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - (["a:vxx"], - [xd#index_variable lhs; xd#index_xpr rhs1; xd#index_xpr rhs2]) + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) - | UnsignedExtendByte (c, rd, rm, _) -> - let vrd = rd#to_variable floc in - let xrm = XOp (XXlsb, [rm#to_expr floc]) in - let result = xrm in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrm] @ (get_all_rdefs rresult) in + | UnsignedExtendAddByte (c, rd, rn, rm) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | UnsignedExtendHalfword (c, rd, rm, _) -> - let vrd = rd#to_variable floc in - let xrm = rm#to_expr floc in - let result = XOp (XXlsh, [xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrm] @ (get_all_rdefs rresult) in + | UnsignedExtendAddHalfword (c, rd, rn, rm) -> + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | UnsignedExtendByte (c, rd, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let result_r = TR.tmap (fun xrm -> XOp (XXlsb, [xrm])) xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) + + | UnsignedExtendHalfword (c, rd, rm, _) -> + let vrd_r = rd#to_variable floc in + let xrm_r = rm#to_expr floc in + let result_r = TR.tmap (fun xrm -> XOp (XXlsh, [xrm])) xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = [get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | UnsignedMultiplyAccumulateLong (_, _, rdlo, rdhi, rn, rm) -> - let lhslo = rdlo#to_variable floc in - let lhshi = rdhi#to_variable floc in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMult, [rhs1; rhs2]) in - let rresult = rewrite_expr result in - (["a:vvxxxx"], - [xd#index_variable lhslo; - xd#index_variable lhshi; - xd#index_xpr rhs1; - xd#index_xpr rhs2; - xd#index_xpr result; - xd#index_xpr rresult]) + | UnsignedMultiplyAccumulateLong (_, c, rdlo, rdhi, rn, rm) -> + let vlo_r = rdlo#to_variable floc in + let vhi_r = rdhi#to_variable floc in + let xlo_r = rdlo#to_expr floc in + let xhi_r = rdhi#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let acc_r = TR.tmap (fun xhi -> XOp (XMult, [xhi; e32_c])) xhi_r in + let acc_r = + TR.tmap2 (fun acc xlo -> XOp (XPlus, [acc; xlo])) acc_r xlo_r in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let result_r = + TR.tmap2 (fun result acc -> XOp (XPlus, [result; acc])) result_r acc_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r; get_rdef_r xlo_r; get_rdef_r xhi_r] + @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vlo_r; get_def_use_r vhi_r] in + let useshigh = [get_def_use_high_r vlo_r; get_def_use_high_r vhi_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vlo_r; vhi_r] + ~xprs_r:[xrn_r; xrm_r; xlo_r; xhi_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | UnsignedMultiplyLong (_, c, rdlo, rdhi, rn, rm) -> - let vlo = rdlo#to_variable floc in - let vhi = rdhi#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XMult, [xrn; xrm]) in - let rresult = rewrite_expr result in - let rdefs = [get_rdef xrn; get_rdef xrm] @ (get_all_rdefs rresult) in + let vlo_r = rdlo#to_variable floc in + let vhi_r = rdhi#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let rresult_r = TR.tmap rewrite_expr result_r in + let rdefs = + [get_rdef_r xrn_r; get_rdef_r xrm_r] @ (get_all_rdefs_r rresult_r) in + let uses = [get_def_use_r vlo_r; get_def_use_r vhi_r] in + let useshigh = [get_def_use_high_r vlo_r; get_def_use_high_r vhi_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vlo; vhi] - ~xprs:[xrn; xrm; result; rresult] - ~rdefs:rdefs - ~uses:[get_def_use vlo; get_def_use vhi] - ~useshigh:[get_def_use_high vlo; get_def_use_high vhi] + mk_instrx_data_r + ~vars_r:[vlo_r; vhi_r] + ~xprs_r:[xrn_r; xrm_r; result_r; rresult_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | UnsignedSaturate (c, rd, imm, rn) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let ximm = imm#to_expr floc in - let rdefs = [get_rdef xrn] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[ximm; xrn] + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let ximm_r = imm#to_expr floc in + let rdefs = [get_rdef_r xrn_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[ximm_r; xrn_r] ~rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | UnsignedSaturatingSubtract8 (c, rd, rn, rm) -> - let vrd = rd#to_variable floc in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let rdefs = [get_rdef xrn; get_rdef xrm] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vrd] - ~xprs:[xrn; xrm] + let vrd_r = rd#to_variable floc in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rdefs = [get_rdef_r xrn_r; get_rdef_r xrm_r] in + let uses = [get_def_use_r vrd_r] in + let useshigh = [get_def_use_high_r vrd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vrd_r] + ~xprs_r:[xrn_r; xrm_r] ~rdefs - ~uses:[get_def_use vrd] - ~useshigh:[get_def_use_high vrd] + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorAbsolute (c, _, dst, src) -> - let vdst = dst#to_variable floc in - let xsrc = src#to_expr floc in - let rxsrc = rewrite_expr xsrc in - let rdefs = [get_rdef xsrc] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc; rxsrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xsrc_r = src#to_expr floc in + let rxsrc_r = TR.tmap rewrite_expr xsrc_r in + let rdefs = [get_rdef_r xsrc_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc_r; rxsrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VCompare (_, c, _, fdst, src1, src2) -> - let v_fpscr = fdst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let rxsrc2 = rewrite_expr xsrc2 in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2] in - let (tagstring, args) = - mk_instrx_data - ~xprs:[xsrc1; xsrc2; rxsrc1; rxsrc2] - ~rdefs:rdefs - ~uses:[get_def_use v_fpscr] + let v_fpscr_r = fdst#to_variable floc in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rdefs = [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r] in + let uses = [get_def_use_r v_fpscr_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[v_fpscr_r] + ~xprs_r:[xsrc1_r; xsrc2_r; rxsrc1_r; rxsrc2_r] + ~rdefs + ~uses () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorConvert (_, _, c, _, _, dst, src, _) -> - let vdst = dst#to_variable floc in - let xsrc = src#to_expr floc in - let rxsrc = rewrite_expr xsrc in - let rdefs = [get_rdef xsrc] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc; rxsrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xsrc_r = src#to_expr floc in + let rxsrc_r = TR.tmap rewrite_expr xsrc_r in + let rdefs = [get_rdef_r xsrc_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc_r; rxsrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VDivide (c, _, dst, src1, src2) -> - let vdst = dst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let rxsrc2 = rewrite_expr xsrc2 in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc1; xsrc2; rxsrc1; rxsrc2] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rdefs = [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc1_r; xsrc2_r; rxsrc1_r; rxsrc2_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | VectorDuplicate (_, _, _, _, _, src) -> - let src = src#to_expr floc in - let rsrc = rewrite_expr src in - (["a:xx"], [xd#index_xpr src; xd#index_xpr rsrc]) + | VectorDuplicate (c, _, _, _, dst, src) -> + let vdst_r = dst#to_variable floc in + let src_r = src#to_expr floc in + let rsrc_r = TR.tmap rewrite_expr src_r in + let rdefs = (get_rdef_r rsrc_r) :: (get_all_rdefs_r rsrc_r) in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[src_r; rsrc_r] + ~rdefs + ~uses + ~useshigh + () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | VLoadRegister (c, vd, base, mem) -> - let vvd = vd#to_variable floc in - let xbase = base#to_expr floc in - let xaddr = mem#to_address floc in - let vmem = mem#to_variable floc in - let xmem = mem#to_expr floc in - let rxbase = rewrite_expr xbase in - let rxmem = rewrite_expr xmem in - let rdefs = [get_rdef_memvar vmem; get_rdef xmem] @ (get_all_rdefs rxmem) in - let uses = [get_def_use_high vvd] in - let useshigh = [get_def_use_high vvd] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vvd; vmem] - ~xprs:[xmem; rxmem; xbase; rxbase; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + let vvd_r = vd#to_variable floc in + let xbase_r = base#to_expr floc in + let xaddr_r = mem#to_address floc in + let vmem_r = mem#to_variable floc in + let xmem_r = mem#to_expr floc in + let rxbase_r = TR.tmap rewrite_expr xbase_r in + let rxmem_r = TR.tmap rewrite_expr xmem_r in + let rdefs = + [get_rdef_memvar_r vmem_r; get_rdef_r xmem_r] + @ (get_all_rdefs_r rxmem_r) in + let uses = [get_def_use_high_r vvd_r] in + let useshigh = [get_def_use_high_r vvd_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vvd_r; vmem_r] + ~xprs_r:[xmem_r; rxmem_r; xbase_r; rxbase_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorMoveDS (c, _, dst, src) -> - let vdst = dst#to_variable floc in - let xsrc = src#to_expr floc in - let rxsrc = rewrite_expr xsrc in - let rdefs = [get_rdef xsrc] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc; rxsrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xsrc_r = src#to_expr floc in + let rxsrc_r = TR.tmap rewrite_expr xsrc_r in + let rdefs = [get_rdef_r xsrc_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc_r; rxsrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorMoveDDSS (c, _, dst1, dst2, ddst, src1, src2, ssrc) -> - let vdst1 = dst1#to_variable floc in - let vdst2 = dst2#to_variable floc in - let vddst = ddst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let xssrc = ssrc#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let rxsrc2 = rewrite_expr xsrc2 in - let rxssrc = rewrite_expr xssrc in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2; get_rdef xssrc] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst1; vdst2; vddst] - ~xprs:[xsrc1; xsrc2; xssrc; rxsrc1; rxsrc2; rxssrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst1; get_def_use vdst2; get_def_use vddst] - ~useshigh:[ - get_def_use_high vdst1; - get_def_use_high vdst2; - get_def_use_high vddst] + let vdst1_r = dst1#to_variable floc in + let vdst2_r = dst2#to_variable floc in + let vddst_r = ddst#to_variable floc in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let xssrc_r = ssrc#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rxssrc_r = TR.tmap rewrite_expr xssrc_r in + let rdefs = + [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r; get_rdef_r xssrc_r] in + let uses = + [get_def_use_r vdst1_r; get_def_use_r vdst2_r; get_def_use_r vddst_r] in + let useshigh = [ + get_def_use_high_r vdst1_r; + get_def_use_high_r vdst2_r; + get_def_use_high_r vddst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst1_r; vdst2_r; vddst_r] + ~xprs_r:[xsrc1_r; xsrc2_r; xssrc_r; rxsrc1_r; rxsrc2_r; rxssrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorMoveDSS (c, _, dst, src1, src2, ssrc) -> - let vdst = dst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let xssrc = ssrc#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let rxsrc2 = rewrite_expr xsrc2 in - let rxssrc = rewrite_expr xssrc in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2; get_rdef xssrc] in + let vdst_r = dst#to_variable floc in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let xssrc_r = ssrc#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rxssrc_r = TR.tmap rewrite_expr xssrc_r in + let rdefs = + [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r; get_rdef_r xssrc_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc1; xsrc2; xssrc; rxsrc1; rxsrc2; rxssrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc1_r; xsrc2_r; xssrc_r; rxsrc1_r; rxsrc2_r; rxssrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorMoveDDS (c, _, dst1, dst2, ddst, src) -> - let vdst1 = dst1#to_variable floc in - let vdst2 = dst2#to_variable floc in - let vddst = ddst#to_variable floc in - let xsrc = src#to_expr floc in - let rxsrc = rewrite_expr xsrc in - let rdefs = [get_rdef xsrc] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst1; vdst2; vddst] - ~xprs:[xsrc; rxsrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst1; get_def_use vdst2; get_def_use vddst] - ~useshigh:[ - get_def_use_high vdst1; - get_def_use_high vdst2; - get_def_use_high vddst] + let vdst1_r = dst1#to_variable floc in + let vdst2_r = dst2#to_variable floc in + let vddst_r = ddst#to_variable floc in + let xsrc_r = src#to_expr floc in + let rxsrc_r = TR.tmap rewrite_expr xsrc_r in + let rdefs = [get_rdef_r xsrc_r] in + let uses = + [get_def_use_r vdst1_r; get_def_use_r vdst2_r; get_def_use_r vddst_r] in + let useshigh = [ + get_def_use_high_r vdst1_r; + get_def_use_high_r vdst2_r; + get_def_use_high_r vddst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst1_r; vdst2_r; vddst_r] + ~xprs_r:[xsrc_r; rxsrc_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VMoveRegisterStatus (c, dst, src) -> - let vdst = dst#to_variable floc in - let xsrc = src#to_expr floc in - let rdefs = [get_rdef xsrc] in + let vdst_r = dst#to_variable floc in + let xsrc_r = src#to_expr floc in + let rdefs = [get_rdef_r xsrc_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] - () in + mk_instrx_data_r + ~vars_r:[vdst_r] ~xprs_r:[xsrc_r] ~rdefs ~uses ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) - | VMoveToSystemRegister (_, _, src) -> - let xsrc = src#to_expr floc in - (["a:x"], [xd#index_xpr xsrc]) + | VMoveToSystemRegister (c, _, src) -> + let xsrc_r = src#to_expr floc in + let rdefs = [get_rdef_r xsrc_r] in + let (tagstring, args) = mk_instrx_data_r ~xprs_r:[xsrc_r] ~rdefs () in + let (tags, args) = add_optional_instr_condition tagstring args c in + (tags, args) | VectorMultiplySubtract (c, _, dst, src1, src2) -> - let vdst = dst#to_variable floc in - let xdst = dst#to_expr floc in - let rxdst = rewrite_expr xdst in - let xsrc1 = src1#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let xsrc2 = src2#to_expr floc in - let rxsrc2 = rewrite_expr xsrc2 in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2; get_rdef xdst] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc1; xsrc2; xdst; rxsrc1; rxsrc2; rxdst] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xdst_r = dst#to_expr floc in + let rxdst_r = TR.tmap rewrite_expr xdst_r in + let xsrc1_r = src1#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let xsrc2_r = src2#to_expr floc in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rdefs = [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r; get_rdef_r xdst_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc1_r; xsrc2_r; xdst_r; rxsrc1_r; rxsrc2_r; rxdst_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorPop (c, sp, rl, _) -> - let splhs = sp#to_variable floc in - let sprhs = sp#to_expr floc in + let splhs_r = sp#to_variable floc in + let sprhs_r = sp#to_expr floc in let regcount = rl#get_register_count in let regsize = if rl#is_double_extension_register_list then 8 else 4 in - let spresult = - XOp (XPlus, [sprhs; int_constant_expr (regcount * regsize)]) in - let rspresult = rewrite_expr spresult in - let lhsvars = + let spresult_r = + TR.tmap + (fun sprhs -> + XOp (XPlus, [sprhs; int_constant_expr (regcount * regsize)])) + sprhs_r in + let rspresult_r = TR.tmap rewrite_expr spresult_r in + let lhsvars_rl = List.map (fun (op: arm_operand_int) -> op#to_variable floc) rl#get_extension_register_op_list in let rhsops = List.map (fun offset -> arm_sp_deref ~with_offset:offset RD) (List.init rl#get_register_count (fun i -> regsize * i)) in - let rhsexprs = + let rhsexprs_rl = List.map (fun (x: arm_operand_int) -> x#to_expr floc) rhsops in - let xaddrs = + let xaddrs_rl = List.init regcount (fun i -> - let xaddr = - XOp (XPlus, [sprhs; int_constant_expr (i * regsize)]) in - rewrite_expr xaddr) in - let rrhsexprs = List.map rewrite_expr rhsexprs in - let rdefs = List.map get_rdef (sprhs :: rhsexprs) in - let uses = List.map get_def_use (splhs :: lhsvars) in - let useshigh = List.map get_def_use_high (splhs :: lhsvars) in - let xprs = (sprhs :: spresult :: rspresult :: rrhsexprs) @ xaddrs in - let (tagstring, args) = - mk_instrx_data - ~vars:(splhs :: lhsvars) - ~xprs + let xaddr_r = + TR.tmap + (fun sprhs -> + XOp (XPlus, [sprhs; int_constant_expr (i * regsize)])) + sprhs_r in + TR.tmap rewrite_expr xaddr_r) in + let rrhsexprs_rl = List.map (TR.tmap rewrite_expr) rhsexprs_rl in + let rdefs = List.map get_rdef_r (sprhs_r :: rhsexprs_rl) in + let uses = List.map get_def_use_r (splhs_r :: lhsvars_rl) in + let useshigh = List.map get_def_use_high_r (splhs_r :: lhsvars_rl) in + let xprs_r = + (sprhs_r :: spresult_r :: rspresult_r :: rrhsexprs_rl) @ xaddrs_rl in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(splhs_r :: lhsvars_rl) + ~xprs_r ~rdefs ~uses ~useshigh @@ -2720,38 +3522,45 @@ object (self) (tags, args) | VectorPush (c, sp, rl, _) -> - let splhs = sp#to_variable floc in - let sprhs = sp#to_expr floc in - let rhsexprs = + let splhs_r = sp#to_variable floc in + let sprhs_r = sp#to_expr floc in + let rhsexprs_rl = List.map (fun (op: arm_operand_int) -> op#to_expr floc) rl#get_extension_register_op_list in - let rrhsexprs = List.map rewrite_expr rhsexprs in - let regcount = List.length rhsexprs in - let regsize = - if rl#is_double_extension_register_list then 8 else 4 in + let rrhsexprs_rl = List.map (TR.tmap rewrite_expr) rhsexprs_rl in + let regcount = List.length rhsexprs_rl in + let regsize = if rl#is_double_extension_register_list then 8 else 4 in let lhsops = List.map (fun offset -> arm_sp_deref ~with_offset:offset WR) (List.init regcount (fun i -> ((- regsize * regcount) + (regsize * i)))) in - let lhsvars = List.map (fun v -> v#to_variable floc) lhsops in - let rdefs = List.map get_rdef (sprhs :: rhsexprs) in - let uses = List.map get_def_use (splhs :: lhsvars) in - let useshigh = List.map get_def_use_high (splhs :: lhsvars) in - let spresult = - XOp (XMinus, [sprhs; int_constant_expr (regcount * regsize)]) in - let rspresult = rewrite_expr spresult in - let xaddrs = + let lhsvars_rl = List.map (fun v -> v#to_variable floc) lhsops in + let rdefs = List.map get_rdef_r (sprhs_r :: rhsexprs_rl) in + let uses = List.map get_def_use_r (splhs_r :: lhsvars_rl) in + let useshigh = List.map get_def_use_high_r (splhs_r :: lhsvars_rl) in + let spresult_r = + TR.tmap + (fun sprhs -> + XOp (XMinus, [sprhs; int_constant_expr (regcount * regsize)])) + sprhs_r in + let rspresult_r = TR.tmap rewrite_expr spresult_r in + let xaddrs_rl = List.init regcount (fun i -> - let xaddr = - XOp (XPlus, [rspresult; int_constant_expr (i * regsize)]) in - rewrite_expr xaddr) in - let (tagstring, args) = - mk_instrx_data - ~vars:(splhs :: lhsvars) - ~xprs:((sprhs :: spresult :: rspresult :: rrhsexprs) @ xaddrs) + let xaddr_r = + TR.tmap + (fun rspresult -> + XOp (XPlus, [rspresult; int_constant_expr (i * regsize)])) + rspresult_r in + TR.tmap rewrite_expr xaddr_r) in + let xprs_r = + ((sprhs_r :: spresult_r :: rspresult_r :: rrhsexprs_rl) @ xaddrs_rl) in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:(splhs_r :: lhsvars_rl) + ~xprs_r ~rdefs ~uses ~useshigh @@ -2760,42 +3569,44 @@ object (self) (tags, args) | VStoreRegister (c, src, base, mem) -> - let vmem = mem#to_variable floc in - let xaddr = mem#to_address floc in - let xsrc = src#to_expr floc in - let xbase = base#to_expr floc in - let rxsrc = rewrite_expr xsrc in - let rxbase = rewrite_expr xbase in - let rdefs = [get_rdef xsrc; get_rdef xbase] in - let uses = [get_def_use vmem] in - let useshigh = [get_def_use_high vmem] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vmem] - ~xprs:[xsrc; rxsrc; xbase; rxbase; xaddr] - ~rdefs:rdefs - ~uses:uses - ~useshigh:useshigh + let vmem_r = mem#to_variable floc in + let xaddr_r = mem#to_address floc in + let xsrc_r = src#to_expr floc in + let xbase_r = base#to_expr floc in + let rxsrc_r = TR.tmap rewrite_expr xsrc_r in + let rxbase_r = TR.tmap rewrite_expr xbase_r in + let rdefs = [get_rdef_r xsrc_r; get_rdef_r xbase_r] in + let uses = [get_def_use_r vmem_r] in + let useshigh = [get_def_use_high_r vmem_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vmem_r] + ~xprs_r:[xsrc_r; rxsrc_r; xbase_r; rxbase_r; xaddr_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) | VectorSubtract (c, _, dst, src1, src2) -> - let vdst = dst#to_variable floc in - let xdst = dst#to_expr floc in - let rxdst = rewrite_expr xdst in - let xsrc1 = src1#to_expr floc in - let rxsrc1 = rewrite_expr xsrc1 in - let xsrc2 = src2#to_expr floc in - let rxsrc2 = rewrite_expr xsrc2 in - let rdefs = [get_rdef xsrc1; get_rdef xsrc2] in - let (tagstring, args) = - mk_instrx_data - ~vars:[vdst] - ~xprs:[xsrc1; xsrc2; xdst; rxsrc1; rxsrc2; rxdst] - ~rdefs:rdefs - ~uses:[get_def_use vdst] - ~useshigh:[get_def_use_high vdst] + let vdst_r = dst#to_variable floc in + let xdst_r = dst#to_expr floc in + let rxdst_r = TR.tmap rewrite_expr xdst_r in + let xsrc1_r = src1#to_expr floc in + let rxsrc1_r = TR.tmap rewrite_expr xsrc1_r in + let xsrc2_r = src2#to_expr floc in + let rxsrc2_r = TR.tmap rewrite_expr xsrc2_r in + let rdefs = [get_rdef_r xsrc1_r; get_rdef_r xsrc2_r] in + let uses = [get_def_use_r vdst_r] in + let useshigh = [get_def_use_high_r vdst_r] in + let (tagstring, args) = + mk_instrx_data_r + ~vars_r:[vdst_r] + ~xprs_r:[xsrc1_r; xsrc2_r; xdst_r; rxsrc1_r; rxsrc2_r; rxdst_r] + ~rdefs + ~uses + ~useshigh () in let (tags, args) = add_optional_instr_condition tagstring args c in (tags, args) @@ -2820,12 +3631,14 @@ object (self) with | BCH_failure p -> let msg = - LBLOCK [STR "Error in writing xml instruction: "; - floc#l#i#toPretty; - STR " "; - instr#toPretty; - STR ": "; - p] in + LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Error in writing xml instruction: "; + floc#l#i#toPretty; + STR " "; + instr#toPretty; + STR ": "; + p] in raise (BCH_failure msg) method write_xml (node:xml_element_int) = diff --git a/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml b/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml index dd16b4b6..4f3b2651 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 @@ -32,6 +32,7 @@ open CHPretty (* chutil *) open CHLogger +open CHTraceResult (* xprlib *) open XprTypes @@ -75,6 +76,7 @@ object (self) val faddr = fn#get_address#to_hex_string val finfo = get_function_info fn#get_address val env = (get_function_info fn#get_address)#env + val fndata = BCHFunctionData.functions_data#get_function fn#get_address method record_type_constraints = let fintf = finfo#get_summary#get_function_interface in @@ -95,6 +97,19 @@ object (self) let x = floc#inv#rewrite_expr x in simplify_xpr x in + let get_regvar_type_annotation (): btype_t option = + if fndata#has_regvar_type_annotation loc#i then + TR.tfold + ~ok:(fun t -> Some t) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + None + end) + (fndata#get_regvar_type_annotation loc#i) + else + None in + let rdef_pairs_to_pretty (pairs: (symbol_t * symbol_t) list) = pretty_print_list pairs @@ -126,6 +141,9 @@ object (self) | [vinv] -> vinv#get_reaching_defs | _ -> []) in + let get_variable_rdefs_r (v_r: variable_t traceresult): symbol_t list = + TR.tfold_default get_variable_rdefs [] v_r in + let get_variable_defuses (v: variable_t): symbol_t list = let symvar = floc#f#env#mk_symbolic_variable v in let varinvs = floc#varinv#get_var_def_uses symvar in @@ -137,6 +155,9 @@ object (self) let defuses = get_variable_defuses v in List.exists (fun s -> s#getBaseName = "exit") defuses in + let has_exit_use_r (v_r: variable_t traceresult): bool = + TR.tfold_default has_exit_use false v_r in + let getopt_initial_argument_value (x: xpr_t): (register_t * int) option = match (rewrite_expr x) with | XVar v when floc#f#env#is_initial_arm_argument_value v -> @@ -148,6 +169,10 @@ object (self) n#toInt) | _ -> None in + let getopt_initial_argument_value_r + (x_r: xpr_t traceresult): (register_t * int) option = + TR.tfold_default getopt_initial_argument_value None x_r in + let getopt_stackaddress (x: xpr_t): int option = match (rewrite_expr x) with | XOp (xop, [XVar v; XConst (IntConst n)]) @@ -167,6 +192,9 @@ object (self) (floc#f#env#get_initial_register_value_register v) | _ -> None in + let getopt_stackaddress_r (x_r: xpr_t traceresult): int option = + TR.tfold_default getopt_stackaddress None x_r in + let getopt_global_address (x: xpr_t): doubleword_int option = match (rewrite_expr x) with | XConst (IntConst num) -> @@ -178,6 +206,9 @@ object (self) | _ -> None in + let getopt_global_address_r (x_r: xpr_t traceresult): doubleword_int option = + TR.tfold_default getopt_global_address None x_r in + let log_subtype_constraint (kind: string) (ty1: type_term_t) (ty2: type_term_t) = let tag = "add " ^ kind ^ " subtype constraint" in @@ -208,13 +239,13 @@ object (self) match instr#get_opcode with | Add (_, _, rd, rn, rm, _) -> - let xrn = rn#to_expr floc in + let xrn_r = rn#to_expr floc in begin (if rm#is_immediate && (rm#to_numerical#toInt < 256) then let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in List.iter (fun rnsym -> let rnaddr = rnsym#getBaseName in @@ -226,12 +257,12 @@ object (self) store#add_subtype_constraint rntypeterm lhstypeterm end) rndefs); - (match getopt_global_address (rn#to_expr floc) with + (match getopt_global_address_r (rn#to_expr floc) with | Some gaddr -> if BCHConstantDefinitions.is_in_global_arrayvar gaddr then (match (BCHConstantDefinitions.get_arrayvar_base_offset gaddr) with | Some _ -> - let rmdefs = get_variable_rdefs (rm#to_variable floc) in + let rmdefs = get_variable_rdefs_r (rm#to_variable floc) in let rmreg = rm#to_register in List.iter (fun rmsym -> let rmaddr = rmsym#getBaseName in @@ -248,7 +279,7 @@ object (self) () | _ -> ()); - (match getopt_initial_argument_value xrn with + (match getopt_initial_argument_value_r xrn_r with | Some (reg, _) -> let ftvar = mk_function_typevar faddr in let ftvar = add_freg_param_capability reg ftvar in @@ -267,7 +298,7 @@ object (self) let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in let rnreg = rn#to_register in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in begin (* ASR results in a signed integer *) @@ -295,7 +326,7 @@ object (self) | BitwiseAnd (_, _, rd, rn, _, _) -> let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in begin @@ -330,7 +361,7 @@ object (self) | BitwiseOr (_, _, rd, rn, _, _) -> let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in begin @@ -345,7 +376,6 @@ object (self) end) rndefs end - | Branch _ -> (* no type information gained *) () @@ -466,7 +496,7 @@ object (self) end | Compare (_, rn, rm, _) when rm#is_immediate -> - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in let immval = rm#to_numerical#toInt in if immval = 0 then @@ -484,8 +514,8 @@ object (self) end) rndefs | Compare (_, rn, rm, _) when rm#is_register -> - let rndefs = get_variable_rdefs (rn#to_variable floc) in - let rmdefs = get_variable_rdefs (rm#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in + let rmdefs = get_variable_rdefs_r (rm#to_variable floc) in let rnreg = rn#to_register in let rmreg = rm#to_register in let pairs = CHUtil.xproduct rndefs rmdefs in @@ -506,8 +536,8 @@ object (self) store#add_subtype_constraint rntypeterm rmtypeterm end) pairs); - (let xrn = rn#to_expr floc in - match getopt_initial_argument_value xrn with + (let xrn_r = rn#to_expr floc in + match getopt_initial_argument_value_r xrn_r with | Some (reg, _) -> let ftvar = mk_function_typevar faddr in let ftvar = add_freg_param_capability reg ftvar in @@ -522,8 +552,8 @@ object (self) end) rmdefs | _ -> ()); - (let xrm = rm#to_expr floc in - match getopt_initial_argument_value xrm with + (let xrm_r = rm#to_expr floc in + match getopt_initial_argument_value_r xrm_r with | Some (reg, _) -> let ftvar = mk_function_typevar faddr in let ftvar = add_freg_param_capability reg ftvar in @@ -544,8 +574,20 @@ object (self) let rttypevar = mk_reglhs_typevar rtreg faddr iaddr in begin + (match get_regvar_type_annotation () with + | Some t -> + let opttc = mk_btype_constraint rttypevar t in + (match opttc with + | Some tc -> + begin + log_type_constraint "LDR-rvintro" tc; + store#add_constraint tc + end + | _ -> ()) + | _ -> ()); + (* LDR rt, [rn, rm] : X_rndef.load <: X_rt *) - (let xrdef = get_variable_rdefs (rn#to_variable floc) in + (let xrdef = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in let offset = rm#to_numerical#toInt in List.iter (fun rdsym -> @@ -559,8 +601,9 @@ object (self) store#add_subtype_constraint rdtypeterm rttypeterm end) xrdef); - (match rewrite_expr (memop#to_expr floc) with - | XVar v -> + (match TR.tmap rewrite_expr (memop#to_expr floc) with + | Error _ -> () + | Ok (XVar v) -> (match floc#f#env#get_variable_type v with | Some ty -> let opttc = mk_btype_constraint rttypevar ty in @@ -576,7 +619,7 @@ object (self) (* if the address to load from is the address of a global struct field, assign the type of that field to the destination register. *) - (match getopt_global_address (memop#to_address floc) with + (match getopt_global_address_r (memop#to_address floc) with | Some gaddr -> if BCHConstantDefinitions.is_in_global_structvar gaddr then match (BCHConstantDefinitions.get_structvar_base_offset gaddr) with @@ -630,7 +673,7 @@ object (self) (* if the value loaded is the start address of a global array, assign that array type to the destination register. *) - (match getopt_global_address (memop#to_expr floc) with + (match getopt_global_address_r (memop#to_expr floc) with | Some gaddr -> if BCHConstantDefinitions.is_in_global_arrayvar gaddr then (match (BCHConstantDefinitions.get_arrayvar_base_offset gaddr) with @@ -662,7 +705,7 @@ object (self) | _ -> ()) | _ -> ()); - (match getopt_stackaddress (memop#to_address floc) with + (match getopt_stackaddress_r (memop#to_address floc) with | None -> () | Some offset -> let rhstypevar = mk_localstack_lhs_typevar offset faddr iaddr in @@ -680,7 +723,7 @@ object (self) begin (* LDRB rt, [rn, rm] : X_rndef.load <: X_rt *) - (let xrdefs = get_variable_rdefs (rn#to_variable floc) in + (let xrdefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in let offset = rm#to_numerical#toInt in List.iter (fun rdsym -> @@ -727,7 +770,7 @@ object (self) begin (* LDRH rt, [rn, rm] : X_rndef.load <: X_rt *) - (let xrdef = get_variable_rdefs (rn#to_variable floc) in + (let xrdef = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in let offset = rm#to_numerical#toInt in List.iter (fun rdsym -> @@ -762,7 +805,7 @@ object (self) let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in let rnreg = rn#to_register in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in (* LSL results in an unsigned integer *) (let tc = mk_int_type_constant Unsigned 32 in @@ -789,7 +832,7 @@ object (self) let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in let rnreg = rn#to_register in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in (* LSR results in an unsigned integer *) (let tc = mk_int_type_constant Unsigned 32 in @@ -834,11 +877,11 @@ object (self) (* Move x, y --- x := y --- Y <: X *) | Move (_, _, rd, rm, _, _) when rm#is_register -> - let xrm = rm#to_expr floc in + let xrm_r = rm#to_expr floc in let rdreg = rd#to_register in begin (* propagate function argument type *) - (match getopt_initial_argument_value xrm with + (match getopt_initial_argument_value_r xrm_r with | Some (rmreg, off) when off = 0 -> let rhstypevar = mk_function_typevar faddr in let rhstypevar = add_freg_param_capability rmreg rhstypevar in @@ -852,7 +895,7 @@ object (self) | _ -> ()); (* propagate function return type *) - (if rd#get_register = AR0 && (has_exit_use (rd#to_variable floc)) then + (if rd#get_register = AR0 && (has_exit_use_r (rd#to_variable floc)) then let regvar = mk_reglhs_typevar rdreg faddr iaddr in let fvar = mk_function_typevar faddr in let fvar = add_return_capability fvar in @@ -865,8 +908,8 @@ object (self) (* use reaching defs *) (let rmreg = rm#to_register in - let rmvar = rm#to_variable floc in - let rmrdefs = get_variable_rdefs rmvar in + let rmvar_r = rm#to_variable floc in + let rmrdefs = get_variable_rdefs_r rmvar_r in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in List.iter (fun rmrdef -> let rmaddr = rmrdef#getBaseName in @@ -910,17 +953,48 @@ object (self) (* no type information gained *) () + | SignedMultiplyLong (_, _, rdlo, rdhi, rn, rm) -> + let rdloreg = rdlo#to_register in + let lhslotypevar = mk_reglhs_typevar rdloreg faddr iaddr in + let rdhireg = rdhi#to_register in + let lhshitypevar = mk_reglhs_typevar rdhireg faddr iaddr in + let rnreg = rn#to_register in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in + let rmreg = rm#to_register in + let rmdefs = get_variable_rdefs_r (rm#to_variable floc) in + + let tc = mk_int_type_constant Signed 32 in + let tctypeterm = mk_cty_term tc in + let lhslotypeterm = mk_vty_term lhslotypevar in + let lhshitypeterm = mk_vty_term lhshitypevar in + begin + store#add_subtype_constraint tctypeterm lhslotypeterm; + store#add_subtype_constraint tctypeterm lhshitypeterm; + + (List.iter (fun rnrdef -> + let rnaddr = rnrdef#getBaseName in + let rntypevar = mk_reglhs_typevar rnreg faddr rnaddr in + let rntypeterm = mk_vty_term rntypevar in + store#add_subtype_constraint tctypeterm rntypeterm) rndefs); + + (List.iter (fun rmrdef -> + let rmaddr = rmrdef#getBaseName in + let rmtypevar = mk_reglhs_typevar rmreg faddr rmaddr in + let rmtypeterm = mk_vty_term rmtypevar in + store#add_subtype_constraint tctypeterm rmtypeterm) rmdefs) + end + (* Store x in y --- *y := x --- X <: Y.store *) | StoreRegister (_, rt, _rn, rm, memvarop, _) when rm#is_immediate -> - let xaddr = memvarop#to_address floc in - let xrt = rt#to_expr floc in - (match getopt_stackaddress xaddr with + let xaddr_r = memvarop#to_address floc in + let xrt_r = rt#to_expr floc in + (match getopt_stackaddress_r xaddr_r with | None -> () | Some offset -> let lhstypevar = mk_localstack_lhs_typevar offset faddr iaddr in begin (* propagate function argument type *) - (match getopt_initial_argument_value xrt with + (match getopt_initial_argument_value_r xrt_r with | Some (rtreg, off) when off = 0 -> let rhstypevar = mk_function_typevar faddr in let rhstypevar = add_freg_param_capability rtreg rhstypevar in @@ -934,8 +1008,8 @@ object (self) (* propagate src register type from rdefs *) (let rtreg = rt#to_register in - let rtvar = rt#to_variable floc in - let rtrdefs = get_variable_rdefs rtvar in + let rtvar_r = rt#to_variable floc in + let rtrdefs = get_variable_rdefs_r rtvar_r in List.iter (fun rtrdef -> let rtaddr = rtrdef#getBaseName in if rtaddr != "init" then @@ -950,10 +1024,10 @@ object (self) ) | StoreRegisterByte (_, rt, rn, rm, _memvarop, _) when rm#is_immediate -> - let rnrdefs = get_variable_rdefs (rn#to_variable floc) in + let rnrdefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in let offset = rm#to_numerical#toInt in - let rtrdefs = get_variable_rdefs (rt#to_variable floc) in + let rtrdefs = get_variable_rdefs_r (rt#to_variable floc) in let rtreg = rt#to_register in begin @@ -1003,7 +1077,7 @@ object (self) | Subtract (_, _, rd, rn, _, _, _) -> let rdreg = rd#to_register in let lhstypevar = mk_reglhs_typevar rdreg faddr iaddr in - let rndefs = get_variable_rdefs (rn#to_variable floc) in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in let rnreg = rn#to_register in begin @@ -1020,6 +1094,51 @@ object (self) end) rndefs end + | UnsignedBitFieldExtract (_, _, rn) -> + (match rn#get_kind with + | ARMRegBitSequence (r, _, _) -> + let rnreg = register_of_arm_register r in + let rndefs = get_variable_rdefs_r (rn#to_variable floc) in + begin + (List.iter (fun rnrdef -> + let rnaddr = rnrdef#getBaseName in + let rntypevar = mk_reglhs_typevar rnreg faddr rnaddr in + let tyc = mk_int_type_constant Unsigned 32 in + let tctypeterm = mk_cty_term tyc in + let rntypeterm = mk_vty_term rntypevar in + begin + log_subtype_constraint "UBFX-rhs" tctypeterm rntypeterm; + store#add_subtype_constraint tctypeterm rntypeterm + end) rndefs) + end + | _ -> ()) + + | UnsignedExtendHalfword (_, rd, _, _) -> + let rdreg = rd#to_register in + let rdtypevar = mk_reglhs_typevar rdreg faddr iaddr in + begin + (match get_regvar_type_annotation () with + | Some t -> + let opttc = mk_btype_constraint rdtypevar t in + (match opttc with + | Some tc -> + begin + log_type_constraint "UXTH-rvintro" tc; + store#add_constraint tc + end + | _ -> + let opttc = mk_btype_constraint rdtypevar t_short in + (match opttc with + | Some tc -> store#add_constraint tc + | _ -> ()) + ) + | _ -> + let opttc = mk_btype_constraint rdtypevar t_short in + (match opttc with + | Some tc -> store#add_constraint tc + | _ -> ())); + end + | opc -> chlog#add "type constraints not yet implemented" diff --git a/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.mli b/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.mli index 7ba4fbd0..4203a15c 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.mli +++ b/CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.mli @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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/CHB/bchlibarm32/bCHTranslateARMToCHIF.ml b/CodeHawk/CHB/bchlibarm32/bCHTranslateARMToCHIF.ml index df8ebdd0..c215ad06 100644 --- a/CodeHawk/CHB/bchlibarm32/bCHTranslateARMToCHIF.ml +++ b/CodeHawk/CHB/bchlibarm32/bCHTranslateARMToCHIF.ml @@ -33,6 +33,7 @@ open CHLanguage (* chutil *) open CHLogger +open CHTraceResult (* xprlib *) open Xprt @@ -72,6 +73,7 @@ module TR = CHTraceResult let x2p = xpr_formatter#pr_expr let p2s = CHPrettyUtil.pretty_to_string +let x2s x = p2s (x2p x) let log_error (tag: string) (msg: string): tracelogspec_t = mk_tracelog_spec ~tag:("TranslateARMToCHIF:" ^ tag) msg @@ -379,22 +381,28 @@ let make_tests let make_local_tests - (condinstr: arm_assembly_instruction_int) (condloc: location_int) = + (condinstr: arm_assembly_instruction_int) + (condloc: location_int): (cmd_t list * cmd_t list) = let floc = get_floc condloc in let env = floc#f#env in let reqN () = env#mk_num_temp in let reqC i = env#request_num_constant i in - let boolxpr = + let boolxpr_r = match condinstr#get_opcode with | CompareBranchZero (op, _) -> - let x = op#to_expr floc in - XOp (XEq, [x; zero_constant_expr]) + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun x -> XOp (XEq, [x; zero_constant_expr])) + (op#to_expr floc) | CompareBranchNonzero (op, _) -> - let x = op#to_expr floc in - XOp (XNe, [x; zero_constant_expr]) + TR.tmap + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun x -> XOp (XNe, [x; zero_constant_expr])) + (op#to_expr floc) | _ -> - raise (BCH_failure - (LBLOCK [STR "Unexpected condition: "; condinstr#toPretty])) in + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unexpected condition: " ^ (p2s condinstr#toPretty)] in + let convert_to_chif expr = let vars = variables_in_expr expr in let defcmds = floc#get_vardef_commands ~usehigh:vars floc#l#ci in @@ -405,9 +413,17 @@ let make_local_tests let commands = convert_to_chif x in let const_assigns = env#end_transaction in const_assigns @ commands in - let thencode = make_assert boolxpr in - let elsecode = make_assert (simplify_xpr (XOp (XLNot, [boolxpr]))) in - (thencode, elsecode) + TR.tfold + ~ok:(fun boolxpr -> + let thencode = make_assert boolxpr in + let elsecode = make_assert (simplify_xpr (XOp (XLNot, [boolxpr]))) in + (thencode, elsecode)) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + ([SKIP], [SKIP]) + end) + boolxpr_r let make_local_condition @@ -527,7 +543,12 @@ let translate_arm_instruction instruction. *) let floc = get_floc loc in - let pcv = (pc_r RD)#to_variable floc in + let log_dc_error_result (file: string) (line: int) (e: string list) = + if BCHSystemSettings.system_settings#collect_data then + log_error_result ~msg:(p2s floc#l#toPretty) file line e + else + () in + let pcv = TR.tget_ok ((pc_r RD)#to_variable floc) in let iaddr8 = if instr#is_arm32 then (loc#i#add_int 12)#to_numerical @@ -578,7 +599,7 @@ let translate_arm_instruction let get_register_vars (ops: arm_operand_int list) = List.fold_left (fun acc op -> if op#is_register || op#is_extension_register then - (op#to_variable floc) :: acc + (TR.tget_ok (op#to_variable floc)) :: acc else match op#get_kind with | ARMShiftedReg (r, ARMImmSRT _) -> @@ -587,6 +608,8 @@ let translate_arm_instruction let rvar = floc#env#mk_arm_register_variable r in let rsvar = floc#env#mk_arm_register_variable rs in rvar :: rsvar :: acc + | ARMRegBitSequence (r, _, _) -> + (floc#env#mk_arm_register_variable r) :: acc | _ -> acc) [] ops in let get_use_high_vars ?(is_pop=false) (xprs: xpr_t list): variable_t list = @@ -623,14 +646,26 @@ let translate_arm_instruction xprvars in vars @ acc) [] xprs in - let get_addr_use_high_vars (xprs: xpr_t list): variable_t list = + let get_use_high_vars_r + ?(is_pop=false) + (xprrs: xpr_t traceresult list): variable_t list = + let xprs = + List.fold_left (fun acc x_r -> + TR.tfold_default (fun x -> x :: acc) acc x_r) [] xprrs in + get_use_high_vars ~is_pop xprs in + + let get_addr_use_high_vars_r (xprs: xpr_t traceresult list): variable_t list = (* Don't apply invariants to the expressions *) - List.fold_left (fun acc x -> - let xs = simplify_xpr x in - let vars = - List.filter (fun v -> not (floc#f#env#is_function_initial_value v)) - (floc#env#variables_in_expr xs) in - vars @ acc) [] xprs in + List.fold_left (fun acc x_r -> + let x_r = TR.tmap simplify_xpr x_r in + TR.tfold_default + (fun x -> + let vars = + List.filter (fun v -> not (floc#f#env#is_function_initial_value v)) + (floc#env#variables_in_expr x) in + vars @ acc) + acc + x_r) [] xprs in let flagdefs = let flags_set = get_arm_flags_set instr#get_opcode in @@ -642,15 +677,12 @@ let translate_arm_instruction match instr#is_in_aggregate with | Some dw -> (get_aggregate dw)#is_jumptable | _ -> false in - let check_storage (_op: arm_operand_int) (v: variable_t) = - if BCHSystemSettings.system_settings#collect_data then - if (floc#env#is_unknown_memory_variable v) || v#isTemporary then - ch_error_log#add - "unknown storage location" - (LBLOCK [ - floc#l#toPretty; - STR " "; - STR (arm_opcode_to_string instr#get_opcode)]) in + let is_part_of_pseudo_instr () = + match instr#is_in_aggregate with + | Some dw -> + let agg = get_aggregate dw in + agg#is_pseudo_ldrsh || agg#is_pseudo_ldrsb + | _ -> false in let calltgt_cmds (_tgt: arm_operand_int): cmd_t list = let callargs = floc#get_call_arguments in @@ -679,8 +711,15 @@ let translate_arm_instruction else if is_stack_parameter p then let p_offset = TR.tget_ok (get_stack_parameter_offset p) in let stackop = arm_sp_deref ~with_offset:p_offset RD in - let (stacklhs, stacklhscmds) = stackop#to_lhs floc in - (stacklhscmds @ acccmds, stacklhs :: accuse) + TR.tfold + ~ok:(fun (stacklhs, stacklhscmds) -> + (stacklhscmds @ acccmds, stacklhs :: accuse)) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + (acccmds, accuse) + end) + (stackop#to_lhs floc) else raise (BCH_failure @@ -780,7 +819,15 @@ let translate_arm_instruction let thenaddr = (make_i_location loc tgt#get_absolute_address)#ci in let elseaddr = codepc#get_false_branch_successor in let usevars = get_register_vars [op] in - let usehigh = get_use_high_vars [op#to_expr floc] in + let usehigh = + TR.tfold + ~ok:(fun x -> get_use_high_vars [x]) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + [] + end) + (op#to_expr floc) in let defcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in let cmds = cmds @ defcmds @ [invop] in let transaction = package_transaction finfo blocklabel cmds in @@ -795,20 +842,18 @@ let translate_arm_instruction | Branch (_, op, _) | BranchExchange (ACCAlways, op) when op#is_register && op#get_register = ARLR -> - let floc = get_floc loc in let r0_op = arm_register_op AR0 RD in let usevars = get_register_vars [r0_op] in let xr0 = r0_op#to_expr floc in - let usehigh = get_use_high_vars [xr0] in + let usehigh = get_use_high_vars_r [xr0] in let defcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in default defcmds | Branch (_, op, _) | BranchExchange (_, op) when op#is_register -> - let floc = get_floc loc in let usevars = get_register_vars [op] in let xop = op#to_expr floc in - let usehigh = get_use_high_vars [xop] in + let usehigh = get_use_high_vars_r [xop] in let defcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in default defcmds @@ -827,23 +872,25 @@ let translate_arm_instruction * APSR.V = overflow; *------------------------------------------------------------------------- *) | Add (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let usehigh = get_use_high_vars [xrn; xrm] in - let result = XOp (XPlus, [xrn; xrm]) in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let result_r = + TR.tmap2 (fun xrn xrm -> XOp (XPlus, [xrn; xrm])) xrn_r xrm_r in (* let result = floc#inv#rewrite_expr result in let result = simplify_xpr result in *) - let result = - match result with - | XConst (IntConst n) when n#geq numerical_e32 -> - (* Assume unsigned roll-over *) - XConst (IntConst (n#sub numerical_e32)) - | _ -> - result in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg result in + let result_r = + TR.tmap (fun result -> + match result with + | XConst (IntConst n) when n#geq numerical_e32 -> + (* Assume unsigned roll-over *) + XConst (IntConst (n#sub numerical_e32)) + | _ -> + result) result_r in + let cmds = floc#get_assign_commands_r lhs_r result_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -870,13 +917,13 @@ let translate_arm_instruction * APSR.V = overflow; * ------------------------------------------------------------------------ *) | AddCarry (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap (fun (v, _) -> v) (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -889,29 +936,35 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | Adr (c, rd, src) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let rhs = src#to_expr floc in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg rhs in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let rhs_r = src#to_expr floc in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) + | ArithmeticShiftRight _ when is_part_of_pseudo_instr () -> + default [] + | ArithmeticShiftRight(_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let asrr = - match xrm with - | XConst (IntConst n) when n#toInt = 2-> - XOp (XDiv, [xrn; XConst (IntConst (mkNumerical 4))]) - | _ -> XOp (XAsr, [xrn; xrm]) in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = + TR.tmap2 + (fun xrn xrm -> + match xrm with + | XConst (IntConst n) when n#toInt = 2-> + XOp (XDiv, [xrn; XConst (IntConst (mkNumerical 4))]) + | _ -> XOp (XAsr, [xrn; xrm])) + xrn_r xrm_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_int asrr in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -924,47 +977,53 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | BitFieldClear (_, rd, _, _, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrd = rd#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + | BitFieldClear (c, rd, _, _, _) -> + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let rhs_r = rd#to_expr floc in let usevars = get_register_vars [rd] in - let usehigh = get_use_high_vars [xrd] in + let usehigh = get_use_high_vars_r [rhs_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in - default (defcmds @ cmds) + let cmds = defcmds @ cmds in + (match c with + | ACCAlways -> default cmds + | _ -> make_conditional_commands c cmds) - | BitFieldInsert (_, rd, rn, _, _, _) -> - let floc = get_floc loc in - (* let vrd = rd#to_variable floc in *) - let rdreg = rd#to_register in - let xrd = rd#to_expr floc in - let xrn = rn#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + | BitFieldInsert (c, rd, rn, _, _, _) -> + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrd_r = rd#to_expr floc in + let xrn_r = rn#to_expr floc in let usevars = get_register_vars [rd; rn] in - let usehigh = get_use_high_vars [xrd; xrn] in + let usehigh = get_use_high_vars_r [xrd_r; xrn_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in - default (defcmds @ cmds) + let cmds = defcmds @ cmds in + (match c with + | ACCAlways -> default cmds + | _ -> make_conditional_commands c cmds) | BitwiseAnd (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBAnd, [xrn; xrm]) in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_uint result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = + TR.tmap2 (fun xrn xrm -> XOp (XBAnd, [xrn; xrm])) xrn_r xrm_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -978,14 +1037,17 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | BitwiseBitClear (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XBAnd, [xrn; XOp (XBNot, [xrm])]) in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_uint result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = + TR.tmap2 + (fun xrn xrm -> XOp (XBAnd, [xrn; XOp (XBNot, [xrm])])) + xrn_r xrm_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -999,13 +1061,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | BitwiseExclusiveOr (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1034,19 +1096,25 @@ let translate_arm_instruction * APSR.C = carry; * ------------------------------------------------------------------------ *) | BitwiseNot (_, c, rd, rm, _) when rm#is_immediate -> - let floc = get_floc loc in - let rhs = rm#to_expr floc in - let notrhs = - match rhs with - | XConst (IntConst n) when n#equal numerical_zero -> - XConst (IntConst numerical_one#neg) - | XConst (IntConst n) -> - XConst (IntConst ((nume32#sub n)#sub numerical_one)) - | _ -> XConst XRandom in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_uint notrhs in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let rhs_r = rm#to_expr floc in + let rhs_r = + TR.tbind + ~msg:(__FILE__ ^ ":" ^ (string_of_int __LINE__)) + (fun rhs -> + match rhs with + | XConst (IntConst n) when n#equal numerical_zero -> + Ok (XConst (IntConst numerical_one#neg)) + | XConst (IntConst n) -> + Ok (XConst (IntConst ((nume32#sub n)#sub numerical_one))) + | _ -> + Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": " + ^ "Unable to invert " ^ (x2s rhs)]) + rhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [rhs] in + let usehigh = get_use_high_vars_r [rhs_r] in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1059,12 +1127,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | BitwiseNot (_, c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let rhs = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let rhs_r = rm#to_expr floc in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [rhs] in + let usehigh = get_use_high_vars_r [rhs_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1077,13 +1145,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | BitwiseOr (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1096,13 +1164,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | BitwiseOrNot (_, c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1138,7 +1206,6 @@ let translate_arm_instruction | BranchLink (c,_) | BranchLinkExchange (c, _) -> - let floc = get_floc loc in let vr0 = floc#f#env#mk_arm_register_variable AR0 in let vr1 = floc#f#env#mk_arm_register_variable AR1 in let vr2 = floc#f#env#mk_arm_register_variable AR2 in @@ -1160,12 +1227,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | ByteReverseWord (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1188,12 +1255,12 @@ let translate_arm_instruction * R[d] = result; * ------------------------------------------------------------------------ *) | ByteReversePackedHalfword (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1206,14 +1273,10 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | Compare (c, rn, rm, _) -> - let floc = get_floc loc in - let _ = floc#inv#rewrite_expr (rn#to_expr floc) in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xresult = XOp (XMinus, [xrn; xrm]) in - let xresult = rewrite_expr floc xresult in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xresult] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~use:usevars @@ -1225,12 +1288,10 @@ let translate_arm_instruction | _ -> make_conditional_commands c defcmds) | CompareNegative (c, rn, rm) -> - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xresult = XOp (XPlus, [xrn; xrm]) in - let xresult = rewrite_expr floc xresult in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xresult] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~use:usevars @@ -1242,12 +1303,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c defcmds) | CountLeadingZeros (c, rd, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1263,7 +1324,6 @@ let translate_arm_instruction default [] | IfThen _ when instr#is_aggregate_anchor -> - let floc = get_floc loc in if finfo#has_associated_cc_setter ctxtiaddr then let testiaddr = finfo#get_associated_cc_setter ctxtiaddr in let testloc = ctxt_string_to_location faddr testiaddr in @@ -1287,28 +1347,36 @@ let translate_arm_instruction match optpredicate with | Some p -> let p = if inverse then XOp (XLNot, [p]) else p in - let rdreg = dstop#to_register in - let (lhs, cmds) = floc#get_ssa_assign_commands rdreg p in + let vrd = floc#env#mk_register_variable dstop#to_register in + let lhs_r = TR.tmap fst (dstop#to_lhs floc) in let usevars = vars_in_expr_list [p] in let usehigh = get_use_high_vars [p] in + let cmds = floc#get_assign_commands_r lhs_r (Ok p) in let defcmds = floc#get_vardef_commands - ~defs:[lhs] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ~flagdefs:flagdefs ctxtiaddr in defcmds @ cmds | _ -> - [] in + begin + log_error_result + ~tag:"IfThen" + __FILE__ __LINE__ + ["Predicate assignment without predicate"]; + [] + end in default cmds) else - let _ = - if collect_diagnostics () then - ch_diagnostics_log#add - "aggregate without ite predicate" - (LBLOCK [loc#toPretty; STR ": "; instr#toPretty]) in - default [] + begin + log_error_result + ~tag:"IfThen" + __FILE__ __LINE__ + ["Aggregate IfThen without associated cc setter"]; + default [] + end | IfThen _ when instr#is_block_condition -> let thenaddr = codepc#get_true_branch_successor in @@ -1358,7 +1426,6 @@ let translate_arm_instruction * R[n] = R[n] - 4 * BitCount(registers); * ---------------------------------------------------------------------- *) | LoadMultipleDecrementAfter (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let usevars = get_register_vars [base] in let regcount = rl#get_register_count in @@ -1367,16 +1434,13 @@ let translate_arm_instruction let (memreads, _) = List.fold_left (fun (acc, off) reg -> + let regvar = floc#env#mk_register_variable reg in let memop = arm_reg_deref basereg ~with_offset:off RD in - let memvar = memop#to_variable floc in - let memrhs = memop#to_expr floc in - let (regvar, cmds1) = floc#get_ssa_assign_commands reg memrhs in - let memuse = - if floc#env#is_unknown_memory_variable memvar then - [] - else - [memvar] in - let memusehigh = get_use_high_vars [memrhs] in + let memvar_r = memop#to_variable floc in + let memrhs_r = memop#to_expr floc in + let memuse = TR.tfold_default (fun memvar -> [memvar]) [] memvar_r in + let memusehigh = get_use_high_vars_r [memrhs_r] in + let cmds1 = floc#get_assign_commands_r memvar_r memrhs_r in let defcmds1 = floc#get_vardef_commands ~defs:[regvar] @@ -1386,12 +1450,11 @@ let translate_arm_instruction (acc @ defcmds1 @ cmds1, off + 4)) ([], 4 - (4 * regcount)) regs in let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let decrem = int_constant_expr (4 * regcount) in - let newrhs = XOp (XMinus, [rhs; decrem]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XMinus, [rhs; decrem])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let wbackdefcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in wbackdefcmds @ wbackcmds else @@ -1418,7 +1481,6 @@ let translate_arm_instruction * R[n] = R[n] - 4 * BitCount(registers); * ---------------------------------------------------------------------- *) | LoadMultipleDecrementBefore (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let usevars = get_register_vars [base] in let regcount = rl#get_register_count in @@ -1427,31 +1489,27 @@ let translate_arm_instruction let (memreads, _) = List.fold_left (fun (acc, off) reg -> + let regvar = floc#env#mk_register_variable reg in let memop = arm_reg_deref basereg ~with_offset:off RD in - let memvar = memop#to_variable floc in - let memrhs = memop#to_expr floc in - let (reglhs, cmds1) = floc#get_ssa_assign_commands reg memrhs in - let memuse = - if floc#env#is_unknown_memory_variable memvar then - [] - else - [memvar] in - let memusehigh = get_use_high_vars [memrhs] in + let memvar_r = memop#to_variable floc in + let memrhs_r = memop#to_expr floc in + let memuse = TR.tfold_default (fun memvar -> [memvar]) [] memvar_r in + let memusehigh = get_use_high_vars_r [memrhs_r] in + let cmds1 = floc#get_assign_commands_r memvar_r memrhs_r in let defcmds1 = floc#get_vardef_commands - ~defs:[reglhs] + ~defs:[regvar] ~use:memuse ~usehigh:memusehigh ctxtiaddr in (acc @ defcmds1 @ cmds1, off + 4)) ([], -(4 * regcount)) regs in let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let decrem = int_constant_expr (4 * regcount) in - let newrhs = XOp (XMinus, [rhs; decrem]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XMinus, [rhs; decrem])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let defwbackcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in defwbackcmds @ wbackcmds else @@ -1478,7 +1536,6 @@ let translate_arm_instruction * R[n] = R[n] + + 4 * BitCount(registers); * ---------------------------------------------------------------------- *) | LoadMultipleIncrementAfter (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let usevars = get_register_vars [base] in let regcount = rl#get_register_count in @@ -1487,31 +1544,27 @@ let translate_arm_instruction let (memreads, _) = List.fold_left (fun (acc, off) reg -> + let regvar = floc#env#mk_register_variable reg in let memop = arm_reg_deref ~with_offset:off basereg RD in - let memvar = memop#to_variable floc in - let memrhs = memop#to_expr floc in - let (reglhs, cmds1) = floc#get_ssa_assign_commands reg memrhs in - let memuse = - if floc#f#env#is_unknown_memory_variable memvar then - [] - else - [memvar] in - let memusehigh = get_use_high_vars [memrhs] in + let memvar_r = memop#to_variable floc in + let memrhs_r = memop#to_expr floc in + let memuse = TR.tfold_default (fun memvar -> [memvar]) [] memvar_r in + let memusehigh = get_use_high_vars_r [memrhs_r] in + let cmds1 = floc#get_assign_commands_r memvar_r memrhs_r in let defcmds1 = floc#get_vardef_commands - ~defs:[reglhs] + ~defs:[regvar] ~use:memuse ~usehigh:memusehigh ctxtiaddr in (acc @ defcmds1 @ cmds1, off + 4)) ([], 0) regs in let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let increm = int_constant_expr (4 * regcount) in - let newrhs = XOp (XPlus, [rhs; increm]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XPlus, [rhs; increm])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let defwbackcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in defwbackcmds @ wbackcmds else @@ -1538,7 +1591,6 @@ let translate_arm_instruction * R[n] = R[n] + 4 * BitCount(registers) * ---------------------------------------------------------------------- *) | LoadMultipleIncrementBefore (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let usevars = get_register_vars [base] in let regcount = rl#get_register_count in @@ -1547,31 +1599,27 @@ let translate_arm_instruction let (memreads, _) = List.fold_left (fun (acc, off) reg -> + let regvar = floc#env#mk_register_variable reg in let memop = arm_reg_deref ~with_offset:off basereg RD in - let memvar = memop#to_variable floc in - let memrhs = memop#to_expr floc in - let (reglhs, cmds1) = floc#get_ssa_assign_commands reg memrhs in - let memuse = - if floc#f#env#is_unknown_memory_variable memvar then - [] - else - [memvar] in - let memusehigh = get_use_high_vars [memrhs] in + let memvar_r = memop#to_variable floc in + let memrhs_r = memop#to_expr floc in + let memuse = TR.tfold_default (fun memvar -> [memvar]) [] memvar_r in + let memusehigh = get_use_high_vars_r [memrhs_r] in + let cmds1 = floc#get_assign_commands_r memvar_r memrhs_r in let defcmds1 = floc#get_vardef_commands - ~defs:[reglhs] + ~defs:[regvar] ~use:memuse ~usehigh:memusehigh ctxtiaddr in (acc @ defcmds1 @ cmds1, off + 4)) ([], 4) regs in let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let increm = int_constant_expr (4 * regcount) in - let newrhs = XOp (XPlus, [rhs; increm]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XPlus, [rhs; increm])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let defwbackcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in defwbackcmds @ wbackcmds else @@ -1598,62 +1646,69 @@ let translate_arm_instruction * R[t] = ROR(data, 8*UInt(address<1:0>)); * ------------------------------------------------------------------------ *) | LoadRegister (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let rhs = mem#to_expr floc in - let rtreg = rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDR")) - (fun (_, addr) -> - let basereg = rn#to_register in - let (baselhs, ucmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in - defupdatecmds @ ucmds) - [] - addr_r + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds else [] in - let (lhs, cmds) = floc#get_ssa_assign_commands rtreg rhs in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let cmds = cmds @ updatecmds in let usevars = get_register_vars [rn; rm] in - let memvar = mem#to_variable floc in + let memvar_r = mem#to_variable floc in let (usevars, usehigh) = - if memvar#isTmp - || floc#f#env#is_unknown_memory_variable memvar - || floc#f#env#has_variable_index_offset memvar then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (usevars, get_use_high_vars [xrn; xrm]) - else - (memvar :: usevars, get_use_high_vars [rhs]) in + TR.tfold + ~error:(fun _ -> + (* elevate address variables to high-use *) + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r])) + ~ok:(fun memvar -> + if floc#env#has_variable_index_offset memvar then + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r]) + else + (memvar :: usevars, get_use_high_vars_r [rhs_r])) + memvar_r in let defcmds = floc#get_vardef_commands - ~defs:[lhs] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in let cmds = defcmds @ cmds in let _ = - (* record register restore *) - let rhs = rewrite_expr floc rhs in - match rhs with - | XVar rhsvar -> - if floc#f#env#is_initial_register_value rhsvar then - let memreg = - TR.tget_ok (floc#f#env#get_initial_register_value_register rhsvar) in - match memreg with - | ARMRegister r when r = rt#get_register -> - let memaddr = mem#to_address floc in - let memaddr = floc#inv#rewrite_expr memaddr in - finfo#restore_register memaddr floc#cia rt#to_register - | _ -> () - else - () - | _ -> () in + TR.tfold_default + (fun rhs -> + (* record register restore *) + let rhs = rewrite_expr floc rhs in + match rhs with + | XVar rhsvar -> + if floc#f#env#is_initial_register_value rhsvar then + let memreg = + TR.tget_ok + (floc#f#env#get_initial_register_value_register rhsvar) in + match memreg with + | ARMRegister r when r = rt#get_register -> + TR.tfold_default + (fun memaddr -> + let memaddr = floc#inv#rewrite_expr memaddr in + finfo#restore_register memaddr floc#cia rt#to_register) + () + (mem#to_address floc) + | _ -> () + else + () + | _ -> ()) + () + rhs_r in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) @@ -1663,116 +1718,119 @@ let translate_arm_instruction * if wback then R[n] = offset_addr; * -------------------------------------------------------------------------*) | LoadRegisterByte (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let rhs = XOp (XXlsb, [mem#to_expr floc]) in - let rtreg = rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRB")) - (fun (_, addr) -> - let basereg = rn#to_register in - let (baselhs, ucmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in - defupdatecmds @ ucmds) - [] - addr_r + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds else [] in - let vtype = t_uchar in - let (lhs, cmds) = floc#get_ssa_assign_commands rtreg ~vtype rhs in + let cmds = floc#get_assign_commands_r ~size:1 lhs_r rhs_r in let cmds = cmds @ updatecmds in let usevars = get_register_vars [rn; rm] in - let memvar = mem#to_variable floc in + let memvar_r = mem#to_variable floc in let (usevars, usehigh) = - if memvar#isTmp || floc#f#env#is_unknown_memory_variable memvar then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (usevars, get_use_high_vars [xrn; xrm]) - else - (memvar :: usevars, get_use_high_vars [rhs]) in + TR.tfold + ~error:(fun _ -> + (* elevate address variables to high-use *) + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r])) + ~ok:(fun memvar -> + (memvar :: usevars, get_use_high_vars_r [rhs_r])) + memvar_r in let defcmds = floc#get_vardef_commands - ~defs:[lhs] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in - let cmds = defcmds @ cmds in + let cmds = defcmds @ cmds @ updatecmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | LoadRegisterDual (c, rt, rt2, rn, rm, mem, mem2) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let rt2reg = rt2#to_register in - let memvar1 = mem#to_variable floc in - let memvar2 = mem2#to_variable floc in - let rhs1 = mem#to_expr floc in - let rhs2 = mem2#to_expr floc in - let (vrt, cmds1) = floc#get_ssa_assign_commands rtreg rhs1 in - let (vrt2, cmds2) = floc#get_ssa_assign_commands rt2reg rhs2 in + let lhs1_r = TR.tmap fst (rt#to_lhs floc) in + let lhs2_r = TR.tmap fst (rt2#to_lhs floc) in + let vrd1 = floc#env#mk_register_variable rt#to_register in + let vrd2 = floc#env#mk_register_variable rt2#to_register in + let updatecmds = + if mem#is_offset_address_writeback then + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds + else + [] in + let memvar1_r = mem#to_variable floc in + let memvar2_r = mem2#to_variable floc in + let rhs1_r = mem#to_expr floc in + let rhs2_r = mem2#to_expr floc in + let cmds1 = floc#get_assign_commands_r lhs1_r rhs1_r in + let cmds2 = floc#get_assign_commands_r lhs2_r rhs2_r in let usevars = get_register_vars [rn; rm] in let usevars = - if floc#f#env#is_unknown_memory_variable memvar1 then - usevars - else - memvar1 :: usevars in + TR.tfold_default (fun memvar1 -> memvar1 :: usevars) usevars memvar1_r in let usevars = - if floc#f#env#is_unknown_memory_variable memvar2 then - usevars - else - memvar2 :: usevars in - let usehigh = get_use_high_vars [rhs1; rhs2] in + TR.tfold_default (fun memvar2 -> memvar2 :: usevars) usevars memvar2_r in + let usehigh = get_use_high_vars_r [rhs1_r; rhs2_r] in let defcmds = floc#get_vardef_commands - ~defs:[vrt; vrt2] + ~defs:[vrd1; vrd2] ~use:usevars ~usehigh:usehigh ctxtiaddr in - let cmds = defcmds @ cmds1 @ cmds2 in + let cmds = defcmds @ cmds1 @ cmds2 @ updatecmds in let _ = (* record register restores *) - List.iter (fun ((xrt, xmem): (arm_operand_int * arm_operand_int)) -> - let x = rewrite_expr floc (xmem#to_expr floc) in - match x with - | XVar xvar -> - if floc#f#env#is_initial_register_value xvar then - let xreg = - TR.tget_ok - (floc#f#env#get_initial_register_value_register xvar) in - match xreg with - | ARMRegister r when r = xrt#get_register -> - let xmemaddr = xmem#to_address floc in - let xmemaddr = floc#inv#rewrite_expr xmemaddr in - finfo#restore_register xmemaddr floc#cia xrt#to_register - | _ -> () - else - () - | _ -> ()) [(rt, mem); (rt2, mem2)] in + List.iter (fun (rt, mem, rhs_r) -> + TR.tfold_default + (fun rhs -> + let rhs = rewrite_expr floc rhs in + match rhs with + | XVar rhsvar -> + if floc#f#env#is_initial_register_value rhsvar then + let memreg = + TR.tget_ok + (floc#f#env#get_initial_register_value_register rhsvar) in + match memreg with + | ARMRegister r when r = rt#get_register -> + TR.tfold_default + (fun memaddr -> + let memaddr = floc#inv#rewrite_expr memaddr in + finfo#restore_register memaddr floc#cia rt#to_register) + () + (mem#to_address floc) + | _ -> () + else + () + | _ -> ()) + () + rhs_r) [(rt, mem, rhs1_r); (rt2, mem2, rhs2_r)] in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | LoadRegisterExclusive (c, rt, rn, rm, mem) -> - let floc = get_floc loc in - let memvar = mem#to_variable floc in - let rhs = mem#to_expr floc in - let rtreg = rt#to_register in - let (vrt, cmds) = floc#get_ssa_assign_commands rtreg rhs in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in + let memvar_r = mem#to_variable floc in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm] in let usevars = - if floc#f#env#is_unknown_memory_variable memvar then - usevars - else - memvar :: usevars in - let usehigh = get_use_high_vars [rhs] in + TR.tfold_default (fun memvar -> memvar :: usevars) usevars memvar_r in + let usehigh = get_use_high_vars_r [rhs_r] in let defcmds = floc#get_vardef_commands - ~defs:[vrt] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in @@ -1782,106 +1840,108 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | LoadRegisterHalfword (c, rt, rn,rm, mem, _) -> - let floc = get_floc loc in - let memvar = mem#to_variable floc in - let rhs = mem#to_expr floc in - let rtreg = rt#to_register in - let vtype = t_ushort in - let (vrt, cmds) = floc#get_ssa_assign_commands rtreg ~vtype rhs in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in + let updatecmds = + if mem#is_offset_address_writeback then + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds + else + [] in + let cmds = floc#get_assign_commands_r ~size:2 lhs_r rhs_r in + let memvar_r = mem#to_variable floc in let usevars = get_register_vars [rn; rm] in let (usevars, usehigh) = - if memvar#isTmp || floc#f#env#is_unknown_memory_variable memvar then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (usevars, get_use_high_vars [xrn; xrm]) - else - (memvar :: usevars, get_use_high_vars [rhs]) in + TR.tfold + ~error:(fun _ -> + (* elevate address variables to high-use *) + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r])) + ~ok:(fun memvar -> + (memvar :: usevars, get_use_high_vars_r [rhs_r])) + memvar_r in let defcmds = floc#get_vardef_commands - ~defs:[vrt] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in - let cmds = defcmds @ cmds in + let cmds = defcmds @ cmds @ updatecmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | LoadRegisterSignedHalfword (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let memvar = mem#to_variable floc in - let rhs = mem#to_expr floc in - let rtreg = rt#to_register in - let usevars = get_register_vars [rn; rm] in - let usevars = - if floc#f#env#is_unknown_memory_variable memvar then - usevars + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in + let updatecmds = + if mem#is_offset_address_writeback then + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds else - memvar :: usevars in - let usehigh = get_use_high_vars [rhs] in - let is_external v = floc#env#is_function_initial_value v in - let rec is_symbolic_expr x = - match x with - | XOp (_, l) -> List.for_all is_symbolic_expr l - | XVar v -> is_external v - | XConst _ -> true - | XAttr _ -> false in - let vtype = t_short in - let (vrt, cmds) = - (match rhs with - | XConst (IntConst n) when n#toInt > e15 -> - let rhs = XOp (XPlus, [rhs; int_constant_expr (e32-e16)]) in - floc#get_ssa_assign_commands rtreg ~vtype rhs - | _ -> - if is_symbolic_expr rhs then - let rhs = floc#env#mk_signed_symbolic_value rhs 16 32 in - floc#get_ssa_assign_commands rtreg ~vtype (XVar rhs) - else - floc#get_ssa_abstract_commands rtreg ()) in + [] in + let cmds = floc#get_assign_commands_r ~size:2 ~signed:true lhs_r rhs_r in + let memvar_r = mem#to_variable floc in + let usevars = get_register_vars [rn; rm] in + let (usevars, usehigh) = + TR.tfold + ~error:(fun _ -> + (* elevate address variables to high-use *) + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r])) + ~ok:(fun memvar -> + (memvar :: usevars, get_use_high_vars_r [rhs_r])) + memvar_r in let defcmds = floc#get_vardef_commands - ~defs:[vrt] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in - let cmds = defcmds @ cmds in + let cmds = defcmds @ cmds @ updatecmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | LoadRegisterSignedByte (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let memvar = mem#to_variable floc in - let rhs = mem#to_expr floc in - let rtreg = rt#to_register in - let vtype = t_char in - let (vrt, cmds) = floc#get_ssa_assign_commands rtreg ~vtype rhs in - let usevars = get_register_vars [rn; rm] in - let usevars = - if floc#f#env#is_unknown_memory_variable memvar then - usevars - else - memvar :: usevars in - let usehigh = get_use_high_vars [rhs] in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let rhs_r = mem#to_expr floc in + let vrd = floc#env#mk_register_variable rt#to_register in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": LDRSB")) - (fun (_, addr) -> - let basereg = rn#to_register in - let (baselhs, ucmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in - defupdatecmds @ ucmds) - [] - addr_r + let baselhs = floc#env#mk_register_variable rn#to_register in + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let ucmds = floc#get_assign_commands_r (Ok baselhs) addr_r in + let defupdatecmds = floc#get_vardef_commands ~defs:[baselhs] ctxtiaddr in + defupdatecmds @ ucmds else [] in + let cmds = floc#get_assign_commands_r ~size:1 ~signed:true lhs_r rhs_r in + let memvar_r = mem#to_variable floc in + let usevars = get_register_vars [rn; rm] in + let (usevars, usehigh) = + TR.tfold + ~error:(fun _ -> + (* elevate address variables to high-use *) + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + (usevars, get_use_high_vars_r [xrn_r; xrm_r])) + ~ok:(fun memvar -> + (memvar :: usevars, get_use_high_vars_r [rhs_r])) + memvar_r in let defcmds = floc#get_vardef_commands - ~defs:[vrt] + ~defs:[vrd] ~use:usevars ~usehigh:usehigh ctxtiaddr in @@ -1890,11 +1950,14 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) + | LogicalShiftLeft _ when is_part_of_pseudo_instr () -> + default [] + | LogicalShiftLeft (_, c, rd, rn, rm, _) when rm#is_small_immediate -> - let floc = get_floc loc in - let vrd = rd#to_register in - let xrn = rn#to_expr floc in - let xxrn = rewrite_expr floc xrn in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xxrn_r = TR.tmap (rewrite_expr floc) xrn_r in let m = rm#to_numerical#toInt in let factor = match m with | 0 -> 1 @@ -1904,9 +1967,12 @@ let translate_arm_instruction | 4 -> 16 | _ -> 1 in (* not reachable by small immediate *) let usevars = get_register_vars [rn] in - let usehigh = get_use_high_vars [xxrn] in - let result = XOp (XMult, [xxrn; int_constant_expr factor]) in - let (vrd, cmds) = floc#get_ssa_assign_commands vrd ~vtype:t_uint result in + let usehigh = get_use_high_vars_r [xxrn_r] in + let rhs_r = + TR.tmap + (fun xxrn -> XOp (XMult, [xxrn; int_constant_expr factor])) + xxrn_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1920,14 +1986,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | LogicalShiftLeft (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let vrd = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let result = XOp (XLsl, [xrn; xrm]) in - let (vrd, cmds) = floc#get_ssa_assign_commands vrd ~vtype:t_uint result in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XLsl, [xrn; xrm])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1941,14 +2007,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | LogicalShiftRight (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let vrd = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XLsr, [xrn; xrm]) in - let (vrd, cmds) = floc#get_ssa_assign_commands vrd result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XLsr, [xrn; xrm])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -1971,12 +2037,55 @@ let translate_arm_instruction * APSR.N = result<31>; * APSR.Z = IsZeroBit(result); * ------------------------------------------------------------------------ *) + | Move _ when instr#is_aggregate_anchor -> + let floc = get_floc loc in + if finfo#has_associated_cc_setter ctxtiaddr then + let testiaddr = finfo#get_associated_cc_setter ctxtiaddr in + let testloc = ctxt_string_to_location faddr testiaddr in + let testaddr = testloc#i in + let testinstr = + fail_tvalue + (trerror_record + (LBLOCK [STR "Translate MOV predicate assignment"; STR ctxtiaddr])) + (get_arm_assembly_instruction testaddr) in + let movagg = get_aggregate loc#i in + (match movagg#kind with + | ARMPredicateAssignment (inverse, dstop) -> + let (_, optpredicate, _) = + make_conditional_predicate + ~condinstr:instr + ~testinstr:testinstr + ~condloc:loc + ~testloc:testloc in + let cmds = + match optpredicate with + | Some p -> + let p = if inverse then XOp (XLNot, [p]) else p in + let lhs_r = TR.tmap fst (dstop#to_lhs floc) in + let cmds = floc#get_assign_commands_r lhs_r (Ok p) in + let vrd = floc#env#mk_register_variable dstop#to_register in + let usevars = vars_in_expr_list [p] in + let usehigh = get_use_high_vars [p] in + let defcmds = + floc#get_vardef_commands + ~defs:[vrd] + ~use:usevars + ~usehigh + ~flagdefs + ctxtiaddr in + defcmds @ cmds + | _ -> + [] in + default cmds + | _ -> default []) + else + let _ = + chlog#add + "predicate assignment aggregate without predicate" + (LBLOCK [loc#toPretty; STR ": "; instr#toPretty]) in + default [] + | Move _ when Option.is_some instr#is_in_aggregate -> - let _ = - if collect_diagnostics () then - ch_diagnostics_log#add - "instr part of aggregate" - (LBLOCK [(get_floc loc)#l#toPretty; STR ": "; instr#toPretty]) in default [] (* Preempt spurious reaching definitions by vacuous assignment *) @@ -1985,13 +2094,13 @@ let translate_arm_instruction default [] | Move (_, c, rd, rm, _, _) -> - let floc = get_floc loc in - let vrd = rd#to_register in - let xrm = rm#to_expr floc in - let xxrm = floc#inv#rewrite_expr xrm in - let (vrd, cmds) = floc#get_ssa_assign_commands vrd xrm in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap floc#inv#rewrite_expr xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xxrm] in + let usehigh = get_use_high_vars_r [rhs_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2004,12 +2113,15 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | MoveRegisterCoprocessor (_, _, _, rt, _, _, _) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let (vrt, cmds) = floc#get_ssa_abstract_commands rtreg () in - let defcmds = floc#get_vardef_commands ~defs:[vrt] ctxtiaddr in - default (defcmds @ cmds) + | MoveRegisterCoprocessor (c, _, _, rt, _, _, _) -> + let vrd = floc#env#mk_register_variable rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let cmds = floc#get_abstract_commands_r lhs_r in + let defcmds = floc#get_vardef_commands ~defs:[vrd] ctxtiaddr in + let cmds = defcmds @ cmds in + (match c with + | ACCAlways -> default cmds + | _ -> make_conditional_commands c cmds) | MoveToCoprocessor _ -> default [] @@ -2018,17 +2130,20 @@ let translate_arm_instruction * // R[d]<15:0> unchanged * ------------------------------------------------------------------------ *) | MoveTop (c, rd, imm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrd = rd#to_expr floc in - let xrd = rewrite_expr floc xrd in - let imm16 = imm#to_expr floc in - let ximm16 = XOp (XMult, [imm16; int_constant_expr e16]) in - let xrdm16 = XOp (XXlsh, [xrd]) in - let rhsxpr = XOp (XPlus, [xrdm16; ximm16]) in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg rhsxpr in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrd_r = rd#to_expr floc in + let xrd_r = TR.tmap (rewrite_expr floc) xrd_r in + let imm16_r = imm#to_expr floc in + let ximm16_r = + TR.tmap + (fun imm16 -> XOp (XMult, [imm16; int_constant_expr e16])) imm16_r in + let rhs_r = TR.tmap (fun xrd -> XOp (XXlsh, [xrd])) xrd_r in + let rhs_r = + TR.tmap2 (fun rhs ximm16 -> XOp (XPlus, [rhs; ximm16])) rhs_r ximm16_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rd] in - let usehigh = get_use_high_vars [xrd] in + let usehigh = get_use_high_vars_r [xrd_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2041,24 +2156,25 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | MoveTwoRegisterCoprocessor (c, _, _, rt, rt2, _) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let rt2reg = rt2#to_register in - let (vrt, cmds1) = floc#get_ssa_abstract_commands rtreg () in - let (vrt2, cmds2) = floc#get_ssa_abstract_commands rt2reg () in - let defcmds = floc#get_vardef_commands ~defs:[vrt; vrt2] ctxtiaddr in + let lhs1_r = TR.tmap fst (rt#to_lhs floc) in + let lhs2_r = TR.tmap fst (rt2#to_lhs floc) in + let vrd1 = floc#env#mk_register_variable rt#to_register in + let vrd2 = floc#env#mk_register_variable rt2#to_register in + let cmds1 = floc#get_abstract_commands_r lhs1_r in + let cmds2 = floc#get_abstract_commands_r lhs2_r in + let defcmds = floc#get_vardef_commands ~defs:[vrd1; vrd2] ctxtiaddr in let cmds = defcmds @ cmds1 @ cmds2 in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | Multiply (_, c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let result = XOp (XMult, [rhs1; rhs2]) in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XMult, [xrn; xrm])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ctxtiaddr in let cmds = defcmds @ cmds in (match c with @@ -2066,16 +2182,17 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | MultiplyAccumulate (_, c, rd, rn, rm, ra) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let rhsa = ra#to_expr floc in - let result = XOp (XPlus, [XOp (XMult, [rhs1; rhs2]); rhsa]) in - let (vrd, cmds) = - floc#get_ssa_assign_commands rdreg ~vtype:t_unknown_int result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xra_r = ra#to_expr floc in + let rhs_r = + TR.tmap3 (fun xrn xrm xra -> + XOp (XPlus, [XOp (XMult, [xrn; xrm]); xra])) xrn_r xrm_r xra_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm; ra] in - let usehigh = get_use_high_vars [rhs1; rhs2; rhsa] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r; xra_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2089,16 +2206,17 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | MultiplySubtract (c, rd, rn, rm, ra) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let rhs1 = rn#to_expr floc in - let rhs2 = rm#to_expr floc in - let rhsa = ra#to_expr floc in - let result = XOp (XMinus, [rhsa; XOp (XMult, [rhs1; rhs2])]) in - let (vrd, cmds) = - floc#get_ssa_assign_commands rdreg ~vtype:t_unknown_int result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xra_r = ra#to_expr floc in + let rhs_r = + TR.tmap3 (fun xrn xrm xra -> + XOp (XMinus, [xra; XOp (XMult, [xrn; xrm])])) xrn_r xrm_r xra_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm; ra] in - let usehigh = get_use_high_vars [rhs1; rhs2; rhsa] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r; xra_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2138,51 +2256,67 @@ let translate_arm_instruction let floc = get_floc loc in let regcount = rl#get_register_count in - let popcmds () = - let sprhs = sp#to_expr floc in + let popcmds (): cmd_t list = + let sprhs_r = sp#to_expr floc in let regs = rl#to_multiple_register in let (stackops, _) = List.fold_left (fun (acc, off) reg -> - let (splhs, splhscmds) = (sp_r RD)#to_lhs floc in + let reglhs = floc#env#mk_register_variable reg in + let splhs = floc#env#mk_register_variable sp#to_register in let stackop = arm_sp_deref ~with_offset:off RD in - let stackvar = stackop#to_variable floc in - let stackrhs = stackop#to_expr floc in - let (regvar, cmds1) = floc#get_ssa_assign_commands reg stackrhs in - let usehigh = get_use_high_vars ~is_pop:true [stackrhs] in + let stackvar_r = stackop#to_variable floc in + let stackrhs_r = stackop#to_expr floc in + let cmds1 = floc#get_assign_commands_r (Ok reglhs) stackrhs_r in + let usevars = + TR.tfold_default (fun stackvar -> [stackvar]) [] stackvar_r in + let usehigh = get_use_high_vars_r ~is_pop:true [stackrhs_r] in let defcmds1 = floc#get_vardef_commands - ~defs:[regvar; splhs] - ~use:[stackvar] + ~defs:[reglhs; splhs] + ~use:usevars ~usehigh:usehigh ctxtiaddr in let _ = (* record register restore *) - let xrhs = rewrite_expr floc stackrhs in - match xrhs with - | XVar xvar -> - if floc#f#env#is_initial_register_value xvar then - let xreg = - TR.tget_ok - (floc#f#env#get_initial_register_value_register xvar) in - match (xreg, reg) with - | (ARMRegister r, ARMRegister g) when r = g -> - let xmemaddr = stackop#to_address floc in - let xmemaddr = floc#inv#rewrite_expr xmemaddr in - finfo#restore_register xmemaddr floc#cia reg - | (ARMRegister r, ARMRegister g) when r = ARLR && g = ARPC -> - let xmemaddr = stackop#to_address floc in - let xmemaddr = floc#inv#rewrite_expr xmemaddr in - finfo#restore_register xmemaddr floc#cia xreg - | _ -> () - else - () - | _ -> () in - (acc @ defcmds1 @ cmds1 @ splhscmds, off+4)) ([], 0) regs in - let spreg = (sp_r WR)#to_register in + let rhs_r = TR.tmap (rewrite_expr floc) stackrhs_r in + TR.tfold_default + (fun rhs -> + match rhs with + | XVar xvar -> + if floc#f#env#is_initial_register_value xvar then + let xreg = + TR.tget_ok + (floc#f#env#get_initial_register_value_register xvar) in + match (xreg, reg) with + | (ARMRegister r, ARMRegister g) when r = g -> + TR.tfold_default + (fun xmemaddr -> + let xmemaddr = floc#inv#rewrite_expr xmemaddr in + finfo#restore_register xmemaddr floc#cia reg) + () + (stackop#to_address floc) + | (ARMRegister r, ARMRegister g) + when r = ARLR && g = ARPC -> + TR.tfold_default + (fun xmemaddr -> + let xmemaddr = floc#inv#rewrite_expr xmemaddr in + finfo#restore_register xmemaddr floc#cia xreg) + () + (stackop#to_address floc) + | _ -> () + else + () + | _ -> + ()) + () + rhs_r in + (acc @ defcmds1 @ cmds1, off+4)) ([], 0) regs in + let splhs = floc#env#mk_register_variable (sp_r WR)#to_register in let increm = XConst (IntConst (mkNumerical (4 * regcount))) in - let (splhs, popcmds) = - floc#get_ssa_assign_commands spreg (XOp (XPlus, [sprhs; increm])) in + let sprhs_r = + TR.tmap (fun sprhs -> XOp (XPlus, [sprhs; increm])) sprhs_r in + let popcmds = floc#get_assign_commands_r (Ok splhs) sprhs_r in let useshigh = let fsig = finfo#get_summary#get_function_signature in let rtype = fsig.fts_returntype in @@ -2200,7 +2334,7 @@ let translate_arm_instruction ctxtiaddr in stackops @ popdefcmds @ popcmds in - let ccdefcmds () = + let ccdefcmds (): cmd_t list = if is_cond_conditional c && finfo#has_associated_cc_setter ctxtiaddr then let testiaddr = finfo#get_associated_cc_setter ctxtiaddr in let testloc = ctxt_string_to_location faddr testiaddr in @@ -2315,32 +2449,46 @@ let translate_arm_instruction * SP = SP - 4*BitCount(registers); * ------------------------------------------------------------------------ *) | Push (c, sp, rl, _) -> - let floc = get_floc loc in let regcount = rl#get_register_count in - let sprhs = sp#to_expr floc in - let rhsvars = rl#to_multiple_variable floc in - let (stackops,_) = + let sprhs_r = sp#to_expr floc in + let rhsvars_rl = rl#to_multiple_variable floc in + let (stackops, _) = List.fold_left - (fun (acc, off) rhsvar -> - (* let (splhs,splhscmds) = (sp_r RD)#to_lhs floc in *) - let stackop = arm_sp_deref ~with_offset:off WR in - let (stacklhs, stacklhscmds) = stackop#to_lhs floc in - let rhsexpr = rewrite_expr floc (XVar rhsvar) in - let cmds1 = floc#get_assign_commands stacklhs rhsexpr in - let usehigh = get_use_high_vars [rhsexpr] in - let defcmds1 = - floc#get_vardef_commands - ~defs:[stacklhs] - ~use:[rhsvar] - ~usehigh:usehigh - ctxtiaddr in - (acc @ stacklhscmds @ defcmds1 @ cmds1, off+4)) - ([],(-(4*regcount))) rhsvars in - let spreg = (sp_r WR)#to_register in + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let stackop = arm_sp_deref ~with_offset:off WR in + TR.tfold + ~ok:(fun (stacklhs, stacklhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands stacklhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[stacklhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + stacklhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (stackop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + 4)) ([], (- (4 * regcount))) rhsvars_rl in + + let splhs = floc#env#mk_register_variable (sp_r WR)#to_register in let decrem = XConst (IntConst (mkNumerical(4 * regcount))) in - let (splhs, cmds) = - floc#get_ssa_assign_commands - spreg ~vtype:t_voidptr (XOp (XMinus, [sprhs; decrem])) in + let sprhs_r = TR.tmap (fun sprhs -> XOp (XMinus, [sprhs; decrem])) sprhs_r in + let cmds = floc#get_assign_commands_r (Ok splhs) sprhs_r in let defcmds = floc#get_vardef_commands ~defs:[splhs] @@ -2352,12 +2500,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | ReverseBits (c, rd, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2370,14 +2518,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | ReverseSubtract (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = - floc#get_ssa_assign_commands rdreg (XOp (XMinus, [xrm; xrn])) in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrm; xrn])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2391,14 +2539,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | ReverseSubtractCarry(_, c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = - floc#get_ssa_assign_commands rdreg (XOp (XMinus, [xrm; xrn])) in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrm; xrn])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2412,13 +2560,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | RotateRight (_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2432,12 +2580,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | RotateRightExtend (_, c, rd, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2451,13 +2599,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SelectBytes (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2470,12 +2618,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedBitFieldExtract (c, rd, rn) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn] in - let usehigh = get_use_high_vars [xrn] in + let usehigh = get_use_high_vars_r [xrn_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2488,14 +2636,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedDivide (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XDiv, [xrn; xrm])) xrn_r xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn; rm] in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let result = XOp (XDiv, [xrn; xrm]) in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_int result in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2508,12 +2656,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedExtendByte (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2526,12 +2674,12 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedExtendHalfword (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2544,13 +2692,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedMostSignificantWordMultiply (c, rd, rm, rn, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let xrn = rn#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let xrn_r = rn#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rm; rn] in - let usehigh = get_use_high_vars [xrm; xrn] in + let usehigh = get_use_high_vars_r [xrm_r; xrn_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2563,14 +2711,14 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedMostSignificantWordMultiplyAccumulate (c, rd, rn, rm, ra, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let xra = ra#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xra_r = ra#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm; ra] in - let usehigh = get_use_high_vars [xrn; xrm; xra] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r; xra_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2582,26 +2730,36 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | SignedMultiplyLong (_, c, rdlo, rdhi, _, _) -> - let floc = get_floc loc in - let loreg = rdlo#to_register in - let hireg = rdhi#to_register in - let (vlo, cmdslo) = floc#get_ssa_abstract_commands loreg () in - let (vhi, cmdshi) = floc#get_ssa_abstract_commands hireg () in - let defcmds = floc#get_vardef_commands ~defs:[vlo; vhi] ctxtiaddr in + | SignedMultiplyLong (_, c, rdlo, rdhi, rn, rm) -> + let vlo = floc#env#mk_register_variable rdlo#to_register in + let vhi = floc#env#mk_register_variable rdhi#to_register in + let lhslo_r = TR.tmap fst (rdlo#to_lhs floc) in + let lhshi_r = TR.tmap fst (rdhi#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmdslo = floc#get_abstract_commands_r lhslo_r in + let cmdshi = floc#get_abstract_commands_r lhshi_r in + let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = + floc#get_vardef_commands + ~defs:[vlo; vhi] + ~use:usevars + ~usehigh + ctxtiaddr in let cmds = defcmds @ cmdslo @ cmdshi in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | SignedMultiplyWordB (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2614,13 +2772,13 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SignedMultiplyWordT (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands ~defs:[vrd] @@ -2648,29 +2806,49 @@ let translate_arm_instruction * if wback then R[n] = R[n] + 4 * BitCount(registers); * ------------------------------------------------------------------------ *) | StoreMultipleIncrementAfter (wback, c, base, rl, _, _) -> - let floc = get_floc loc in let basereg = base#get_register in let regcount = rl#get_register_count in - let rhsexprs = rl#to_multiple_expr floc in - let rhsexprs = List.map (rewrite_expr floc) rhsexprs in + let rhsvars_rl = rl#to_multiple_variable floc in let (memassigns, _) = List.fold_left - (fun (acc, off) rhsexpr -> - let memop = arm_reg_deref ~with_offset:off basereg WR in - let (memlhs, memlhscmds) = memop#to_lhs floc in - let cmds1 = floc#get_assign_commands memlhs rhsexpr in - let defcmds1 = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in - (acc @ memlhscmds @ defcmds1 @ cmds1, off + 4)) - ([], 0) - rhsexprs in - let wbackassign = + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + TR.tfold + ~ok:(fun (memlhs, memlhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands memlhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[memlhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + memlhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (memop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + 4)) ([], 0) rhsvars_rl in + + let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let increm = int_constant_expr (4 * regcount) in - let newrhs = XOp (XPlus, [rhs; increm]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XPlus, [rhs; increm])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let wbackdefcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in wbackdefcmds @ wbackcmds else @@ -2697,29 +2875,49 @@ let translate_arm_instruction * R[n] = R[n] + 4 * BitCount(registers); * ------------------------------------------------------------------------ *) | StoreMultipleIncrementBefore (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let regcount = rl#get_register_count in - let rhsexprs = rl#to_multiple_expr floc in - let rhsexprs = List.map (rewrite_expr floc) rhsexprs in + let rhsvars_rl = rl#to_multiple_variable floc in let (memassigns, _) = List.fold_left - (fun (acc, off) rhsexpr -> - let memop = arm_reg_deref ~with_offset:off basereg WR in - let (memlhs, memlhscmds) = memop#to_lhs floc in - let cmds1 = floc#get_assign_commands memlhs rhsexpr in - let defcmds1 = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in - (acc @ memlhscmds @ defcmds1 @ cmds1, off + 4)) - ([], 4) - rhsexprs in + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + TR.tfold + ~ok:(fun (memlhs, memlhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands memlhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[memlhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + memlhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (memop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + 4)) ([], 4) rhsvars_rl in + let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let increm = int_constant_expr (4 + (4 * regcount)) in - let newrhs = XOp (XPlus, [rhs; increm]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in + let rhs_r = TR.tmap (fun rhs -> XOp (XPlus, [rhs; increm])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in let wbackdefcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in wbackdefcmds @ wbackcmds else @@ -2745,46 +2943,50 @@ let translate_arm_instruction * if wback then R[n] = R[n] - 4 * BitCount(registers); * ------------------------------------------------------------------------ *) | StoreMultipleDecrementBefore (wback, c, base, rl, _) -> - let floc = get_floc loc in let basereg = base#get_register in let regcount = rl#get_register_count in - let rhsvars = rl#to_multiple_variable floc in + let rhsvars_rl = rl#to_multiple_variable floc in let (memassigns, _) = List.fold_left - (fun (acc, off) rhsvar -> - let memop = arm_reg_deref ~with_offset:off basereg WR in - let (memlhs, memlhscmds) = memop#to_lhs floc in - let memop1 = arm_reg_deref ~with_offset:(off+1) basereg WR in - let memlhs1 = memop1#to_variable floc in - let memop2 = arm_reg_deref ~with_offset:(off+2) basereg WR in - let memlhs2 = memop2#to_variable floc in - let memop3 = arm_reg_deref ~with_offset:(off+3) basereg WR in - let memlhs3 = memop3#to_variable floc in - let rhsexpr = rewrite_expr floc (XVar rhsvar) in - let cmds1 = floc#get_assign_commands memlhs rhsexpr in - let usehigh = get_use_high_vars [rhsexpr] in - let defcmds1 = - floc#get_vardef_commands - ~defs:[memlhs; memlhs1; memlhs2; memlhs3] - ~use:[rhsvar] - ~usehigh:usehigh - ctxtiaddr in - (acc @ memlhscmds @ defcmds1 @ cmds1, off + 4)) - ([], -(4 * regcount)) - rhsvars in + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + TR.tfold + ~ok:(fun (memlhs, memlhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands memlhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[memlhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + memlhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (memop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + 4)) ([], - (4 * regcount)) rhsvars_rl in + let wbackassign = if wback then - let basereg = base#to_register in - let rhs = base#to_expr floc in + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in let decrem = int_constant_expr (4 * regcount) in - let newrhs = XOp (XMinus, [rhs; decrem]) in - let (lhs, wbackcmds) = - floc#get_ssa_assign_commands basereg ~vtype:t_voidptr newrhs in - let wbackdefcmds = - floc#get_vardef_commands - ~defs:[lhs] - ~use:(get_register_vars [base]) - ctxtiaddr in + let rhs_r = TR.tmap (fun rhs -> XOp (XMinus, [rhs; decrem])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in + let wbackdefcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in wbackdefcmds @ wbackcmds else [] in @@ -2793,138 +2995,154 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | StoreRegister (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let _ = check_storage mem vmem in - let xrt = rt#to_expr floc in - let xrt = floc#inv#rewrite_expr xrt in - let cmds = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - let xrn = rewrite_expr floc (rn#to_expr floc) in - let xrm = rewrite_expr floc (rm#to_expr floc) in - begin - (if BCHSystemSettings.system_settings#collect_data then - ch_error_log#add - "assignment to unknown memory" - (LBLOCK [ - floc#l#toPretty; - STR " STR ["; - rn#toPretty; - STR ", "; - rm#toPretty; - STR "]; base: "; - x2p xrn; - STR ", offset: "; - x2p xrm])); - [] - end + + (* ------------------------------------------ StoreMultipleDecrementAfter --- + * Stores multiple registers to consecutive memory locations using an address + * from a base register. The consecutive memory locations end at this address, + * and the address of the first of those locations may be written back to the + * base register. + * + * address = R[n] - 4 * BitCount(registers) + 4; + * for i = 0 to 14 + * if registers == '1' then + * MemA[address, 4] = R[i]; + * address = address + 4; + * if registers<15> == '1' then + * MemA[address, 4] = PCStoreValue(); + * if wback then R[n] = R[n] - 4 * BitCount(registers); + * ------------------------------------------------------------------------ *) + | StoreMultipleDecrementAfter (wback, c, base, rl, _) -> + let basereg = base#get_register in + let regcount = rl#get_register_count in + let rhsvars_rl = rl#to_multiple_variable floc in + let (memassigns, _) = + List.fold_left + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let memop = arm_reg_deref ~with_offset:off basereg WR in + TR.tfold + ~ok:(fun (memlhs, memlhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands memlhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[memlhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + memlhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (memop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + 4)) ([], 4 - (4 * regcount)) rhsvars_rl in + + let wbackassign = + if wback then + let lhs = floc#env#mk_register_variable base#to_register in + let rhs_r = base#to_expr floc in + let decrem = int_constant_expr (4 * regcount) in + let rhs_r = TR.tmap (fun rhs -> XOp (XMinus, [rhs; decrem])) rhs_r in + let wbackcmds = floc#get_assign_commands_r (Ok lhs) rhs_r in + let wbackdefcmds = floc#get_vardef_commands ~defs:[lhs] ctxtiaddr in + wbackdefcmds @ wbackcmds else - floc#get_assign_commands vmem xrt in + [] in + let cmds = memassigns @ wbackassign in + (match c with + | ACCAlways -> default cmds + | _ -> make_conditional_commands c cmds) + + | StoreRegister (c, rt, rn, rm, mem, _) -> + let xrt_r = rt#to_expr floc in + let xrt_r = TR.tmap (floc#inv#rewrite_expr) xrt_r in let usevars = get_register_vars [rt; rn; rm] in - let usehigh = get_use_high_vars [xrt] in - let (usevars, usehigh) = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (usevars, get_addr_use_high_vars [xrn; xrm]) - else - (vmem :: usevars, usehigh) in - let defcmds = - floc#get_vardef_commands - ~defs:[vmem] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + let usehigh = get_use_high_vars_r [xrt_r] in + let rdefcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in + let cmds = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xrt_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let usehigh = get_addr_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": STR")) - (fun (_, addr) -> - let rnreg = rn#to_register in - let (vrn, ucmds) = - floc#get_ssa_assign_commands rnreg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in - defupdatecmds @ucmds) - [] - addr_r + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let vrn = floc#env#mk_register_variable rn#to_register in + let cmds = floc#get_assign_commands_r (Ok vrn) addr_r in + let defcmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in + defcmds @ cmds else [] in - let cmds = memcmds @ defcmds @ cmds @ updatecmds in + let cmds = cmds @ rdefcmds @ updatecmds in let _ = (* record register spill *) - let vrt = rt#to_variable floc in + let vrt = floc#env#mk_register_variable rt#to_register in if floc#has_initial_value vrt then - finfo#save_register vmem floc#cia rt#to_register in + TR.tfold + ~ok:(fun memlhs -> + if finfo#env#is_stack_variable memlhs then + finfo#save_register memlhs floc#cia rt#to_register) + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; () end) + (mem#to_variable floc) in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | StoreRegisterByte (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let _ = check_storage mem vmem in - let xrt = XOp (XXlsb, [rt#to_expr floc]) in - let cmds = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - let xrn = rewrite_expr floc (rn#to_expr floc) in - let xrm = rewrite_expr floc (rm#to_expr floc) in - begin - (if BCHSystemSettings.system_settings#collect_data then - ch_error_log#add - "assignment to unknown memory" - (LBLOCK [ - floc#l#toPretty; - STR " STRB ["; - rn#toPretty; - STR ", "; - rm#toPretty; - STR "]; base: "; - x2p xrn; - STR ", offset: "; - x2p xrm])); - [] - end - else - floc#get_assign_commands vmem xrt in + let xrt_r = rt#to_expr floc in + let xrt_r = TR.tmap (floc#inv#rewrite_expr) xrt_r in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rt; rn; rm] in - let usehigh = get_use_high_vars [xrt] in - let (usevars, usehigh) = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let _ = - chlog#add - "record address base and offset registers" - (LBLOCK [floc#l#toPretty; STR ": "; x2p xrn; STR ", "; x2p xrm]) in - (usevars, get_addr_use_high_vars [xrn; xrm]) - else - (vmem :: usevars, usehigh) in - let defcmds = - floc#get_vardef_commands - ~defs:[vmem] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + let usehigh = get_use_high_vars_r [xrt_r] in + let rdefcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in + let cmds = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r ~size:1 (Ok memlhs) xrt_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let usehigh = get_addr_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": STRB")) - (fun (_, addr) -> - let rnreg = rn#to_register in - let (vrn, ucmds) = - floc#get_ssa_assign_commands rnreg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in - defupdatecmds @ucmds) - [] - addr_r + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let vrn = floc#env#mk_register_variable rn#to_register in + let cmds = floc#get_assign_commands_r (Ok vrn) addr_r in + let defcmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in + defcmds @ cmds else [] in - let cmds = memcmds @ defcmds @ cmds @ updatecmds in + let cmds = cmds @ rdefcmds @ updatecmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) @@ -2942,150 +3160,132 @@ let translate_arm_instruction * MemA[address+4, 4] = R[t2]; * if wback then R[n] = offset_addr; * ------------------------------------------------------------------------- *) - | StoreRegisterDual (c, rt, rt2,rn, _, mem, mem2) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let (vmem2, mem2cmds) = mem2#to_lhs floc in - let _ = check_storage mem vmem in - let _ = check_storage mem2 vmem2 in - let xrt = rt#to_expr floc in - let xrt2 = rt2#to_expr floc in - let cmds1 = floc#get_assign_commands vmem xrt in - let cmds2 = floc#get_assign_commands vmem2 xrt2 in - let defcmds = floc#get_vardef_commands ~defs:[vmem; vmem2] ctxtiaddr in + | StoreRegisterDual (c, rt, rt2,rn, rm, mem, mem2) -> + let xrt_r = rt#to_expr floc in + let xrt2_r = rt2#to_expr floc in + let usevars = get_register_vars [rt; rt2; rn; rm] in + let usehigh = get_use_high_vars_r [xrt_r; xrt2_r] in + let rdefcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in + let cmds1 = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xrt_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let usehigh = get_addr_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in + let cmds2 = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xrt2_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; [] end) + (mem2#to_lhs floc) in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error "invalid write-back address" ((p2s floc#l#toPretty) ^ ": STRD")) - (fun (_, addr) -> - let rnreg = rn#to_register in - let (vrn, ucmds) = - floc#get_ssa_assign_commands rnreg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in - defupdatecmds @ ucmds) - [] - addr_r + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let vrn = floc#env#mk_register_variable rn#to_register in + let cmds = floc#get_assign_commands_r (Ok vrn) addr_r in + let defcmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in + defcmds @ cmds else [] in - let cmds = memcmds @ mem2cmds @ defcmds @ cmds1 @ cmds2 @ updatecmds in + let cmds = cmds1 @ cmds2 @ rdefcmds @ updatecmds in let _ = (* record register spills *) - let vrt = rt#to_variable floc in - let vrt2 = rt2#to_variable floc in + let vrt = floc#env#mk_register_variable rt#to_register in + let vrt2 = floc#env#mk_register_variable rt2#to_register in begin (if floc#has_initial_value vrt then - finfo#save_register vmem floc#cia rt#to_register); + TR.tfold + ~ok:(fun memlhs -> + finfo#save_register memlhs floc#cia rt#to_register) + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; () end) + (mem#to_variable floc)); (if floc#has_initial_value vrt2 then - finfo#save_register vmem2 floc#cia rt2#to_register) + TR.tfold + ~ok:(fun memlhs -> + finfo#save_register memlhs floc#cia rt2#to_register) + ~error:(fun e -> + begin log_dc_error_result __FILE__ __LINE__ e; () end) + (mem2#to_variable floc)) end in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | StoreRegisterExclusive (c, rd, rt, rn, mem) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let _ = check_storage mem vmem in - let rdreg = rd#to_register in - let xrt = rt#to_expr floc in - let cmds = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - let xrn = rewrite_expr floc (rn#to_expr floc) in - begin - ch_error_log#add - "assignment to unknown memory" - (LBLOCK [ - floc#l#toPretty; - STR " STREX ["; - rn#toPretty; - STR "]; base: "; - x2p xrn]); - [] - end - else - floc#get_assign_commands vmem xrt in + let xrt_r = rt#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in let usevars = get_register_vars [rt; rn] in - let usehigh = get_use_high_vars [xrt] in - let (usevars, usehigh) = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - (usevars, get_addr_use_high_vars [xrn]) - else - (vmem :: usevars, usehigh) in - let (vrd, scmds) = floc#get_ssa_abstract_commands rdreg () in + let usehigh = get_use_high_vars_r [xrt_r] in + let rdcmds = floc#get_abstract_commands_r lhs_r in let defcmds = - floc#get_vardef_commands - ~defs:[vmem; vrd] - ~use:usevars - ~usehigh - ctxtiaddr in - let cmds = memcmds @ defcmds @ cmds @ scmds in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in + let cmds = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xrt_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let xrn_r = rn#to_expr floc in + let usehigh = get_addr_use_high_vars_r [xrn_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in + let cmds = rdcmds @ defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | StoreRegisterHalfword (c, rt, rn, rm, mem, _) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let _ = check_storage mem vmem in - let xrt = XOp (XXlsh, [rt#to_expr floc]) in - let cmds = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - let xrn = rewrite_expr floc (rn#to_expr floc) in - let xrm = rewrite_expr floc (rm#to_expr floc) in - begin - (if BCHSystemSettings.system_settings#collect_data then - ch_error_log#add - "assignment to unknown memory" - (LBLOCK [ - floc#l#toPretty; - STR " STRH ["; - rn#toPretty; - STR ", "; - rm#toPretty; - STR "]; base: "; - x2p xrn; - STR ", offset: "; - x2p xrm])); - [] - end - else - floc#get_assign_commands vmem xrt in + let xrt_r = rt#to_expr floc in + let xrt_r = TR.tmap (floc#inv#rewrite_expr) xrt_r in let usevars = get_register_vars [rt; rn; rm] in - let usehigh = get_use_high_vars [xrt] in - let (usevars, usehigh) = - if vmem#isTmp || floc#f#env#is_unknown_memory_variable vmem then - (* elevate address variables to high-use *) - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - (usevars, get_addr_use_high_vars [xrn; xrm]) - else - (vmem :: usevars, usehigh) in - let defcmds = - floc#get_vardef_commands - ~defs:[vmem] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + let usehigh = get_use_high_vars_r [xrt_r] in + let rdefcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in + let cmds = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r ~size:2 (Ok memlhs) xrt_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let usehigh = get_addr_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in let updatecmds = if mem#is_offset_address_writeback then - let addr_r = mem#to_updated_offset_address floc in - log_tfold_default - (log_error - "invalid write-back address" ((p2s floc#l#toPretty) ^ ": STRH")) - (fun (_, addr) -> - let rnreg = rn#to_register in - let (vrn, ucmds) = - floc#get_ssa_assign_commands rnreg ~vtype:t_voidptr addr in - let defupdatecmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in - defupdatecmds @ucmds) - [] - addr_r + let addr_r = TR.tmap snd (mem#to_updated_offset_address floc) in + let vrn = floc#env#mk_register_variable rn#to_register in + let cmds = floc#get_assign_commands_r (Ok vrn) addr_r in + let defcmds = floc#get_vardef_commands ~defs:[vrn] ctxtiaddr in + defcmds @ cmds else [] in - let cmds = memcmds @ defcmds @ cmds @ updatecmds in + let cmds = cmds @ rdefcmds @ updatecmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) @@ -3101,19 +3301,19 @@ let translate_arm_instruction * APSR.V = overflow * ------------------------------------------------------------------------- *) | Subtract (_, c, rd, rn, rm, _, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap2 (fun xrn xrm -> XOp (XMinus, [xrn; xrm])) xrn_r xrm_r in let usevars = get_register_vars [rn; rm] in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = - floc#get_ssa_assign_commands rdreg (XOp (XMinus, [xrn; xrm])) in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ~use:usevars - ~usehigh:usehigh + ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with @@ -3121,18 +3321,18 @@ let translate_arm_instruction | _ -> make_conditional_commands c cmds) | SubtractCarry(_, c, rd, rn, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let cmds = floc#get_abstract_commands_r lhs_r in let defcmds = floc#get_vardef_commands ~defs:[vrd] ~use:usevars - ~usehigh:usehigh + ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with @@ -3147,23 +3347,34 @@ let translate_arm_instruction * R[t] = data; * ------------------------------------------------------------------------ *) | Swap (c, rt, rt2, rn, mem) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let (vmem, memcmds) = mem#to_lhs floc in - let xmem = mem#to_expr floc in - let _ = check_storage mem vmem in - let xrt2 = rt2#to_expr floc in - let cmds = memcmds @ (floc#get_assign_commands vmem xrt2) in - let (vrt, rcmds) = floc#get_ssa_assign_commands rtreg xmem in + let vrt = floc#env#mk_register_variable rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let xrt2_r = rt2#to_expr floc in + let memrhs_r = mem#to_expr floc in + let cmds1 = floc#get_assign_commands_r lhs_r memrhs_r in + let cmds2 = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xrt2_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let usehigh = get_use_high_vars_r [xrt2_r] in + let defs = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defs + end) + (mem#to_lhs floc) in let usevars = get_register_vars [rt2; rn] in - let usehigh = get_use_high_vars [xrt2; xmem] in + let usehigh = get_use_high_vars_r [memrhs_r] in let defcmds = floc#get_vardef_commands - ~defs:[vmem; vrt] + ~defs:[vrt] ~use:usevars - ~usehigh:usehigh + ~usehigh ctxtiaddr in - let cmds = defcmds @ cmds @ rcmds in + let cmds = cmds1 @ cmds2 @ defcmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) @@ -3176,23 +3387,34 @@ let translate_arm_instruction * R[t] = data; * ------------------------------------------------------------------------ *) | SwapByte (c, rt, rt2, rn, mem) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let (vmem, memcmds) = mem#to_lhs floc in - let xmem = XOp (XXlsb, [mem#to_expr floc]) in - let _ = check_storage mem vmem in - let xrt2 = XOp (XXlsb, [rt2#to_expr floc]) in - let cmds = memcmds @ (floc#get_assign_commands vmem xrt2) in - let (vrt, rcmds) = floc#get_ssa_assign_commands rtreg ~vtype:t_char xmem in + let vrt = floc#env#mk_register_variable rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let xrt2_r = rt2#to_expr floc in + let memrhs_r = mem#to_expr floc in + let cmds1 = floc#get_assign_commands_r ~size:1 lhs_r memrhs_r in + let cmds2 = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r ~size:1 (Ok memlhs) xrt2_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let usehigh = get_use_high_vars_r [xrt2_r] in + let defs = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defs + end) + (mem#to_lhs floc) in let usevars = get_register_vars [rt2; rn] in - let usehigh = get_use_high_vars [xrt2; xmem] in + let usehigh = get_use_high_vars_r [memrhs_r] in let defcmds = floc#get_vardef_commands - ~defs:[vmem; vrt] + ~defs:[vrt] ~use:usevars - ~usehigh:usehigh + ~usehigh ctxtiaddr in - let cmds = defcmds @ cmds @ rcmds in + let cmds = cmds1 @ cmds2 @ defcmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) @@ -3203,389 +3425,404 @@ let translate_arm_instruction | TableBranchHalfword _ -> default cmds + | Test (c, rn, rm, _) -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = + floc#get_vardef_commands ~use:usevars ~usehigh ~flagdefs ctxtiaddr in + (match c with + | ACCAlways -> default defcmds + | _ -> make_conditional_commands c defcmds) + + | TestEquivalence (c, rn, rm) -> + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in + let defcmds = + floc#get_vardef_commands ~use:usevars ~usehigh ~flagdefs ctxtiaddr in + (match c with + | ACCAlways -> default defcmds + | _ -> make_conditional_commands c defcmds) + | UnsignedAdd8 (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = - floc#get_vardef_commands ~defs:[vrd] ~use:usevars ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedBitFieldExtract (c, rd, rn) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let vtype = rn#to_btype in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype xrn in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn] in - let usehigh = get_use_high_vars [xrn] in + let usehigh = get_use_high_vars_r [xrn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vrd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in - let cmds = (defcmds @ cmds) in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in + let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedDivide (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = - floc#get_vardef_commands ~defs:[vrd] ~use:usevars ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedExtendAddByte (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = - floc#get_vardef_commands ~defs:[vrd] ~use:usevars ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedExtendAddHalfword (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = - floc#get_vardef_commands ~defs:[vrd] ~use:usevars ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedExtendByte (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = XOp (XXlsb, [rm#to_expr floc]) in - let result = xrm in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_uchar result in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap (fun xrm -> XOp (XXlsb, [xrm])) xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vrd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedExtendHalfword (c, rd, rm, _) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrm = rm#to_expr floc in - let xrm = XOp (XXlsh, [xrm]) in - let (vrd, cmds) = floc#get_ssa_assign_commands rdreg ~vtype:t_ushort xrm in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrm_r = rm#to_expr floc in + let rhs_r = TR.tmap (fun xrm -> XOp (XXlsh, [xrm])) xrm_r in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rm] in - let usehigh = get_use_high_vars [xrm] in + let usehigh = get_use_high_vars_r [xrm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vrd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = cmds @ defcmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedMultiplyAccumulateLong (_, c, rdlo, rdhi, rn, rm) -> - let floc = get_floc loc in - let rdloreg = rdlo#to_register in - let rdhireg = rdhi#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in - let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vlo, cmdslo) = floc#get_ssa_abstract_commands rdloreg () in - let (vhi, cmdshi) = floc#get_ssa_abstract_commands rdhireg () in + let vrlo = floc#env#mk_register_variable rdlo#to_register in + let vrhi = floc#env#mk_register_variable rdhi#to_register in + let lhslo_r = TR.tmap fst (rdlo#to_lhs floc) in + let lhshi_r = TR.tmap fst (rdhi#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let xrdlo_r = rdlo#to_expr floc in + let xrdhi_r = rdhi#to_expr floc in + let cmdslo = floc#get_abstract_commands_r lhslo_r in + let cmdshi = floc#get_abstract_commands_r lhshi_r in + let usevars = get_register_vars [rn; rm; rdlo; rdhi] in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r; xrdlo_r; xrdhi_r] in let defcmds = floc#get_vardef_commands - ~defs:[vlo; vhi] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + ~defs:[vrlo; vrhi] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmdslo @ cmdshi in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedMultiplyLong (_, c, rdlo, rdhi, rn, rm) -> - let floc = get_floc loc in - let rdreglo = rdlo#to_register in - let rdreghi = rdhi#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrlo = floc#env#mk_register_variable rdlo#to_register in + let vrhi = floc#env#mk_register_variable rdhi#to_register in + let lhslo_r = TR.tmap fst (rdlo#to_lhs floc) in + let lhshi_r = TR.tmap fst (rdhi#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmdslo = floc#get_abstract_commands_r lhslo_r in + let cmdshi = floc#get_abstract_commands_r lhshi_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vlo, cmdslo) = floc#get_ssa_abstract_commands rdreglo () in - let (vhi, cmdshi) = floc#get_ssa_abstract_commands rdreghi () in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = floc#get_vardef_commands - ~defs:[vlo; vhi] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + ~defs:[vrlo; vrhi] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmdslo @ cmdshi in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedSaturate (c, rd, _, rn) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn] in - let usehigh = get_use_high_vars [xrn] in + let usehigh = get_use_high_vars_r [xrn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vrd] - ~use:usevars - ~usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | UnsignedSaturatingSubtract8 (c, rd, rn, rm) -> - let floc = get_floc loc in - let rdreg = rd#to_register in - let xrn = rn#to_expr floc in - let xrm = rm#to_expr floc in + let vrd = floc#env#mk_register_variable rd#to_register in + let lhs_r = TR.tmap fst (rd#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let xrm_r = rm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [rn; rm] in - let usehigh = get_use_high_vars [xrn; xrm] in - let (vrd, cmds) = floc#get_ssa_abstract_commands rdreg () in + let usehigh = get_use_high_vars_r [xrn_r; xrm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vrd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vrd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorAbsolute (c, _dt, dst, src) -> - let floc = get_floc loc in - let dreg = dst#to_register in - let xsrc = src#to_expr floc in - let usevars = get_register_vars [src] in - let usehigh = get_use_high_vars [xsrc] in - (* let vtype = vfp_datatype_to_btype dt in *) - let (vdst, cmds) = floc#get_ssa_abstract_commands dreg () in + | VectorAbsolute (c, _, qd, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorAdd (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorAdd (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorAddLong (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorAddLong (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorAddWide (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorAddWide (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseAnd (c, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseAnd (c, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseBitClear (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseBitClear (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseExclusiveOr (c, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseExclusiveOr (c, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseNot (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseNot (c, _, qd, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseOr (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseOr (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseOrNot (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorBitwiseOrNot (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorBitwiseSelect (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + (* NEON instruction *) + | VectorBitwiseSelect (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VCompare (_, _, _, fdst, src1, src2) -> - let floc = get_floc loc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let fpscr_def = fdst#to_variable floc in - let usevars = get_register_vars [src1; src2] in - let usehigh = get_use_high_vars [xsrc1; xsrc2] in + | VCompare (_, _, _, fdst, dd, dm) -> + let xdd_r = dd#to_expr floc in + let xdm_r = dm#to_expr floc in + let fpscr_def = floc#env#mk_register_variable fdst#to_register in + let usevars = get_register_vars [dd; dm] in + let usehigh = get_use_high_vars_r [xdd_r; xdm_r] in let defcmds = floc#get_vardef_commands ~defs:[fpscr_def] ~use:usevars - ~usehigh:usehigh - ~flagdefs:flagdefs + ~usehigh + ~flagdefs ctxtiaddr in default defcmds - | VectorConvert (_, _, c, dt, _, dd, dm, _) -> - let floc = get_floc loc in - let ddreg = dd#to_register in - let xdm = dm#to_expr floc in + | VectorConvert (_, _, c, _, _, dd, dm, _) -> + let vdd = floc#env#mk_register_variable dd#to_register in + let lhs_r = TR.tmap fst (dd#to_lhs floc) in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_assign_commands_r lhs_r xdm_r in let usevars = get_register_vars [dm] in - let usehigh = get_use_high_vars [xdm] in - let vtype = vfp_datatype_to_btype dt in - let (vdd, cmds) = floc#get_ssa_assign_commands ddreg ~vtype xdm in + let usehigh = get_use_high_vars_r [xdm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VDivide (c, _dt, dd, dn, dm) -> - let floc = get_floc loc in - let ddreg = dd#to_register in - let xdn = dn#to_expr floc in - let xdm = dm#to_expr floc in + let vdd = floc#env#mk_register_variable dd#to_register in + let lhs_r = TR.tmap fst (dd#to_lhs floc) in + let xdn_r = dn#to_expr floc in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in let usevars = get_register_vars [dn; dm] in - let usehigh = get_use_high_vars [xdn; xdm] in - (* let vtype = vfp_datatype_to_btype dt in *) - let (vdd, cmds) = floc#get_ssa_abstract_commands ddreg () in + let usehigh = get_use_high_vars_r [xdm_r; xdn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds @@ -3593,121 +3830,111 @@ let translate_arm_instruction | VectorDuplicate _ -> default [] - | VectorMoveDS (c, dt, dd, dm) -> - let floc = get_floc loc in - let ddreg = dd#to_register in - let xdm = dm#to_expr floc in + | VectorMoveDS (c, _, dd, dm) -> + let vdd = floc#env#mk_register_variable dd#to_register in + let lhs_r = TR.tmap fst (dd#to_lhs floc) in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_assign_commands_r lhs_r xdm_r in let usevars = get_register_vars [dm] in - let usehigh = get_use_high_vars [xdm] in - let vtype = vfp_datatype_to_btype dt in - let (vdd, cmds) = floc#get_ssa_assign_commands ddreg ~vtype xdm in + let usehigh = get_use_high_vars_r [xdm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdd] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VectorMoveDDSS (c, _, dst1, dst2, ddst, src1, src2, ssrc) -> - let floc = get_floc loc in - let vdst1 = dst1#to_variable floc in - let vdst2 = dst2#to_variable floc in - let vddst = ddst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let xssrc = ssrc#to_expr floc in + let vdst1_r = dst1#to_variable floc in + let vdst2_r = dst2#to_variable floc in + let vddst_r = ddst#to_variable floc in + let vdst1 = floc#env#mk_register_variable dst1#to_register in + let vdst2 = floc#env#mk_register_variable dst2#to_register in + let vddst = floc#env#mk_register_variable ddst#to_register in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let xssrc_r = ssrc#to_expr floc in let usevars = get_register_vars [src1; src2; ssrc] in - let usehigh = get_use_high_vars [xsrc1; xsrc2; xssrc] in - let cmds1 = floc#get_abstract_commands vdst1 () in - let cmds2 = floc#get_abstract_commands vdst2 () in - let cmds3 = floc#get_abstract_commands vddst () in + let usehigh = get_use_high_vars_r [xsrc1_r; xsrc2_r; xssrc_r] in + let cmds1 = floc#get_abstract_commands_r vdst1_r in + let cmds2 = floc#get_abstract_commands_r vdst2_r in + let cmds3 = floc#get_abstract_commands_r vddst_r in let defcmds = floc#get_vardef_commands - ~defs:[vdst1; vdst2; vddst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + ~defs:[vdst1; vdst2; vddst] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds1 @ cmds2 @ cmds3 in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VectorMoveDSS (c, _, dst, src1, src2, ssrc) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let xssrc = ssrc#to_expr floc in + let vdst_r = dst#to_variable floc in + let vdst = floc#env#mk_register_variable dst#to_register in + let xsrc1_r = src1#to_expr floc in + let xsrc2_r = src2#to_expr floc in + let xssrc_r = ssrc#to_expr floc in let usevars = get_register_vars [src1; src2; ssrc] in - let usehigh = get_use_high_vars [xsrc1; xsrc2; xssrc] in - let cmds = floc#get_abstract_commands vdst () in + let usehigh = get_use_high_vars_r [xsrc1_r; xsrc2_r; xssrc_r] in + let cmds = floc#get_abstract_commands_r vdst_r in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdst] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VectorMoveDDS (c, _, dst1, dst2, ddst, src) -> - let floc = get_floc loc in - let vdst1 = dst1#to_variable floc in - let vdst2 = dst2#to_variable floc in - let ddstreg = ddst#to_register in - let xsrc = src#to_expr floc in + let vdst1_r = dst1#to_variable floc in + let vdst2_r = dst2#to_variable floc in + let ddst_r = ddst#to_variable floc in + let xsrc_r = src#to_expr floc in + let vdst1 = floc#env#mk_register_variable dst1#to_register in + let vdst2 = floc#env#mk_register_variable dst2#to_register in + let vddst = floc#env#mk_register_variable ddst#to_register in let usevars = get_register_vars [src] in - let usehigh = get_use_high_vars [xsrc] in - let cmds1 = floc#get_abstract_commands vdst1 () in - let cmds2 = floc#get_abstract_commands vdst2 () in - let (vddst, cmds3) = - floc#get_ssa_assign_commands ddstreg ~vtype:t_double xsrc in + let usehigh = get_use_high_vars_r [xsrc_r] in + let cmds1 = floc#get_abstract_commands_r vdst1_r in + let cmds2 = floc#get_abstract_commands_r vdst2_r in + let cmds3 = floc#get_assign_commands_r ddst_r xsrc_r in let defcmds = floc#get_vardef_commands - ~defs:[vdst1; vdst2; vddst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + ~defs:[vdst1; vdst2; vddst] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds1 @ cmds2 @ cmds3 in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VLoadRegister(c, rt, rn, mem) -> - let floc = get_floc loc in - let rtreg = rt#to_register in - let xrn = rn#to_expr floc in - let xmem = mem#to_expr floc in + let vrt = floc#env#mk_register_variable rt#to_register in + let lhs_r = TR.tmap fst (rt#to_lhs floc) in + let xrn_r = rn#to_expr floc in + let rhs_r = mem#to_expr floc in + let cmds = floc#get_assign_commands_r lhs_r rhs_r in let usevars = get_register_vars [rn] in - let usehigh = get_use_high_vars [xrn; xmem] in - let vtype = - if rt#is_double_extension_register then t_double else t_float in - let (lhs, cmds) = floc#get_ssa_assign_commands rtreg ~vtype xmem in + let usehigh = + TR.tfold + ~ok:(fun rhs -> get_use_high_vars [rhs]) + ~error:(fun e -> + let usehigh = get_use_high_vars_r [xrn_r] in + begin + log_dc_error_result __FILE__ __LINE__ e; + usehigh + end) + rhs_r in let defcmds = - floc#get_vardef_commands - ~defs:[lhs] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vrt] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VMoveRegisterStatus (_, dst, src) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let xsrc = src#to_expr floc in + let vdst_r = dst#to_variable floc in + let vdst = floc#env#mk_register_variable dst#to_register in + let xsrc_r = src#to_expr floc in let usevars = get_register_vars [src] in - let usevars = (src#to_variable floc) :: usevars in - let usehigh = get_use_high_vars [xsrc] in - let cmds = floc#get_abstract_commands vdst () in + let usehigh = get_use_high_vars_r [xsrc_r] in + let cmds = floc#get_abstract_commands_r vdst_r in let flagdefs = if dst#is_APSR_condition_flags then apsr_flagdefs else [] in let defcmds = @@ -3719,209 +3946,229 @@ let translate_arm_instruction ctxtiaddr in default (defcmds @ cmds) - | VectorMoveLong (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorMoveLong (c, _, qd, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qm] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorMoveNarrow (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorMoveNarrow (c, _, qd, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorMultiply (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorMultiply (c, _, qd, qn, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqn_r; xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorMultiplyAccumulateLong (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorMultiplyAccumulateLong (c, _, qd, qn, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqn_r; xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorMultiplyLong (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorMultiplyLong (c, _, qd, qn, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqn_r; xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorMultiplySubtract (c, _dt, dst, src1, src2) -> - let floc = get_floc loc in - let dstreg = dst#to_register in - let xsrc0 = dst#to_expr floc in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let usevars = get_register_vars [dst; src1; src2] in - let usehigh = get_use_high_vars [xsrc0; xsrc1; xsrc2] in - (* let vtype = vfp_datatype_to_btype dt in *) - let (vdst, cmds) = floc#get_ssa_abstract_commands dstreg () in + | VectorMultiplySubtract (c, _, qd, qn, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqn_r; xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorNegate (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorNegate (c, _, qd, qm) -> + let vqd_r = qd#to_variable floc in + let vqd = floc#env#mk_register_variable qd#to_register in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r vqd_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorNegateMultiply (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorNegateMultiply (c, _, dd, dn, dm) -> + let vdd_r = dd#to_variable floc in + let vdd = floc#env#mk_register_variable dd#to_register in + let xdn_r = dn#to_expr floc in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_abstract_commands_r vdd_r in + let usevars = get_register_vars [dn; dm] in + let usehigh = get_use_high_vars_r [xdn_r; xdm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorNegateMultiplyAccumulate (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorNegateMultiplyAccumulate (c, _, dd, dn, dm) -> + let vdd_r = dd#to_variable floc in + let vdd = floc#env#mk_register_variable dd#to_register in + let xdn_r = dn#to_expr floc in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_abstract_commands_r vdd_r in + let usevars = get_register_vars [dn; dm] in + let usehigh = get_use_high_vars_r [xdn_r; xdm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorNegateMultiplySubtract (c, _, dst, _, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorNegateMultiplySubtract (c, _, dd, dn, dm) -> + let vdd_r = dd#to_variable floc in + let vdd = floc#env#mk_register_variable dd#to_register in + let xdn_r = dn#to_expr floc in + let xdm_r = dm#to_expr floc in + let cmds = floc#get_abstract_commands_r vdd_r in + let usevars = get_register_vars [dn; dm] in + let usehigh = get_use_high_vars_r [xdn_r; xdm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vdd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VectorPop (c, sp, rl, _) -> - let floc = get_floc loc in let regcount =rl#get_register_count in let regsize = if rl#is_double_extension_register_list then 8 else 4 in - let sprhs = sp#to_expr floc in let regs = rl#to_multiple_register in let (stackops, _) = List.fold_left (fun (acc, off) reg -> - let (splhs, splhscmds) = (sp_r RD)#to_lhs floc in + let reglhs = floc#env#mk_register_variable reg in + let splhs = floc#env#mk_register_variable sp#to_register in let stackop = arm_sp_deref ~with_offset:off RD in - let stackvar = stackop#to_variable floc in - let stackrhs = stackop#to_expr floc in - let (regvar, cmds1) = floc#get_ssa_assign_commands reg stackrhs in - let usehigh = get_use_high_vars [stackrhs] in + let stackvar_r = stackop#to_variable floc in + let stackrhs_r = stackop#to_expr floc in + let cmds1 = floc#get_assign_commands_r (Ok reglhs) stackrhs_r in + let usevars = + TR.tfold_default (fun stackvar -> [stackvar]) [] stackvar_r in + let usehigh = get_use_high_vars_r ~is_pop:true [stackrhs_r] in let defcmds1 = floc#get_vardef_commands - ~defs:[splhs; regvar] - ~use:[stackvar] - ~usehigh - ctxtiaddr in - (acc @ defcmds1 @ cmds1 @ splhscmds, off + regsize)) ([], 0) regs in - let spreg = (sp_r WR)#to_register in + ~defs:[splhs; reglhs] ~use:usevars ~usehigh ctxtiaddr in + (acc @ defcmds1 @ cmds1, off + regsize)) ([], 0) regs in + let splhs = floc#env#mk_register_variable (sp_r WR)#to_register in let increm = XConst (IntConst (mkNumerical (regsize * regcount))) in - let (splhs, cmds) = - floc#get_ssa_assign_commands spreg (XOp (XPlus, [sprhs; increm])) in + let sprhs_r = + TR.tmap (fun sprhs -> XOp (XPlus, [sprhs; increm])) (sp#to_expr floc) in + let cmds = floc#get_assign_commands_r (Ok splhs) sprhs_r in + let usevars = get_register_vars [sp] in let defcmds = - floc#get_vardef_commands - ~defs:[splhs] - ~use:(get_register_vars [sp]) - ctxtiaddr in + floc#get_vardef_commands ~defs:[splhs] ~use:usevars ctxtiaddr in let cmds = stackops @ defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) | VectorPush (c, sp, rl, _) -> - let floc = get_floc loc in let regcount = rl#get_register_count in let regsize = if rl#is_double_extension_register_list then 8 else 4 in - let sprhs = sp#to_expr floc in - let rhsvars = rl#to_multiple_variable floc in + let sprhs_r = sp#to_expr floc in + let rhsvars_rl = rl#to_multiple_variable floc in let (stackops, _) = List.fold_left - (fun (acc, off) rhsvar -> - let stackop = arm_sp_deref ~with_offset:off WR in - let (stacklhs, stacklhscmds) = stackop#to_lhs floc in - let rhsexpr = rewrite_expr floc (XVar rhsvar) in - let cmds1 = floc#get_assign_commands stacklhs rhsexpr in - let usehigh = get_use_high_vars [rhsexpr] in - let defcmds1 = - floc#get_vardef_commands - ~defs:[stacklhs] - ~use:[rhsvar] - ~usehigh - ctxtiaddr in - (acc @ stacklhscmds @ defcmds1 @ cmds1, off + regsize)) - ([], (- (regsize * regcount))) rhsvars in - let spreg = (sp_r WR)#to_register in + (fun (acc, off) rhsvar_r -> + let cmds = + TR.tfold + ~ok:(fun rhsvar -> + let stackop = arm_sp_deref ~with_offset:off WR in + TR.tfold + ~ok:(fun (stacklhs, stacklhscmds) -> + let rhsexpr = rewrite_expr floc (XVar rhsvar) in + let cmds1 = floc#get_assign_commands stacklhs rhsexpr in + let usehigh = get_use_high_vars [rhsexpr] in + let defcmds1 = + floc#get_vardef_commands + ~defs:[stacklhs] + ~use:[rhsvar] + ~usehigh + ctxtiaddr in + stacklhscmds @ defcmds1 @ cmds1) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + (stackop#to_lhs floc)) + ~error:(fun e -> + begin + log_dc_error_result __FILE__ __LINE__ e; + [] + end) + rhsvar_r in + (acc @ cmds, off + regsize)) + ([], (- (regsize * regcount))) rhsvars_rl in + + let splhs = floc#env#mk_register_variable (sp_r WR)#to_register in let decrem = XConst (IntConst (mkNumerical (regsize * regcount))) in - let (splhs, cmds) = - floc#get_ssa_assign_commands - spreg ~vtype:t_voidptr (XOp (XMinus, [sprhs; decrem])) in + let sprhs_r = TR.tmap (fun sprhs -> XOp (XMinus, [sprhs; decrem])) sprhs_r in + let cmds = floc#get_assign_commands_r (Ok splhs) sprhs_r in let defcmds = floc#get_vardef_commands ~defs:[splhs] @@ -3932,40 +4179,43 @@ let translate_arm_instruction | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorReverseDoublewords (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorReverseDoublewords (c, _, qd, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorReverseHalfwords (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorReverseHalfwords (c, _, qd, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorReverseWords (c, _, dst, _) -> - let floc = get_floc loc in - let vdst = dst#to_variable floc in - let cmds = floc#get_abstract_commands vdst () in + | VectorReverseWords (c, _, qd, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qm] in + let usehigh = get_use_high_vars_r [xqm_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds @@ -3974,39 +4224,41 @@ let translate_arm_instruction | VectorShiftRightNarrow _ -> default [] | VStoreRegister(c, dd, rn, mem) -> - let floc = get_floc loc in - let (vmem, memcmds) = mem#to_lhs floc in - let _ = check_storage mem vmem in - let xdd = dd#to_expr floc in - let cmds = memcmds @ (floc#get_abstract_commands vmem ()) in + let xdd_r = dd#to_expr floc in + let xrn_r = rn#to_expr floc in + let xrn_r = TR.tmap (rewrite_expr floc) xrn_r in let usevars = get_register_vars [dd; rn] in - let usehigh = get_use_high_vars [xdd] in - let defcmds = - floc#get_vardef_commands - ~defs:[vmem] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in - let cmds = defcmds @ cmds in + let usehigh = get_use_high_vars_r [xdd_r] in + let rdefcmds = floc#get_vardef_commands ~use:usevars ~usehigh ctxtiaddr in + let cmds = + TR.tfold + ~ok:(fun (memlhs, memcmds) -> + let cmds = floc#get_assign_commands_r (Ok memlhs) xdd_r in + let defcmds = floc#get_vardef_commands ~defs:[memlhs] ctxtiaddr in + memcmds @ cmds @ defcmds) + ~error:(fun e -> + let usehigh = get_use_high_vars_r [xrn_r] in + let defcmds = floc#get_vardef_commands ~usehigh ctxtiaddr in + begin + log_dc_error_result __FILE__ __LINE__ e; + defcmds + end) + (mem#to_lhs floc) in + let cmds = rdefcmds @ cmds in (match c with | ACCAlways -> default cmds | _ -> make_conditional_commands c cmds) - | VectorSubtract (c, _dt, dst, src1, src2) -> - let floc = get_floc loc in - let dstreg = dst#to_register in - let xsrc1 = src1#to_expr floc in - let xsrc2 = src2#to_expr floc in - let usevars = get_register_vars [src1; src2] in - let usehigh = get_use_high_vars [xsrc1; xsrc2] in - (* let vtype = vfp_datatype_to_btype dt in *) - let (vdst, cmds) = floc#get_ssa_abstract_commands dstreg () in + | VectorSubtract (c, _, qd, qn, qm) -> + let vqd = floc#env#mk_register_variable qd#to_register in + let lhs_r = TR.tmap fst (qd#to_lhs floc) in + let xqn_r = qn#to_expr floc in + let xqm_r = qm#to_expr floc in + let cmds = floc#get_abstract_commands_r lhs_r in + let usevars = get_register_vars [qn; qm] in + let usehigh = get_use_high_vars_r [xqm_r; xqn_r] in let defcmds = - floc#get_vardef_commands - ~defs:[vdst] - ~use:usevars - ~usehigh:usehigh - ctxtiaddr in + floc#get_vardef_commands ~defs:[vqd] ~use:usevars ~usehigh ctxtiaddr in let cmds = defcmds @ cmds in (match c with | ACCAlways -> default cmds @@ -4014,18 +4266,24 @@ let translate_arm_instruction | VectorTranspose _ -> default [] - (* | NotRecognized _ -> default [ASSERT FALSE] *) + | NotRecognized (desc, dw) -> + begin + log_error_result + ~msg:"instruction not recognized" + __FILE__ __LINE__ + [(p2s floc#l#toPretty); + (p2s dw#toPretty) ^ ":" ^ desc]; + default [] + end | instr -> - let _ = - chlog#add - "no semantics" - (LBLOCK [ - loc#toPretty; - STR ": "; - STR (arm_opcode_to_string instr)]) in - default [] - + begin + log_error_result + ~msg:"no instruction semantics" + __FILE__ __LINE__ + [(p2s floc#l#toPretty); (arm_opcode_to_string instr)]; + default [] + end class arm_assembly_function_translator_t (f:arm_assembly_function_int) = object (self) @@ -4200,8 +4458,14 @@ object (self) let initVar = env#mk_initial_register_value (ARMExtensionRegister reg) in ASSERT (EQ (regVar, initVar)) in let freeze_external_memory_values (v:variable_t) = - let initVar = env#mk_initial_memory_value v in - ASSERT (EQ (v, initVar)) in + TR.tfold + ~ok:(fun initVar -> ASSERT (EQ (v, initVar))) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + SKIP + end) + (env#mk_initial_memory_value v) in let rAsserts = List.map freeze_initial_register_value arm_regular_registers in let xAsserts = let xregsused = diff --git a/CodeHawk/CHB/bchlibelf/bCHELFHeader.ml b/CodeHawk/CHB/bchlibelf/bCHELFHeader.ml index 4701e3c1..492fc1f0 100644 --- a/CodeHawk/CHB/bchlibelf/bCHELFHeader.ml +++ b/CodeHawk/CHB/bchlibelf/bCHELFHeader.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 @@ -209,7 +209,16 @@ object method read = - let input = system_info#get_file_input (TR.tget_ok (int_to_doubleword 16)) in + let input_r = system_info#get_file_input (TR.tget_ok (int_to_doubleword 16)) in + match input_r with + | Error e -> + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read elf file header from binary: "; + STR (String.concat "; " e)])) + | Ok input -> begin (* 16, 2 -------------------------------------------------------------- Specifies the object file type. @@ -429,8 +438,16 @@ object(self) method get_program_entry_point = elf_file_header#get_program_entry_point method read = - let fileString = system_info#get_file_string wordzero in - let input = IO.input_string fileString in + let fileString_r = system_info#get_file_string wordzero in + let input = + match fileString_r with + | Ok s -> IO.input_string s + | Error e -> + raise + (BCH_failure + (LBLOCK [STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read elf header: "; + STR (String.concat "; " e)])) in begin e_ident <- Bytes.to_string (IO.really_nread input 16); self#check_elf; @@ -530,6 +547,21 @@ object(self) code_ub <- !ub end + method set_global_data_sections_extent = + List.iter (fun (_, h, _) -> + if (h#is_program_section || (h#get_section_name = ".bss")) + && (not h#is_executable) + && (not + (List.mem + h#get_section_name + [".comment"; ".eh_frame"; ".got"; ".interp"; ".jcr"])) then + BCHGlobalMemoryMap.global_memory_map#set_section + ~readonly:h#is_readonly + ~initialized:(not h#is_uninitialized_data_section) + h#get_section_name + h#get_addr + h#get_size) self#get_sections + method is_code_address (va: doubleword_int): bool = List.fold_left (fun found (h, _) -> found @@ -543,8 +575,25 @@ object(self) && (not h#is_executable) && (h#get_addr#le va) && (va#lt (h#get_addr#add h#get_size)))) - false self#get_sections + false self#get_sections + method is_readonly_address (va: doubleword_int): bool = + List.fold_left (fun found (_, h, _) -> + found + || (h#is_program_section) + && (h#is_readonly || h#is_executable) + && (h#get_addr#le va) + && (va#lt (h#get_addr#add h#get_size))) + false self#get_sections + + method is_uninitialized_data_address (va: doubleword_int): bool = + List.fold_left (fun found (_, h, _) -> + found + || (h#is_uninitialized_data_section + && (not h#is_executable) + && (h#get_addr#le va) + && (va#lt (h#get_addr#add h#get_size)))) + false self#get_sections method initialize_jump_tables = let xstrings = @@ -1131,7 +1180,7 @@ object(self) end done - method private add_new_user_defined_section_headers = + method add_new_user_defined_section_headers = (* let shnum = elf_file_header#get_section_header_table_entry_num in *) let shnum = H.length section_header_table in try @@ -1170,17 +1219,30 @@ object(self) else if H.mem section_header_table index then let sh = H.find section_header_table index in - let xString = + let xString_r = if sh#get_size#equal wordzero then - "" + Ok "" else system_info#get_file_string ~hexSize:sh#get_size sh#get_offset in - let section = make_elf_section sh xString in + let section = + match xString_r with + | Ok s -> make_elf_section sh s + | Error e -> + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read section with index "; + INT index; + STR ": "; + STR (String.concat "; " e)])) in H.add section_table index section else raise (BCH_failure - (LBLOCK [STR "No section header found for "; INT index])) + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "No section header found for "; INT index])) method private add_segment (index:int) = if H.mem segment_table index then @@ -1188,17 +1250,30 @@ object(self) else if H.mem program_header_table index then let ph = H.find program_header_table index in - let xString = + let xString_r = if ph#get_file_size#equal wordzero then - "" + Ok "" else system_info#get_file_string ~hexSize:ph#get_file_size ph#get_offset in - let segment = make_elf_segment ph xString in + let segment = + match xString_r with + | Ok s -> make_elf_segment ph s + | Error e -> + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read segment with index "; + INT index; + STR ": "; + STR (String.concat "; " e)])) in H.add segment_table index segment else raise (BCH_failure - (LBLOCK [STR "No segment header found for index "; INT index])) + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "No segment header found for index "; INT index])) method private write_xml_program_headers (node:xml_element_int) = let headers = ref [] in @@ -1565,6 +1640,7 @@ let load_elf_files () = pr_timing [STR "jump tables initialized"]; elf_header#initialize_call_back_tables; elf_header#initialize_struct_tables; + elf_header#set_global_data_sections_extent; end with | CHXmlReader.XmlParseError(line,col,p) -> @@ -1595,6 +1671,7 @@ let read_elf_file (filename: string) (xsize: int) = elf_header#initialize_jump_tables; elf_header#initialize_call_back_tables; elf_header#initialize_struct_tables; + elf_header#set_global_data_sections_extent; (true, LBLOCK [ STR "File: "; diff --git a/CodeHawk/CHB/bchlibelf/bCHELFProgramHeader.ml b/CodeHawk/CHB/bchlibelf/bCHELFProgramHeader.ml index 3ce340ac..b6ea3e23 100644 --- a/CodeHawk/CHB/bchlibelf/bCHELFProgramHeader.ml +++ b/CodeHawk/CHB/bchlibelf/bCHELFProgramHeader.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: A. Cody Schuffelen and Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020-2021 Henny Sipma - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -14,10 +14,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,12 +34,11 @@ open CHPretty open CHXmlDocument (* bchlib *) +open BCHBasicTypes +open BCHDoubleword open BCHLibTypes open BCHSystemInfo -(* bchlibx86 *) -open BCHDoubleword - (* bchlibelf *) open BCHELFTypes open BCHELFUtil @@ -60,9 +59,21 @@ object (self) val mutable p_align = wordzero method read (offset:doubleword_int) (size:int) = - let input = + let input_r = system_info#get_file_input ~hexSize:(TR.tget_ok (int_to_doubleword size)) offset in + match input_r with + | Error e -> + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read elf program header at offset "; + offset#toPretty; + STR ": "; + STR (String.concat "; " e)])) + | Ok input -> + begin (* 0, 4, p_type -------------------------------------------------------- Tells what kind of segment this array element describes or how to @@ -80,21 +91,21 @@ object (self) table appear in ascending order, sorted on the p_vaddr member PT_DYNAMIC 2 array element specifies dynamic linking information - PT_INTERP 3 array element specifies the location and size of a + PT_INTERP 3 array element specifies the location and size of a null-terminated path name to invoke as an interpreter. This segment type is meaningful only for executable - files (though it may occur for shared objects); it + files (though it may occur for shared objects); it may not occur more than once in a file. If it is present, it must precede any loadable segment entry. - PT_NOTE 4 array element specifies the location and size of + PT_NOTE 4 array element specifies the location and size of auxiliary information PT_SHLIB 5 this segment type is reserved but has unspecified semantics. Programs that contain an array element of this type do not conform to the ABI PT_PHDR 6 array element, if present, specifies the location and size of the program header table itself, both in the - file and in the memory image of the program. This - segment may not occur more than once in a file. + file and in the memory image of the program. This + segment may not occur more than once in a file. Moreover, it may occur only if the program header table is part of the memory image of the program. If it is present, it must precede any loadable segment entry. @@ -104,12 +115,12 @@ object (self) PT_LOOS - PT_HIOS values in this inclusive range are reserved for operating system-specific semantics. PT_LOPROC - PT_HIPROC values in this inclusive range are reserved for - processor-specific semantics. + processor-specific semantics. --------------------------------------------------------------------- *) p_type <- input#read_doubleword ; (* 4, 4, p_offset ------------------------------------------------------ - Gives the offset from the beginning of the file at which the first + Gives the offset from the beginning of the file at which the first byte of the segment resides --------------------------------------------------------------------- *) p_offset <- input#read_doubleword ; @@ -125,7 +136,7 @@ object (self) reserved for the segment's physical address. Because System V ignores physical address for application programs, this member has unspecified contents for executable files and shared - objects + objects --------------------------------------------------------------------- *) p_paddr <- input#read_doubleword ; @@ -150,7 +161,7 @@ object (self) (* 28, 4, p_align ------------------------------------------------------ Loadable process segments must have congruent values for p_vaddr and - p_offset, modulo the page size. This member gives the value to which + p_offset, modulo the page size. This member gives the value to which the segments are aligned in memory and in the file. Values 0 and 1 mean no alignment is required. Otherwise, p_align should be a positive, integral power of 2, and p_vaddr should equal p_offset, modulo p_align @@ -161,7 +172,7 @@ object (self) method get_type = p_type method set_type (t: doubleword_int) = p_type <- t - + method get_offset = p_offset method get_vaddr = p_vaddr @@ -196,7 +207,7 @@ object (self) setx "p_filesz" p_filesz; setx "p_memsz" p_memsz; setx "p_flags" p_flags; - setx "p_align" p_align + setx "p_align" p_align end method read_xml (node:xml_element_int) = diff --git a/CodeHawk/CHB/bchlibelf/bCHELFSectionHeader.ml b/CodeHawk/CHB/bchlibelf/bCHELFSectionHeader.ml index dcc4c5f8..5ad5fb82 100644 --- a/CodeHawk/CHB/bchlibelf/bCHELFSectionHeader.ml +++ b/CodeHawk/CHB/bchlibelf/bCHELFSectionHeader.ml @@ -1,12 +1,12 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: A. Cody Schuffelen and Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + 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 @@ -14,10 +14,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,6 +34,7 @@ open CHPretty open CHXmlDocument (* bchlib *) +open BCHBasicTypes open BCHDoubleword open BCHLibTypes open BCHSystemInfo @@ -87,12 +88,26 @@ object (self) end method read (offset:doubleword_int) (size:int) = - let input = + let input_r = system_info#get_file_input ~hexSize:(TR.tget_ok (int_to_doubleword size)) offset in + match input_r with + | Error e -> + raise + (BCH_failure + (LBLOCK [ + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read section header at offset "; + offset#toPretty; + STR " with size "; + INT size; + STR ": "; + STR (String.concat "; " e)])) + | Ok input -> + begin (* 0, 4, sh_name ------------------------------------------------------- - Specifies the name of the section. Its value is an index into the + Specifies the name of the section. Its value is an index into the section header string table section, giving the location of a null- terminated string --------------------------------------------------------------------- *) @@ -102,14 +117,14 @@ object (self) Categorizes the section's contents and semantics. SHT_NULL 0 section header is inactive; it does not have an associated section - SHT_PROGBITS 1 section holds information defined by the + SHT_PROGBITS 1 section holds information defined by the program, whose format and meaning are determined solely by the program SHT_SYMTAB 2 section holds a symbol table. An object file may have only one section of each type. Typically, SHT_SYMTAB provides symbols for link editing, though it may also be used for - dynamic linking. + dynamic linking. SHT_STRTAB 3 section holds a string table. An object file may have multiple string tables SHT_RELA 4 section holds relocation entries with explicit @@ -118,7 +133,7 @@ object (self) multiple relation sections SHT_HASH 5 section holds a symbol has table. Currently, an object file may have only one hash table. - SHT_DYNAMIC 6 section holds information for dynamic linking. + SHT_DYNAMIC 6 section holds information for dynamic linking. Currently, an object file may have only one dynamic section. SHT_NOTE 7 section holds information that marks the file @@ -129,26 +144,26 @@ object (self) sh_offset member contains the conceptual file offset SHT_REL 9 section holds relocation entries without explicit - addends. An object file may have multiple + addends. An object file may have multiple relocation sections SHT_SHLIB 10 section type is reserved but has unspecified semantics SHT_DYNSYM 11 see SHT_SYMTAB - SHT_INIT_ARRAY 14 section contains an array of pointers to + SHT_INIT_ARRAY 14 section contains an array of pointers to initialization functions. Each pointer in the - array is taken as a parameterless procedure + array is taken as a parameterless procedure with a void return SHT_FINI_ARRAY 15 section contains an array of pointers to termination function. Each pointer in the array is taken as a parameterless procedures with a void return - SHT_PREINIT_ARRAY 16 section contains an array of pointers to + SHT_PREINIT_ARRAY 16 section contains an array of pointers to functions that are invoked before all other initialization function. Each pointer is taken as a parameterless procedure with a void return. SHT_GROUP 17 section defines a section group. A section group is a set of sections that are related and that - must be treated specially by the linker. + must be treated specially by the linker. Sections of this type may appear only in relocatable objects (objects with the ELF header e_type member set to ET_REL). The section header table @@ -170,7 +185,7 @@ object (self) actual section header index; otherwise, the entry must be SHN_UNDEF (0) SHT_LOOS 0x60000000 values SHT_LOOS through SHT_HIOS are reserved for - SHT_HIOS 0x6fffffff operating system semantics + SHT_HIOS 0x6fffffff operating system semantics SHT_LOPROC 0x70000000 values SHT_LOPROC through SHT_HIPROC are reserved SHT_HIPROC 0x7fffffff for processor-specific semantics SHT_LOUSER 0x80000000 specifies the lower bound of the range of indexes @@ -182,35 +197,35 @@ object (self) (* 8, 4, sh_flags ------------------------------------------------------ 1-bit flags that describe miscellaneous attributes. - SHF_WRITE 0x1 section contains data that should be writable + SHF_WRITE 0x1 section contains data that should be writable during process execution SHF_ALLOC 0x2 section occupies memory during process exeuction SHF_EXECINSTR 0x4 section contains executable machine instructions SHF_MERGE 0x10 the data in the setion may be merged to eliminate duplication. Unless the SHF_STRINGS flag is also - set, the data elements in the section are of a + set, the data elements in the section are of a uniform size. The size of each element is specified in the section header's sh_entsize field. If the SHF_STRINGS flag is also set, the data elements consist of null-terminated character strings. The size of each character is specified in the section header's sh_entsize field. - + Each element in the section is compared against other elements in sections with the same name, type and flags. Elements that would have identical values at program run-time may be merged. Relocations - referencing elements of such sections must be + referencing elements of such sections must be resolved to the merged locations of the referenced values. Note that any relocatable values, including values that would result in run-time relocations, must be analyzed to determine whether the run-time values would actually be identical. An ABI-conforming object file may not depend on specific elements - being merged, and an ABI-conforming link editor + being merged, and an ABI-conforming link editor may choose not to merge specific elements. SHF_STRINGS 0x20 the data elements in the section consist of - null-terminated character strings. The size of + null-terminated character strings. The size of each character is specified in the section header's sh_entsize field. SHF_INFO_LINK 0x40 the sh_info field of this section header holds a @@ -228,7 +243,7 @@ object (self) to avoid incorrect behavior. If this section has either an sh_type value or contains sh_flags bits in the OS-specific ranges for those fields, and a - link editor processing this section does not + link editor processing this section does not recognize those values, then the link editor should reject the object file containing this section with an error. @@ -252,8 +267,8 @@ object (self) before relocations can be applied. Each decompressed section specifies the algorithm independently. It is permissible for different sections in a given - ELF object to employ different compression - algorithms. + ELF object to employ different compression + algorithms. Compressed sections begin with a compression header structure that identifies the compression algorithm. SHF_PPC_VLE 0x10000000 marks ELF sections containing powerpc VLE @@ -263,7 +278,7 @@ object (self) (* 12, 4, sh_addr ------------------------------------------------------ If the section will appear in the memory image of a process, this member - gives the address at which the section's first byte should reside. + gives the address at which the section's first byte should reside. Otherwise, the member contains 0. --------------------------------------------------------------------- *) sh_addr <- input#read_doubleword ; @@ -283,10 +298,10 @@ object (self) sh_size <- input#read_doubleword ; (* 24, 4, sh_link ------------------------------------------------------ - Section header table index link, whose interpretation depends on the + Section header table index link, whose interpretation depends on the section type. sh_type sh_link - SHT_DYNAMIC section header index of the string table used by + SHT_DYNAMIC section header index of the string table used by entries in the section SHT_HASH section header index of the symbol table to which the hash table applies @@ -322,7 +337,7 @@ object (self) sh_info <- input#read_doubleword ; (* 32, 4, sh_addralign ------------------------------------------------- - Some sections have address alignment constraints. For example, if a + Some sections have address alignment constraints. For example, if a section holds a doubleword, the system must ensure doubleword alignment for the entire section. The value of sh_addr must be congruent to 0, modulo the value of sh_addralign. Currently, only 0 and positive @@ -337,14 +352,14 @@ object (self) The member contains 0 if the section does not hold a table of fixed-size entries. --------------------------------------------------------------------- *) - sh_entsize <- input#read_doubleword + sh_entsize <- input#read_doubleword end method set_name s = name <- s method set_link d = sh_link <- d - method get_name = sh_name + method get_name = sh_name method get_type = sh_type @@ -370,6 +385,8 @@ object (self) method is_executable = sh_flags#is_nth_bit_set 2 + method is_readonly = not (sh_flags#is_nth_bit_set 0) + method is_string_table = match self#get_section_type with SHT_StrTab -> true | _ -> false @@ -379,6 +396,9 @@ object (self) method is_relocation_table = match self#get_section_type with SHT_Rel -> true | _ -> false + method is_uninitialized_data_section = + match self#get_section_type with SHT_NoBits -> true | _ -> false + method is_program_section = match self#get_section_type with SHT_ProgBits -> true | _ -> false diff --git a/CodeHawk/CHB/bchlibelf/bCHELFSymbolTable.ml b/CodeHawk/CHB/bchlibelf/bCHELFSymbolTable.ml index 40ba3457..49ea46e2 100644 --- a/CodeHawk/CHB/bchlibelf/bCHELFSymbolTable.ml +++ b/CodeHawk/CHB/bchlibelf/bCHELFSymbolTable.ml @@ -135,6 +135,8 @@ object (self) method get_st_type = st_info land 15 + method get_st_size = st_size + method get_st_value = st_value method get_value = st_value @@ -145,6 +147,11 @@ object (self) method has_address_value = not (st_value#equal wordzero) + method has_size = not (st_size#equal wordzero) + + method get_size: int option = + if self#has_size then Some st_size#to_int else None + method write_xml (node:xml_element_int) = let set = node#setAttribute in let seti = node#setIntAttribute in @@ -243,14 +250,15 @@ object method set_data_object_names = H.iter (fun _ e -> if e#is_data_object && e#has_address_value && e#has_name then - let cdef = { - xconst_name = e#get_name; - xconst_value = e#get_st_value; - xconst_type = BCHBCTypeUtil.t_unknown; - xconst_desc = "symbol-table"; - xconst_is_addr = true; - } in - BCHConstantDefinitions.add_address cdef + match (BCHGlobalMemoryMap.global_memory_map#add_location + ~name:(Some e#get_name) + ~desc:(Some "symbol-table") + ~size:e#get_size + e#get_st_value) with + | Error e -> + ch_error_log#add + "ELF: set_data_object_names" (STR (String.concat "; " e)) + | _ -> () else () ) entries diff --git a/CodeHawk/CHB/bchlibelf/bCHELFTypes.mli b/CodeHawk/CHB/bchlibelf/bCHELFTypes.mli index 0f0cc0b5..71d69580 100644 --- a/CodeHawk/CHB/bchlibelf/bCHELFTypes.mli +++ b/CodeHawk/CHB/bchlibelf/bCHELFTypes.mli @@ -1,9 +1,9 @@ (* ============================================================================= - CodeHawk Binary Analyzer + CodeHawk Binary Analyzer Author: A. Cody Schuffelen and Henny Sipma ------------------------------------------------------------------------------ The MIT License (MIT) - + Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020 Henny Sipma Copyright (c) 2021-2024 Aarno Labs LLC @@ -14,10 +14,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,11 +31,11 @@ References used: The standard /usr/include/elf.h in Arch Linux - The latest draft of the System V Application Binary Interface: + The latest draft of the System V Application Binary Interface: http://www.sco.com/developers/gabi/latest/contents.html - March 19, 1997 draft copy of the Intel Supplement to the System V + March 19, 1997 draft copy of the Intel Supplement to the System V Application Binary Interface - ----------------------------------------------------------------------------- *) + ----------------------------------------------------------------------------- *) (* chlib *) open CHNumerical @@ -51,47 +51,47 @@ open BCHLibTypes open BCHDwarfTypes -type elf_section_header_type_t = - | SHT_NullSection +type elf_section_header_type_t = + | SHT_NullSection | SHT_ProgBits - | SHT_SymTab - | SHT_StrTab - | SHT_Rela - | SHT_Hash - | SHT_Dynamic - | SHT_Note - | SHT_NoBits - | SHT_Rel - | SHT_ShLib - | SHT_DynSym - | SHT_InitArray + | SHT_SymTab + | SHT_StrTab + | SHT_Rela + | SHT_Hash + | SHT_Dynamic + | SHT_Note + | SHT_NoBits + | SHT_Rel + | SHT_ShLib + | SHT_DynSym + | SHT_InitArray | SHT_FiniArray - | SHT_PreinitArray - | SHT_Group + | SHT_PreinitArray + | SHT_Group | SHT_SymTabShndx | SHT_GNU_verdef | SHT_GNU_verneed | SHT_GNU_versym | SHT_MIPS_RegInfo - | SHT_OSSection of doubleword_int - | SHT_ProcSection of doubleword_int - | SHT_UserSection of doubleword_int + | SHT_OSSection of doubleword_int + | SHT_ProcSection of doubleword_int + | SHT_UserSection of doubleword_int | SHT_UnknownType of doubleword_int - + type elf_program_header_type_t = - | PT_Null - | PT_Load - | PT_Dynamic - | PT_Interpreter - | PT_Note - | PT_Reference + | PT_Null + | PT_Load + | PT_Dynamic + | PT_Interpreter + | PT_Note + | PT_Reference | PT_ThreadLocalStorage | PT_RegInfo - | PT_OSSpecific of doubleword_int + | PT_OSSpecific of doubleword_int | PT_ProcSpecific of doubleword_int type elf_dynamic_tag_value_t = DTV_d_val | DTV_d_ptr | DTV_d_none - + type elf_dynamic_tag_t = | DT_Null | DT_Needed @@ -205,7 +205,7 @@ class type elf_dictionary_int = method read_xml: xml_element_int -> unit method toPretty: pretty_t end - + class type elf_raw_section_int = object method get_size: int @@ -248,16 +248,19 @@ class type elf_string_table_int = class type elf_symbol_table_entry_int = object method id: int - method read: pushback_stream_int -> unit + method read: pushback_stream_int -> unit method set_name: string -> unit method get_name: string method get_st_binding: int method get_st_type: int method get_st_name: doubleword_int method get_st_value: doubleword_int + method get_st_size: doubleword_int method get_value: doubleword_int + method get_size: int option method has_address_value: bool method has_name: bool + method has_size: bool method is_function: bool method is_data_object: bool method to_rep_record: string list * int list @@ -761,10 +764,12 @@ object (* predicates *) method is_executable: bool + method is_readonly: bool method is_string_table: bool method is_symbol_table: bool method is_relocation_table: bool method is_program_section: bool + method is_uninitialized_data_section: bool method is_pwr_vle: bool method is_debug_info: bool @@ -786,12 +791,17 @@ object method read: unit method set_code_extent: unit + method set_global_data_sections_extent: unit method initialize_jump_tables: unit method initialize_call_back_tables: unit method initialize_struct_tables: unit + method add_new_user_defined_section_headers: unit (* only for unit tests *) (* accessors *) + + (** Returns the entry point as specified in the elf file header.*) method get_program_entry_point: doubleword_int + method get_sections: (int * elf_section_header_int * elf_section_t) list method get_program_segments: (int * elf_program_header_int * elf_segment_t) list method get_executable_sections: (elf_section_header_int * string) list @@ -814,6 +824,13 @@ object (** [is_data_address va] returns [true] if virtual address [va] is an address within a program section that is not an executable section. *) method is_data_address: doubleword_int -> bool + + (** [read_readonly_address va] returns [true] if virtual address [va] is an + address within a program section that is not writeable (it may be + executable). *) + method is_readonly_address: doubleword_int -> bool + + method is_uninitialized_data_address: doubleword_int -> bool method is_global_offset_table_address: doubleword_int -> bool method has_xsubstring: doubleword_int -> int -> bool method has_debug_info: bool diff --git a/CodeHawk/CHB/bchlibmips32/bCHDisassembleMIPS.ml b/CodeHawk/CHB/bchlibmips32/bCHDisassembleMIPS.ml index 48909ac4..5fff5eed 100644 --- a/CodeHawk/CHB/bchlibmips32/bCHDisassembleMIPS.ml +++ b/CodeHawk/CHB/bchlibmips32/bCHDisassembleMIPS.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 @@ -585,8 +585,10 @@ let get_successors (faddr:doubleword_int) (iaddr:doubleword_int) = let trace_block (faddr:doubleword_int) (baddr:doubleword_int) = let set_block_entry (va: doubleword_int) = - TR.titer (fun instr -> - instr#set_block_entry) (get_mips_assembly_instruction va) in + TR.titer + ~ok:(fun instr -> instr#set_block_entry) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) + (get_mips_assembly_instruction va) in let get_instr iaddr = get_mips_assembly_instruction iaddr in @@ -717,7 +719,8 @@ let trace_function (faddr:doubleword_int) = let doneSet = new DoublewordCollections.set_t in let set_block_entry (baddr: doubleword_int) = TR.titer - (fun instr -> instr#set_block_entry) + ~ok:(fun instr -> instr#set_block_entry) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) (get_mips_assembly_instruction baddr) in let get_iaddr s = (ctxt_string_to_location faddr s)#i in let add_to_workset l = diff --git a/CodeHawk/CHB/bchlibmips32/bCHFnMIPSDictionary.ml b/CodeHawk/CHB/bchlibmips32/bCHFnMIPSDictionary.ml index 3c368591..5ef247aa 100644 --- a/CodeHawk/CHB/bchlibmips32/bCHFnMIPSDictionary.ml +++ b/CodeHawk/CHB/bchlibmips32/bCHFnMIPSDictionary.ml @@ -718,7 +718,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:1 ~vtype:t_char in + ~signed:true + ~addr:xaddr + ~var:vmem + ~size:1 + ~vtype:t_char in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -741,7 +745,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:1 ~vtype:t_uchar in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:1 + ~vtype:t_uchar in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -764,7 +772,11 @@ object (self) let useshigh = [get_def_use_high vft] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:8 ~vtype:t_double in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:8 + ~vtype:t_double in let (tagstring, args) = mk_instrx_data ~vars:[vft; vmem] @@ -787,7 +799,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:2 ~vtype:t_short in + ~signed:true + ~addr:xaddr + ~var:vmem + ~size:2 + ~vtype:t_short in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -810,7 +826,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:2 ~vtype:t_ushort in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:2 + ~vtype:t_ushort in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -842,7 +862,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_int in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_int in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -876,7 +900,11 @@ object (self) let useshigh = [get_def_use_high vrt] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_int in + ~signed:true + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_int in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -899,7 +927,11 @@ object (self) let useshigh = [get_def_use_high vft] in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_float in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_float in let (tagstring, args) = mk_instrx_data ~vars:[vft; vmem] @@ -928,7 +960,11 @@ object (self) 4 - alignment in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size ~vtype:t_unknown in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size + ~vtype:t_unknown in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -957,7 +993,11 @@ object (self) alignment + 1 in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size ~vtype:t_unknown in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size + ~vtype:t_unknown in let (tagstring, args) = mk_instrx_data ~vars:[vrt; vmem] @@ -1383,7 +1423,11 @@ object (self) let rdefs = (get_rdef_memvar vmem) :: (get_all_rdefs xaddr) in let _ = floc#memrecorder#record_load - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_unknown in + ~signed:false + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_unknown in let (tagstring, args) = mk_instrx_data ~vars:[vmem] ~xprs:[xaddr] ~rdefs () in ([tagstring], args) @@ -1654,7 +1698,10 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:1 ~vtype:t_char ~xpr:xxrt in + ~addr:xaddr + ~var:vmem + ~size:1 + ~vtype:t_char ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1678,7 +1725,10 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:2 ~vtype:t_short ~xpr:xxrt in + ~addr:xaddr + ~var:vmem + ~size:2 + ~vtype:t_short ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1702,7 +1752,11 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_int ~xpr:xxrt in + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_int + ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1726,7 +1780,11 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_float ~xpr:xxft in + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_float + ~xpr:xxft in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1750,7 +1808,11 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:8 ~vtype:t_double ~xpr:xxft in + ~addr:xaddr + ~var:vmem + ~size:8 + ~vtype:t_double + ~xpr:xxft in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1774,7 +1836,11 @@ object (self) let useshigh = [get_def_use_high vmem] in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size:4 ~vtype:t_int ~xpr:xxrt in + ~addr:xaddr + ~var:vmem + ~size:4 + ~vtype:t_int + ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1804,7 +1870,10 @@ object (self) 4 - alignment in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size ~vtype:t_unknown ~xpr:xxrt in + ~addr:xaddr + ~var:vmem ~size + ~vtype:t_unknown + ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] @@ -1834,7 +1903,11 @@ object (self) alignment + 1 in let _ = floc#memrecorder#record_store - ~addr:xaddr ~var:vmem ~size ~vtype:t_unknown ~xpr:xxrt in + ~addr:xaddr + ~var:vmem + ~size + ~vtype:t_unknown + ~xpr:xxrt in let (tagstring, args) = mk_instrx_data ~vars:[vmem] diff --git a/CodeHawk/CHB/bchlibmips32/bCHTranslateMIPSToCHIF.ml b/CodeHawk/CHB/bchlibmips32/bCHTranslateMIPSToCHIF.ml index abc7fdb4..b60354f5 100644 --- a/CodeHawk/CHB/bchlibmips32/bCHTranslateMIPSToCHIF.ml +++ b/CodeHawk/CHB/bchlibmips32/bCHTranslateMIPSToCHIF.ml @@ -1738,10 +1738,17 @@ object (self) ignore (env#mk_symbolic_variable ~domains:["reachingdefs"] initVar) in ASSERT (EQ (regVar, initVar)) in let freeze_external_memory_values (v:variable_t) = - let initVar = env#mk_initial_memory_value v in - let _ = - ignore (env#mk_symbolic_variable ~domains:["reachingdefs"] initVar) in - ASSERT (EQ (v, initVar)) in + TR.tfold + ~ok:(fun initVar -> + let _ = + ignore (env#mk_symbolic_variable ~domains:["reachingdefs"] initVar) in + ASSERT (EQ (v, initVar))) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + SKIP + end) + (env#mk_initial_memory_value v) in let t9Assign = let t9Var = env#mk_mips_register_variable MRt9 in let reqN () = env#mk_num_temp in diff --git a/CodeHawk/CHB/bchlibpe/bCHPEHeader.ml b/CodeHawk/CHB/bchlibpe/bCHPEHeader.ml index 1d6d6d27..bc9c84aa 100644 --- a/CodeHawk/CHB/bchlibpe/bCHPEHeader.ml +++ b/CodeHawk/CHB/bchlibpe/bCHPEHeader.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2019 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -914,8 +914,16 @@ object (self) method get_section_headers = H.fold (fun _ v a -> v::a) section_headers [] - method read = - let exeString = system_info#get_file_string wordzero in + method read = + let exeString = + match system_info#get_file_string wordzero with + | Ok s -> s + | Error e -> + raise + (BCH_failure + (LBLOCK [STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Error in reading binary file: "; + STR (String.concat "; " e)])) in let ch = make_pushback_stream exeString in begin ch#skip_bytes 0x3c; (* file offset to the PE signature is at address 0x3c *) @@ -969,23 +977,25 @@ object (self) method private set_SE_handlers = () - method private load_section sectionHeader = - try - let fileOffset = sectionHeader#get_pointer_to_raw_data in - let rawSize = sectionHeader#get_size_of_raw_data in - let exeString = system_info#get_file_string ~hexSize:rawSize fileOffset in - pe_sections#add_section sectionHeader exeString - with - | BCH_failure p -> + method private load_section (sectionHeader: pe_section_header_int) = + let fileOffset = sectionHeader#get_pointer_to_raw_data in + let rawSize = sectionHeader#get_size_of_raw_data in + let exeString_r = system_info#get_file_string ~hexSize:rawSize fileOffset in + match exeString_r with + | Ok s -> pe_sections#add_section sectionHeader s + | Error e -> raise (BCH_failure (LBLOCK [ - STR "load-section: rawsize: "; + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to load PE section "; + STR sectionHeader#get_name; + STR " with raw size: "; sectionHeader#get_size_of_raw_data#toPretty; - STR "; offset: "; + STR " and offset: "; sectionHeader#get_pointer_to_raw_data#toPretty; STR ": "; - p])) + STR (String.concat "; " e)])) method private read_sections = List.iter (fun h -> @@ -998,18 +1008,18 @@ object (self) else let fileOffset = coff_file_header#get_pointer_to_symbol_table in let nSymbols = coff_file_header#get_number_of_symbols in - try - let exeString = system_info#get_file_string fileOffset in - pe_symboltable#read fileOffset nSymbols exeString - with - | BCH_failure p -> + let exeString_r = system_info#get_file_string fileOffset in + match exeString_r with + | Ok s -> pe_symboltable#read fileOffset nSymbols s + | Error e -> ch_error_log#add "read symbol table" (LBLOCK [ - STR "read-symboltable: fileOffset: "; + STR __FILE__; STR ":"; INT __LINE__; STR ": "; + STR "Unable to read PE symbol table at offset: "; fileOffset#toPretty; STR ": "; - p]) + STR (String.concat "; " e)]) method coff_file_header_to_pretty = coff_file_header#toPretty diff --git a/CodeHawk/CHB/bchlibpower32/bCHConstructPowerFunction.ml b/CodeHawk/CHB/bchlibpower32/bCHConstructPowerFunction.ml index 31e732f3..af1e4382 100644 --- a/CodeHawk/CHB/bchlibpower32/bCHConstructPowerFunction.ml +++ b/CodeHawk/CHB/bchlibpower32/bCHConstructPowerFunction.ml @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2023-2024 Aarno Labs LLC + Copyright (c) 2023-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 @@ -290,7 +290,8 @@ let construct_pwr_assembly_function List.iter (fun a -> if doneset#has a then () else workset#add a) l in let set_block_entry (baddr: doubleword_int) = TR.titer - (fun instr -> instr#set_block_entry) + ~ok:(fun instr -> instr#set_block_entry) + ~error:(fun e -> log_error_result __FILE__ __LINE__ e) (get_pwr_assembly_instruction baddr) in let blocks = ref [] in let rec add_block (baddr: doubleword_int) = diff --git a/CodeHawk/CHB/bchlibpower32/bCHTranslatePowerToCHIF.ml b/CodeHawk/CHB/bchlibpower32/bCHTranslatePowerToCHIF.ml index cb71de5d..a76163f5 100644 --- a/CodeHawk/CHB/bchlibpower32/bCHTranslatePowerToCHIF.ml +++ b/CodeHawk/CHB/bchlibpower32/bCHTranslatePowerToCHIF.ml @@ -869,10 +869,17 @@ object (self) (finfo#env#mk_symbolic_variable ~domains:["reachingdefs"] initvar) in ASSERT (EQ (regvar, initvar)) in let freeze_external_memory_values (v: variable_t) = - let initVar = env#mk_initial_memory_value v in - let _ = - ignore (finfo#env#mk_symbolic_variable ~domains:["reachingdefs"] initVar) in - ASSERT (EQ (v, initVar)) in + TR.tfold + ~ok:(fun initVar -> + let _ = + ignore (finfo#env#mk_symbolic_variable ~domains:["reachingdefs"] initVar) in + ASSERT (EQ (v, initVar))) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + SKIP + end) + (env#mk_initial_memory_value v) in let gprAsserts = List.map freeze_initial_gp_register_value (List.init 32 (fun i -> i)) in let sprAsserts = diff --git a/CodeHawk/CHB/bchlibx86/bCHAssemblyInstructionAnnotations.ml b/CodeHawk/CHB/bchlibx86/bCHAssemblyInstructionAnnotations.ml index 7ed30503..81a63860 100644 --- a/CodeHawk/CHB/bchlibx86/bCHAssemblyInstructionAnnotations.ml +++ b/CodeHawk/CHB/bchlibx86/bCHAssemblyInstructionAnnotations.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -47,7 +47,6 @@ open Xsimplify open BCHBasicTypes open BCHBCTypeUtil open BCHCallTarget -open BCHConstantDefinitions open BCHCPURegisters open BCHDemangler open BCHDoubleword @@ -132,7 +131,7 @@ let create_annotation_aux (floc:floc_int) = let xpr_formatter = make_xpr_formatter sym_printer variable_to_pretty in let pr_expr ?(typespec=None) ?(partype=t_unknown) x = let x = simplify_xpr x in - match get_xpr_symbolic_name ~typespec x with + match BCHConstantDefinitions.get_xpr_symbolic_name ~typespec x with | Some name -> STR name | _ -> if is_unsigned partype then @@ -158,12 +157,15 @@ let create_annotation_aux (floc:floc_int) = LBLOCK [STR "ds:"; (TR.tget_ok (numerical_to_doubleword n))#toPretty] | _ -> if floc#is_address xpr then - let (memref,memoffset) = floc#decompose_address xpr in + let (memref, memoffset) = floc#decompose_address xpr in if is_constant_offset memoffset then - let offset = get_total_constant_offset memoffset in - LBLOCK [ - STR "&"; - variable_to_pretty (env#mk_memory_variable memref offset)] + TR.tfold_default + (fun offset -> + LBLOCK [ + STR "&"; + variable_to_pretty (env#mk_memory_variable memref offset)]) + (pr_expr xpr) + (get_total_constant_offset memoffset) else if memref#is_unknown_reference then pr_expr xpr else @@ -173,7 +175,7 @@ let create_annotation_aux (floc:floc_int) = let pr_sum_argument_expr (ct: call_target_info_int) (p: fts_parameter_t) (xpr: xpr_t) = let typespec = ct#get_enum_type p in - match get_xpr_symbolic_name ~typespec xpr with + match BCHConstantDefinitions.get_xpr_symbolic_name ~typespec xpr with | Some name -> STR name | _ -> pr_argument_expr ~typespec p xpr in let lhs_to_pretty (_lhs_op:operand_int) (var:variable_t) = @@ -275,7 +277,7 @@ let create_annotation_aux (floc:floc_int) = let rhs_pp = match get_string_reference floc rhs with | Some s -> STR s | _ -> - match get_xpr_symbolic_name rhs with + match BCHConstantDefinitions.get_xpr_symbolic_name rhs with | Some name -> STR name | _ -> rhs_to_pretty ~partype:param.apar_type rhs in make_annotation FunctionArgument @@ -1109,7 +1111,7 @@ let create_annotation_aux (floc:floc_int) = let rhs_pp = match get_string_reference floc rhs with | Some s -> STR s | _ -> - match get_xpr_symbolic_name rhs with + match BCHConstantDefinitions.get_xpr_symbolic_name rhs with | Some name -> STR name | _ -> rhs_to_pretty ~partype:param.apar_type rhs in let pp = diff --git a/CodeHawk/CHB/bchlibx86/bCHPredefinedUtil.ml b/CodeHawk/CHB/bchlibx86/bCHPredefinedUtil.ml index 56d4970f..479ef736 100644 --- a/CodeHawk/CHB/bchlibx86/bCHPredefinedUtil.ml +++ b/CodeHawk/CHB/bchlibx86/bCHPredefinedUtil.ml @@ -6,7 +6,7 @@ Copyright (c) 2005-2020 Kestrel Technology LLC Copyright (c) 2020 Henny B. 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 @@ -45,7 +45,6 @@ open Xsimplify open BCHBasicTypes open BCHBCTypeUtil open BCHByteUtilities -open BCHConstantDefinitions open BCHCPURegisters open BCHDoubleword open BCHFtsParameter @@ -187,14 +186,18 @@ let xpr_to_strpretty (floc:floc_int) (x:xpr_t) = LBLOCK [STR "ds:"; (TR.tget_ok (numerical_to_doubleword n))#toPretty] | _ -> if floc#is_address x then - let (memref,memoffset) = floc#decompose_address x in + let (memref, memoffset) = floc#decompose_address x in if is_constant_offset memoffset then - let offset = get_total_constant_offset memoffset in - LBLOCK [ - STR "&"; - xpr_to_pretty - floc - (XVar (floc#env#mk_memory_variable memref offset ))] + (* let offset_r = get_total_constant_offset memoffset in *) + TR.tfold_default + (fun offset -> + LBLOCK [ + STR "&"; + xpr_to_pretty + floc + (XVar (floc#env#mk_memory_variable memref offset))]) + (default ()) + (get_total_constant_offset memoffset) else if memref#is_unknown_reference then default () else @@ -211,7 +214,7 @@ let pr_argument_expr | Some s -> STR ("\"" ^ s ^ "\"") | _ -> let x = simplify_xpr xpr in - match get_xpr_symbolic_name ~typespec x with + match BCHConstantDefinitions.get_xpr_symbolic_name ~typespec x with | Some name -> STR name | _ -> xpr_to_pretty floc x @@ -277,7 +280,10 @@ let get_x_derefvalue (x:xpr_t) (offset:int) (floc:floc_int) = let (memref,memoffset) = floc#decompose_address x in if is_constant_offset memoffset then let memvar = - floc#env#mk_memory_variable memref (get_total_constant_offset memoffset) in + TR.tfold_default + (fun offset -> floc#env#mk_memory_variable memref offset) + (floc#env#mk_unknown_memory_variable "x-deref") + (get_total_constant_offset memoffset) in floc#inv#rewrite_expr (XVar memvar) else XVar (floc#env#mk_unknown_memory_variable "x-deref") @@ -313,7 +319,10 @@ let get_x_deref_lhs (x:xpr_t) (offset:int) (floc:floc_int) = let x = floc#inv#rewrite_expr (XOp (XPlus, [x; int_constant_expr offset])) in let (memref,memoffset) = floc#decompose_address x in if is_constant_offset memoffset then - floc#env#mk_memory_variable memref (get_total_constant_offset memoffset) + TR.tfold_default + (fun offset -> floc#env#mk_memory_variable memref offset) + (floc#env#mk_unknown_memory_variable "x-deref-lhs") + (get_total_constant_offset memoffset) else floc#env#mk_unknown_memory_variable "x-deref-lhs" diff --git a/CodeHawk/CHB/bchlibx86/bCHTranslateToCHIF.ml b/CodeHawk/CHB/bchlibx86/bCHTranslateToCHIF.ml index 6cdec8b8..a6e98e1b 100644 --- a/CodeHawk/CHB/bchlibx86/bCHTranslateToCHIF.ml +++ b/CodeHawk/CHB/bchlibx86/bCHTranslateToCHIF.ml @@ -70,6 +70,7 @@ open BCHX86OpcodeRecords module B = Big_int_Z module LF = CHOnlineCodeSet.LanguageFactory module FFU = BCHFileFormatUtil +module TR = CHTraceResult let cmd_to_pretty = CHLanguage.command_to_pretty 0 @@ -1999,8 +2000,6 @@ let translate_instruction (* different control flow *) | RepzRet | Ret _ | BndRet _ -> - let floc = get_floc loc in - let _ = floc#record_return_value in let transaction = package_transaction finfo block_label (commands @ [invariantOperation]) in let nodes = [(block_label, [transaction])] in @@ -2247,8 +2246,14 @@ object (self) let initVar = env#mk_initial_register_value (CPURegister reg) in ASSERT (EQ (regVar, initVar)) in let freeze_external_memory_values (v:variable_t) = - let initVar = env#mk_initial_memory_value v in - ASSERT (EQ (v, initVar)) in + TR.tfold + ~ok:(fun initVar -> ASSERT (EQ (v, initVar))) + ~error:(fun e -> + begin + log_error_result __FILE__ __LINE__ e; + SKIP + end) + (env#mk_initial_memory_value v) in let rAsserts = List.map freeze_initial_register_value full_registers in let externalMemVars = env#get_external_memory_variables in let externalMemVars = List.filter env#has_constant_offset externalMemVars in diff --git a/CodeHawk/CHB/bchsummaries/so_functions/abort.xml b/CodeHawk/CHB/bchsummaries/so_functions/abort.xml new file mode 100644 index 00000000..a15618e2 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/abort.xml @@ -0,0 +1,34 @@ + + + +
+ + + generates an abnormal process abort + + void abort (void) + + + + + void + + + + + + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/floor.xml b/CodeHawk/CHB/bchsummaries/so_functions/floor.xml new file mode 100644 index 00000000..c185dc2c --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/floor.xml @@ -0,0 +1,31 @@ + + + +
+ + + floor function + + double floor (double x) + argument to floor function + + floor x + NaN + + + + + + double + + double + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/floorf.xml b/CodeHawk/CHB/bchsummaries/so_functions/floorf.xml new file mode 100644 index 00000000..b04ab527 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/floorf.xml @@ -0,0 +1,31 @@ + + + +
+ + + floor function + + float floorf (float x) + argument to floorf function + + floorf x + NaN + + + + + + float + + float + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/log.xml b/CodeHawk/CHB/bchsummaries/so_functions/log.xml new file mode 100644 index 00000000..7c345e0f --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/log.xml @@ -0,0 +1,31 @@ + + + +
+ + + natural logarithm function + + double log (double x) + argument to natural logarithm + + natural logarithm of x + NaN + + + + + + double + + double + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/logf.xml b/CodeHawk/CHB/bchsummaries/so_functions/logf.xml new file mode 100644 index 00000000..83f4ff8b --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/logf.xml @@ -0,0 +1,31 @@ + + + +
+ + + natural logarithm function + + float logf (float x) + argument to natural logarithm + + natural logarithm of x + NaN + + + + + + float + + float + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/mkdir.xml b/CodeHawk/CHB/bchsummaries/so_functions/mkdir.xml new file mode 100644 index 00000000..fd31dab0 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/mkdir.xml @@ -0,0 +1,48 @@ + + + +
+ + + makes a directory + + + int mkdir( + const char *path + int mode + ) + + name for new directory + permission bits + + 0 + -1 + + + + + + char +
+ + + + + + int + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/pthread_create.xml b/CodeHawk/CHB/bchsummaries/so_functions/pthread_create.xml index fe233fa2..40895e33 100644 --- a/CodeHawk/CHB/bchsummaries/so_functions/pthread_create.xml +++ b/CodeHawk/CHB/bchsummaries/so_functions/pthread_create.xml @@ -32,7 +32,7 @@ pthread_attr_t - function-pointer + pthread_start_routine void diff --git a/CodeHawk/CHB/bchsummaries/so_functions/pthread_exit.xml b/CodeHawk/CHB/bchsummaries/so_functions/pthread_exit.xml new file mode 100644 index 00000000..7e4e99d1 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/pthread_exit.xml @@ -0,0 +1,41 @@ + + + +
+ + + thread termination + + void pthread_exit (void *value_ptr) + + value made available to any successful join with the terminating + thread + + + + + + + void + + void + + + + + + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/rmdir.xml b/CodeHawk/CHB/bchsummaries/so_functions/rmdir.xml new file mode 100644 index 00000000..abac0365 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/rmdir.xml @@ -0,0 +1,39 @@ + + + +
+ + + removes a directory + + int rmdir (const char *path) + name of directory to be removed + + 0 + -1 + + + + + + char +
+ + + + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sem_init.xml b/CodeHawk/CHB/bchsummaries/so_functions/sem_init.xml new file mode 100644 index 00000000..a3b2d758 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sem_init.xml @@ -0,0 +1,53 @@ + + + +
+ + + initializes an unnamed semaphore + + + int sem_init( + sem_t *sem + int pshared + unsigned int value + ) + + semaphore to be initialized + to be shared between processes if non-zero + initial value for the semaphore + + 0 + -1 + + + + + +
+ int + + + + + + int + + + unsigned int + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sem_post.xml b/CodeHawk/CHB/bchsummaries/so_functions/sem_post.xml new file mode 100644 index 00000000..8777aee0 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sem_post.xml @@ -0,0 +1,39 @@ + + + +
+ + + unlocks a semaphore + + int sem_post (int *sem) + semaphore + + 0 + -1 + + + + + + int +
+ + + + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sem_wait.xml b/CodeHawk/CHB/bchsummaries/so_functions/sem_wait.xml new file mode 100644 index 00000000..a582f8f1 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sem_wait.xml @@ -0,0 +1,39 @@ + + + +
+ + + locks a semaphore + + int sem_wait (int *sem) + semaphore to be locked + + 0 + -1 + + + + + + int +
+ + + + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sin.xml b/CodeHawk/CHB/bchsummaries/so_functions/sin.xml new file mode 100644 index 00000000..b45e25fb --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sin.xml @@ -0,0 +1,31 @@ + + + +
+ + + sine function + + double sin (double x) + argument to sine function + + sine x + NaN + + + + + + double + + double + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sinf.xml b/CodeHawk/CHB/bchsummaries/so_functions/sinf.xml new file mode 100644 index 00000000..f005c6e1 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sinf.xml @@ -0,0 +1,31 @@ + + + +
+ + + sine function + + float sinf (float x) + argument to sine function + + sine of x + NaN + + + + + + float + + float + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sqrt.xml b/CodeHawk/CHB/bchsummaries/so_functions/sqrt.xml new file mode 100644 index 00000000..4a7d0395 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sqrt.xml @@ -0,0 +1,31 @@ + + + +
+ + + square root function + + double sqrt (double x) + argument to sqrt function + + sqrt x + NaN + + + + + + double + + double + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/sqrtf.xml b/CodeHawk/CHB/bchsummaries/so_functions/sqrtf.xml new file mode 100644 index 00000000..ee3fb4ee --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/sqrtf.xml @@ -0,0 +1,31 @@ + + + +
+ + + square root function + + float sqrtf (float x) + argument to sqrt function + + sqrt x + NaN + + + + + + float + + float + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/symlink.xml b/CodeHawk/CHB/bchsummaries/so_functions/symlink.xml new file mode 100644 index 00000000..80d0ae89 --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/symlink.xml @@ -0,0 +1,52 @@ + + + +
+ + + makes a symbolic link + + + int symlink( + const char *path1 + const char *path2 + ) + + string contained in the symbolic link + name of the symbolic link created + + 0 + -1 + + + + + + char +
+ + + + + + char +
+ + + + + int + + + + + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/trunc.xml b/CodeHawk/CHB/bchsummaries/so_functions/trunc.xml new file mode 100644 index 00000000..f879616a --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/trunc.xml @@ -0,0 +1,31 @@ + + + +
+ + + round to truncated integer value + + double trunc (double x) + argument to trunc function + + trunc x + NaN + + + + + + double + + double + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHB/bchsummaries/so_functions/truncf.xml b/CodeHawk/CHB/bchsummaries/so_functions/truncf.xml new file mode 100644 index 00000000..55acdeed --- /dev/null +++ b/CodeHawk/CHB/bchsummaries/so_functions/truncf.xml @@ -0,0 +1,31 @@ + + + +
+ + + round to truncated integer value + + float truncf (float x) + argument to trunc function + + truncf x + NaN + + + + + + float + + float + + + + + + + + + Copyright 2012-2024, Henny Sipma, Palo Alto, CA 94304 + diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.ml b/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.ml index 1214a962..df51cc1d 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.ml +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.ml @@ -71,6 +71,19 @@ let equal_doubleword = A.make_equal (fun dw1 dw2 -> dw1#equal dw2) (fun dw -> dw#to_hex_string) +let equal_numerical + ?(msg="") + ~(expected: numerical_t) + ~(received: numerical_t) + () = + A.make_equal + (fun num1 num2 -> num1#equal num2) + (fun num -> num#toString) + ~msg + expected + received + + let equal_doubleword_result ?(msg="") (dw: doubleword_int) (dwr: doubleword_result) = if Result.is_error dwr then @@ -125,10 +138,10 @@ let equal_string_imm_result_string let equal_array_index_offset ?(msg="") - ~(expected: (xpr_t * numerical_t) option) - ~(received: (xpr_t * numerical_t) option) + ~(expected: (xpr_t * xpr_t) option) + ~(received: (xpr_t * xpr_t) option) () = - let pri (x, n) = "(" ^ (x2s x) ^ ", " ^ n#toString ^ ")" in + let pri (x, r) = "(" ^ (x2s x) ^ ", " ^ (x2s r) ^ ")" in match (expected, received) with | (None, None) -> () | (Some x, None) -> @@ -137,8 +150,9 @@ let equal_array_index_offset A.fail_msg ("Expected None, but received Some " ^ (pri x)) | (Some x1, Some x2) -> A.make_equal - (fun (x1, n1) (x2, n2) -> ((x2s x1) = (x2s x2)) && n1#equal n2) - (fun (x, n) -> "(" ^ (x2s x) ^ ", " ^ n#toString ^ ")") + (fun (x1, r1) (x2, r2) -> + ((x2s x1) = (x2s x2)) && Xprt.syntactically_equal r1 r2) + (fun (x, r) -> "(" ^ (x2s x) ^ ", " ^ (x2s r) ^ ")") ~msg x1 x2 @@ -190,6 +204,22 @@ let equal_opt_meminfo x2 +let equal_opt_variable + ?(msg="") + ~(expected:(variable_t) option) + ~(received:(variable_t) option) + () = + let pri v = "(" ^ (p2s v#toPretty) ^ ")" in + match expected, received with + | None, None -> () + | Some v, None -> + A.fail_msg ("Expected Some " ^ (pri v) ^ ", but received None") + | None, Some v -> + A.fail_msg ("Expected None, but received Some " ^ (pri v)) + | Some v1, Some v2 -> + A.make_equal (fun v1 v2 -> v1#equal v2) pri ~msg v1 v2 + + let equal_assignments ?(msg="") (finfo: function_info_int) diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.mli b/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.mli index f111242a..bc6cafea 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.mli +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/tbchlib/tCHBchlibAssertion.mli @@ -54,6 +54,12 @@ val e32: int val equal_doubleword: ?msg:string -> doubleword_int -> doubleword_int -> unit +val equal_numerical: + ?msg:string + -> expected:numerical_t + -> received:numerical_t + -> unit + -> unit val equal_doubleword_result: ?msg:string -> doubleword_int -> doubleword_result -> unit @@ -79,8 +85,8 @@ val equal_string_imm_result_string: val equal_array_index_offset: ?msg:string - -> expected:(xpr_t * numerical_t) option - -> received:(xpr_t * numerical_t) option + -> expected:(xpr_t * xpr_t) option + -> received:(xpr_t * xpr_t) option -> unit -> unit @@ -101,6 +107,14 @@ val equal_opt_meminfo: -> unit +val equal_opt_variable: + ?msg:string + -> expected:(variable_t) option + -> received:(variable_t) option + -> unit + -> unit + + val equal_assignments: ?msg:string -> function_info_int diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHFlocTest.ml b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHFlocTest.ml index 21753efc..575ffcda 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHFlocTest.ml +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHFlocTest.ml @@ -26,9 +26,6 @@ SOFTWARE. ============================================================================= *) -(* chlib *) -open CHNumerical - (* xprlib *) open Xprt open XprTypes @@ -36,7 +33,6 @@ open XprTypes (* bchlib *) open BCHBCFiles open BCHBCTypes -open BCHConstantDefinitions open BCHDoubleword open BCHFloc open BCHFunctionData @@ -46,136 +42,155 @@ open BCHLibTypes (* bchcil *) open BCHParseCilFile +module A = TCHAssertion module TR = CHTraceResult module TS = TCHTestSuite module XBA = TCHBchlibAssertion +let mmap = BCHGlobalMemoryMap.global_memory_map + let testname = "bCHFlocTest" let lastupdated = "2024-08-20" -let decompose_memvar_address_test () = +let get_var_at_address_test () = + let secaddr = TR.tget_ok (string_to_doubleword "0x500000") in + let secsize = TR.tget_ok (string_to_doubleword "0x100000") in + let _ = mmap#set_section ~readonly:false ~initialized:false ".bss" secaddr secsize in let faddr = "0x1d6bfc" in let iaddr = "0x1d6cbc" in let gvaddr = "0x5e1e1c" in let dwfaddr = TR.tget_ok (string_to_doubleword faddr) in let dwiaddr = TR.tget_ok (string_to_doubleword iaddr) in let dwgvaddr = TR.tget_ok (string_to_doubleword gvaddr) in - let gvname = "x44_array" in + let dwgvxpr = num_constant_expr dwgvaddr#to_numerical in begin TS.new_testsuite - (testname ^ "_decompose_memvar_address_test") lastupdated; + (testname ^ "_get_var_at_address_test") lastupdated; parse_cil_file ~removeUnused:false "decompose_array_address.i"; ignore (functions_data#add_function dwfaddr); - - let arraysym = { - xconst_name = gvname; - xconst_value = dwgvaddr; - xconst_type = - if bcfiles#has_varinfo gvname then - let vinfo = bcfiles#get_varinfo gvname in - vinfo.bvtype - else - raise - (Invalid_argument "Error in arraysym"); - xconst_desc = "decompose_memvar_address"; - xconst_is_addr = true - } in - let _ = add_address arraysym in let compinfo = bcfiles#get_compinfo_by_name "x44_struct_t" in - let finfo = get_function_info dwfaddr in let floc = get_floc_by_address dwfaddr dwiaddr in - let ty = get_symbolic_address_type_by_name gvname in - let basevar = - finfo#env#mk_global_memory_address - ~optname:(Some gvname) ~opttype:(Some ty) dwgvaddr#to_numerical in - let memref = TR.tget_ok (floc#f#env#mk_base_variable_reference basevar) in + let gvar = TR.tget_ok (finfo#env#mk_global_variable dwgvaddr#to_numerical) in let indexvar = finfo#env#mk_initial_register_value (ARMRegister AR0) in let indexxpr1 = XOp (XMinus, [XVar indexvar; int_constant_expr 1]) in TS.add_simple_test ~title:"constant-68" (fun () -> - let xpr = XOp (XPlus, [XVar basevar; int_constant_expr 68]) in - let xpsuboffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(int_constant_expr 1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xpr = XOp (XPlus, [dwgvxpr; int_constant_expr 68]) in + let xpr = Xsimplify.simplify_xpr xpr in + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_int xpr in + let xpoffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(int_constant_expr 1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); TS.add_simple_test ~title:"constant-72" (fun () -> - let xpr = XOp (XPlus, [XVar basevar; int_constant_expr 72]) in - let xpsuboffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(int_constant_expr 1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xpr = XOp (XPlus, [dwgvxpr; int_constant_expr 72]) in + let xpr = Xsimplify.simplify_xpr xpr in + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_int xpr in + let xpoffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(int_constant_expr 1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); TS.add_simple_test ~title:"var-68" (fun () -> let xpr = - XOp (XPlus, [XVar basevar; + XOp (XPlus, [dwgvxpr; XOp (XMult, [int_constant_expr 68; XVar indexvar])]) in - let xpsuboffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(XVar indexvar, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_int xpr in + let xpoffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(XVar indexvar, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + | Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); + TS.add_simple_test ~title:"varm1-68" (fun () -> let subxpr = XOp (XMult, [int_constant_expr 68; XVar indexvar]) in let subxpr = XOp (XMinus, [subxpr; int_constant_expr 68]) in - let xpr = XOp (XPlus, [XVar basevar; subxpr]) in - let xpsuboffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(indexxpr1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xpr = XOp (XPlus, [dwgvxpr; subxpr]) in + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_int xpr in + let xpoffset = FieldOffset (("field0", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(indexxpr1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + | Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); TS.add_simple_test ~title:"varm1-64" (fun () -> let subxpr = XOp (XMult, [int_constant_expr 68; XVar indexvar]) in let subxpr = XOp (XMinus, [subxpr; int_constant_expr 64]) in - let xpr = XOp (XPlus, [XVar basevar; subxpr]) in - let xpsuboffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(indexxpr1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xpr = XOp (XPlus, [dwgvxpr; subxpr]) in + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_int xpr in + let xpoffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(indexxpr1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + | Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); TS.add_simple_test ~title:"varm1-60" (fun () -> let subxpr = XOp (XMult, [int_constant_expr 68; XVar indexvar]) in let subxpr = XOp (XMinus, [subxpr; int_constant_expr 60]) in - let xpr = XOp (XPlus, [XVar basevar; subxpr]) in - let xpsuboffset = ConstantOffset (numerical_zero, NoOffset) in - let xpsuboffset = FieldOffset (("buffer", compinfo.bckey), xpsuboffset) in - let xpmemoffset = ArrayIndexOffset(indexxpr1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); + let xpr = XOp (XPlus, [dwgvxpr; subxpr]) in + let xprvar = floc#get_var_at_address ~btype:BCHBCTypeUtil.t_char xpr in + let xpoffset = ArrayIndexOffset (int_constant_expr 0, NoOffset) in + let xpoffset = FieldOffset (("buffer", compinfo.bckey), xpoffset) in + let xpoffset = ArrayIndexOffset(indexxpr1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + | Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); (* (((g_data_array + (0x4 * R0_in[4]_in)) + (0x40 * R0_in[4]_in)) - 0x40)) *) @@ -184,17 +199,22 @@ let decompose_memvar_address_test () = (fun () -> let subxpr1 = XOp (XMult, [int_constant_expr 4; XVar indexvar]) in let subxpr2 = XOp (XMult, [int_constant_expr 64; XVar indexvar]) in - let xpr = XOp (XPlus, [XVar basevar; subxpr1]) in + let xpr = XOp (XPlus, [dwgvxpr; subxpr1]) in let xpr = XOp (XPlus, [xpr; subxpr2]) in let xpr = XOp (XMinus, [xpr; int_constant_expr 64]) in - let xpsuboffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in - let xpmemoffset = ArrayIndexOffset(indexxpr1, xpsuboffset) in - let optmeminfo = floc#decompose_memvar_address xpr in - XBA.equal_opt_meminfo - ~expected: (Some (memref, xpmemoffset)) - ~received: optmeminfo - ()); - + let xprvar = floc#get_var_at_address xpr in + let xpoffset = FieldOffset (("field4", compinfo.bckey), NoOffset) in + let xpoffset = ArrayIndexOffset(indexxpr1, xpoffset) in + let expected_r = finfo#env#add_memory_offset gvar xpoffset in + let expected = TR.to_option expected_r in + match xprvar with + | Ok received -> + XBA.equal_opt_variable + ~expected + ~received:(Some received) + () + | Error e -> A.fail_msg ("Error: " ^ (String.concat "; " e))); + TS.launch_tests () end @@ -202,6 +222,6 @@ let decompose_memvar_address_test () = let () = begin TS.new_testfile testname lastupdated; - decompose_memvar_address_test (); + get_var_at_address_test (); TS.exit_file () end diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHMemoryReferenceTest.ml b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHMemoryReferenceTest.ml index 507d30a6..408b1c42 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHMemoryReferenceTest.ml +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHMemoryReferenceTest.ml @@ -5,7 +5,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - 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 @@ -32,7 +32,6 @@ open CHNumerical (* bchlib *) open BCHBCFiles open BCHBCTypes -open BCHConstantDefinitions open BCHDoubleword open BCHFunctionData open BCHLibTypes @@ -49,7 +48,7 @@ module XBA = TCHBchlibAssertion let testname = "bCHMemoryReferenceTest" -let lastupdated = "2024-08-21" +let lastupdated = "2025-01-06" let mk_maximal_memory_offset_test () = @@ -58,21 +57,6 @@ let mk_maximal_memory_offset_test () = parse_cil_file ~removeUnused:false "decompose_array_address.i"; ignore (functions_data#add_function (TR.tget_ok (string_to_doubleword "0x1d6bfc"))); - - let arraysym = { - xconst_name = "x44_array"; - xconst_value = TR.tget_ok (string_to_doubleword "0x5e1e1c"); - xconst_type = - if bcfiles#has_varinfo "x44_array" then - let vinfo = bcfiles#get_varinfo "x44_array" in - vinfo.bvtype - else - raise - (Invalid_argument "Error in arraysym"); - xconst_desc = "decompose_array_address"; - xconst_is_addr = true - } in - let _ = add_address arraysym in let compinfo = bcfiles#get_compinfo_by_name "x44_struct_t" in let structty = TComp (compinfo.bckey, []) in diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHXprUtilTest.ml b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHXprUtilTest.ml index 67d12fb6..19eb2570 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHXprUtilTest.ml +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/bCHXprUtilTest.ml @@ -42,11 +42,32 @@ module TS = TCHTestSuite module X = BCHXprUtil let testname = "bCHXprUtilTest" -let lastupdated = "2024-08-21" +let lastupdated = "2024-12-25" + + +let largest_constant_term_test () = + (* let xv = XVar (XG.mk_var "v") in *) + begin + + TS.new_testsuite (testname ^ "_largest_constant_term_test") lastupdated; + + (* n -> n *) + TS.add_simple_test + ~title:"constant" + (fun () -> + XBA.equal_numerical + ~expected:(mkNumerical 0x500000) + ~received:(X.largest_constant_term (Xprt.int_constant_expr 0x500000)) + ()); + + TS.launch_tests() + end let array_index_offset_test () = let xv = XVar (XG.mk_var "v") in + let xzero = Xprt.int_constant_expr 0 in + let xone = Xprt.int_constant_expr 1 in begin TS.new_testsuite (testname ^ "_array_index_offset_test") lastupdated; @@ -56,7 +77,7 @@ let array_index_offset_test () = ~title:"constant" (fun () -> XBA.equal_array_index_offset - ~expected: (Some ((XG.mk_ix 12), numerical_zero)) + ~expected: (Some ((XG.mk_ix 12), xzero)) ~received: (X.get_array_index_offset (XG.mk_ix 12) 1) ()); @@ -65,7 +86,7 @@ let array_index_offset_test () = ~title:"variable" (fun () -> XBA.equal_array_index_offset - ~expected: (Some (xv, numerical_zero)) + ~expected: (Some (xv, xzero)) ~received: (X.get_array_index_offset xv 1) ()); @@ -75,7 +96,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XMult, [XG.mk_ix 12; XVar (XG.mk_var "v")]) in XBA.equal_array_index_offset - ~expected: (Some (x, numerical_zero)) + ~expected: (Some (x, xzero)) ~received: (X.get_array_index_offset x 1) ()); @@ -84,16 +105,16 @@ let array_index_offset_test () = ~title:"constant-ds" (fun () -> XBA.equal_array_index_offset - ~expected: (Some ((XG.mk_ix 6), numerical_zero)) + ~expected: (Some ((XG.mk_ix 6), xzero)) ~received: (X.get_array_index_offset (XG.mk_ix 12) 2) ()); - (* 12, 2 -> (6, 0) *) + (* 13, 2 -> (6, 1) *) TS.add_simple_test ~title:"constant-ds-rem" (fun () -> XBA.equal_array_index_offset - ~expected: (Some ((XG.mk_ix 6), numerical_one)) + ~expected: (Some ((XG.mk_ix 6), xone)) ~received: (X.get_array_index_offset (XG.mk_ix 13) 2) ()); @@ -103,7 +124,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XMult, [XG.mk_ix 2; xv]) in XBA.equal_array_index_offset - ~expected: (Some (xv, numerical_zero)) + ~expected: (Some (xv, xzero)) ~received: (X.get_array_index_offset x 2) ()); @@ -113,7 +134,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XPlus, [XOp (XMult, [XG.mk_ix 2; xv]); XG.mk_ix 1]) in XBA.equal_array_index_offset - ~expected: (Some (xv, numerical_one)) + ~expected: (Some (xv, xone)) ~received: (X.get_array_index_offset x 2) ()); @@ -123,7 +144,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XPlus, [XOp (XMult, [XG.mk_ix 2; xv]); XG.mk_ix 5]) in XBA.equal_array_index_offset - ~expected: (Some (XOp (XPlus, [xv; XG.mk_ix 2]), numerical_one)) + ~expected: (Some (XOp (XPlus, [xv; XG.mk_ix 2]), xone)) ~received: (X.get_array_index_offset x 2) ()); @@ -143,7 +164,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XMinus, [XOp (XMult, [XG.mk_ix 2; xv]); XG.mk_ix 3]) in XBA.equal_array_index_offset - ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 2]), numerical_one)) + ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 2]), xone)) ~received: (X.get_array_index_offset x 2) ()); @@ -153,7 +174,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XMinus, [XOp (XMult, [XG.mk_ix 68; xv]); XG.mk_ix 68]) in XBA.equal_array_index_offset - ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), numerical_zero)) + ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), xzero)) ~received: (X.get_array_index_offset x 68) ()); @@ -163,7 +184,7 @@ let array_index_offset_test () = (fun () -> let x = XOp (XMinus, [XOp (XMult, [XG.mk_ix 68; xv]); XG.mk_ix 60]) in XBA.equal_array_index_offset - ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), mkNumerical 8)) + ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), Xprt.int_constant_expr 8)) ~received: (X.get_array_index_offset x 68) ()); @@ -179,7 +200,7 @@ let array_index_offset_test () = let x5 = XOp (XMinus, [x4; xdata]) in let x = simplify_xpr x5 in XBA.equal_array_index_offset - ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), mkNumerical 4)) + ~expected: (Some (XOp (XMinus, [xv; XG.mk_ix 1]), Xprt.int_constant_expr 4)) ~received: (X.get_array_index_offset x 68) ()); @@ -191,6 +212,7 @@ let array_index_offset_test () = let () = begin TS.new_testfile testname lastupdated; + largest_constant_term_test (); array_index_offset_test (); TS.exit_file () end diff --git a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/decompose_array_address.i b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/decompose_array_address.i index 551dc289..a7c0c469 100644 --- a/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/decompose_array_address.i +++ b/CodeHawk/CHT/CHB_tests/bchlib_tests/txbchlib/decompose_array_address.i @@ -19,4 +19,4 @@ struct x44_struct_t { int msg; }; -struct x44_struct_t x44_array[64]; +struct x44_struct_t gv_5e1e1c_x44_array[64]; diff --git a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.ml b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.ml index d08d12b8..b0d7bb11 100644 --- a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.ml +++ b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.ml @@ -28,6 +28,7 @@ (* chutil *) open CHPrettyUtil +open CHTraceResult (* xprlib *) open XprToPretty @@ -37,6 +38,7 @@ open XprTypes open BCHARMTypes module A = TCHAssertion +module TR = CHTraceResult let x2s x = pretty_to_string (xpr_formatter#pr_expr x) @@ -105,16 +107,21 @@ let equal_arm_conditional_expr let equal_instrxdata_conditionxprs ?(msg="") ~(expected: string) - ~(received: xpr_t list) + ~(received: xpr_t traceresult list) ~(index: int) () = + let xtr2s (x_r: xpr_t traceresult): string = + TR.tfold + ~ok:x2s + ~error:(fun e -> String.concat "; " e) + x_r in match received with | [] -> A.fail expected "empty list" msg | _ when (List.length received) > index -> - A.equal_string ~msg expected (x2s (List.nth received index)) + A.equal_string ~msg expected (xtr2s (List.nth received index)) | _ -> let receivedlen = string_of_int (List.length received) in - let xprs = String.concat ", " (List.map x2s received) in + let xprs = String.concat ", " (List.map xtr2s received) in A.fail expected ("Index: " diff --git a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.mli b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.mli index d20f644b..639632d2 100644 --- a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.mli +++ b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Assertion.mli @@ -26,6 +26,9 @@ SOFTWARE. ============================================================================= *) +(* chutil *) +open CHTraceResult + (* xprlib *) open XprTypes @@ -68,7 +71,7 @@ val equal_arm_conditional_expr: val equal_instrxdata_conditionxprs: ?msg: string -> expected:string - -> received:xpr_t list + -> received:xpr_t traceresult list -> index:int -> unit -> unit diff --git a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.ml b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.ml index 1515a36f..5bddf5d4 100644 --- a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.ml +++ b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.ml @@ -5,7 +5,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -26,6 +26,12 @@ SOFTWARE. ============================================================================= *) +(* chutil *) +open CHTraceResult + +(* xprlib *) +open XprTypes + (* bchlib *) open BCHByteUtilities open BCHDoubleword @@ -130,7 +136,9 @@ let thumb_function_setup end -let get_instrxdata_xprs (faddr: doubleword_int) (iaddr: doubleword_int) = +let get_instrxdata_xprs + (faddr: doubleword_int) + (iaddr: doubleword_int): xpr_t traceresult list = let _ = testsupport#request_instrx_data in let finfo = get_function_info faddr in let fn = get_arm_assembly_function faddr in diff --git a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.mli b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.mli index 3d85274e..4850234d 100644 --- a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.mli +++ b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/tbchlibarm32/tCHBchlibarm32Utils.mli @@ -5,7 +5,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -26,6 +26,9 @@ SOFTWARE. ============================================================================= *) +(* chutil *) +open CHTraceResult + (* xprlib *) open XprTypes @@ -48,7 +51,8 @@ val arm_function_setup: doubleword_int -> string -> arm_assembly_function_int val thumb_function_setup: doubleword_int -> string -> arm_assembly_function_int -val get_instrxdata_xprs: doubleword_int -> doubleword_int -> xpr_t list +val get_instrxdata_xprs: + doubleword_int -> doubleword_int -> xpr_t traceresult list val get_instrxdata_tags: doubleword_int -> doubleword_int -> string list diff --git a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/txbchlibarm32/bCHTranslateARMToCHIFTest.ml b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/txbchlibarm32/bCHTranslateARMToCHIFTest.ml index bf45880a..9ffa6d23 100644 --- a/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/txbchlibarm32/bCHTranslateARMToCHIFTest.ml +++ b/CodeHawk/CHT/CHB_tests/bchlibarm32_tests/txbchlibarm32/bCHTranslateARMToCHIFTest.ml @@ -5,7 +5,7 @@ ------------------------------------------------------------------------------ The MIT License (MIT) - Copyright (c) 2022-2024 Aarno Labs LLC + Copyright (c) 2022-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 @@ -62,7 +62,7 @@ open BCHAnalyzeApp let testname = "bCHTranslateARMToCHIFTest" -let lastupdated = "2024-08-27" +let lastupdated = "2025-01-06" let make_dw (s: string) = TR.tget_ok (string_to_doubleword s) @@ -85,8 +85,7 @@ let translate_store () = ("STMIB", "0x3ba4c", "10408de900", [("arg_0004", "R4_in"); ("arg_0008", "LR_in")]); ("STR", "0x1b4bc", "08608de500", [("arg_0008", "R6_in")]); - ("STRBwb", "0x10208", "015062e500", - [("R2_in[-1]", "sv__13__sv"); ("R2", "sv__3__sv")]); + ("STRBwb", "0x10208", "015062e500", [("R2", "sv__3__sv")]); ("STRwb", "0x10568", "08402de500", [("var_0008", "R4_in"); ("SP", "sv__3__sv")]); ("STRDwb1", "0x1b4bc", "f0416de100", @@ -97,7 +96,7 @@ let translate_store () = [("var_0012", "R4_in"); ("var_0008", "R5_in"); ("SP", "sv__3__sv")]); - ("STRH", "0x1b4bc", "b031cde100", [("arg_0016", "sv__25__sv")]) + ("STRH", "0x1b4bc", "b031cde100", [("arg_0016", "R3_in")]) ] in begin TS.new_testsuite (testname ^ "_translate_store") lastupdated; @@ -146,7 +145,7 @@ let thumb_chif_conditionxprs () = "0x4f12", "44f6251393f87094b9f1910ff94602d8a9f6e1594847a9f6e769484700", 3, - "((lsb gvb_0x4d95_in) <= 145)") + "(gv_0x4d95_in <= 145)") ] in begin TS.new_testsuite (testname ^ "_thumb_chif_conditionxprs") lastupdated; @@ -200,13 +199,14 @@ let thumb_instrxdata_conditionxprs () = "0x4f12", "44f6251393f87094b9f1910ff94602d8a9f6e1594847a9f6e769484700", 3, - "((lsb gvb_0x4d95_in) <= 145)") + "(gv_0x4d95_in <= 145)") ] in begin TS.new_testsuite (testname ^ "_thumb_instrxdata_conditionxprs") lastupdated; system_info#set_elf_is_code_address wordzero codemax; ARMU.arm_instructions_setup (make_dw "0x4000") 0x10000; + List.iter (fun (title, cfaddr, ccaddr, bytes, iterations, expectedcond) -> TS.add_simple_test