CHB:ARM: updates for result types

Author: sipma

CodeHawk/CHB/bchlib/bCHFloc.ml

@@ -1271,7 +1271,8 @@ object (self)
        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 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

CodeHawk/CHB/bchlib/bCHGlobalMemoryMap.ml

@@ -341,7 +341,8 @@ object (self)
                     && Option.is_none tgtbtype ->
                 Ok (ArrayIndexOffset (indexxpr, NoOffset))
              | Some (indexxpr, rem) ->
-                if is_struct_type eltty then
+                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)
@@ -356,7 +357,8 @@ object (self)
                 else
                   Error[__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":"
                         ^ "xoffset: " ^ (x2s xoffset)
-                        ^ "; btype: " ^ (btype_to_string btype)])
+                        ^ "; btype: " ^ (btype_to_string btype)
+                        ^ "; elementtype: " ^ (btype_to_string eltty)])
            (size_of_btype eltty)
        else
          Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":"
@@ -382,11 +384,14 @@ object (self)
         | 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
+           let tgtbtype =
+             if is_unknown_type tgtbtype then None else Some tgtbtype in
            if self#is_struct then
-             self#structvar_memory_offset ~tgtsize ~tgtbtype self#btype xoffset
+             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
-               self#arrayvar_memory_offset ~tgtsize ~tgtbtype self#btype xoffset
+             let btype = TR.tvalue (resolve_type self#btype) ~default:t_unknown in
+             self#arrayvar_memory_offset ~tgtsize ~tgtbtype self#btype xoffset
            else
              Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ":"
                     ^ (btype_to_string self#btype)
@@ -429,6 +434,16 @@ object (self)
            (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 =

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 =

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
@@ -475,12 +475,31 @@ object (self:'a)
                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
+              | _ ->
+                 floc#get_memory_variable_varoffset
+                   ~size rvar ivar (mkNumerical i))
+           else
+             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
@@ -491,8 +510,8 @@ object (self:'a)
                      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) ->
+                     (match (xoffset, i) with
+                      | (XConst (IntConst n), 0) ->
                          floc#env#mk_global_variable ~size n
                       | _ ->
                          floc#get_memory_variable_varoffset
@@ -509,12 +528,7 @@ object (self:'a)
                Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": "
                       ^ "Shifted Index Offset with isadd: false: "
                       ^ (p2s self#toPretty)
-                      ^ " not yet supported"])
-
-        | _ ->
-           Error [__FILE__ ^ ":" ^ (string_of_int __LINE__) ^ ": "
-                  ^ "Index Offset address: " ^ (p2s self#toPretty)
-                  ^ " not yet supported"])
+                      ^ " not yet supported"]))
 
     | ARMShiftedReg (r, ARMImmSRT (SRType_LSL, 0)) ->
        Ok (env#mk_arm_register_variable r)

CodeHawk/CHB/bchlibarm32/bCHFnARMDictionary.ml

@@ -536,7 +536,12 @@ object (self)
       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 index_xpr xprs_r) @ 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
 
@@ -601,6 +606,7 @@ object (self)
                        ^ "Parameter type not recognized in call instruction"] in
             let ptype = get_parameter_type p in
             let xx = rewrite_expr ?restrict:(Some 4) x in
+            (*
             let xx =
               if is_pointer ptype then
                 let _ = floc#memrecorder#record_argument xx index in
@@ -616,6 +622,7 @@ object (self)
                         (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

CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml

@@ -927,6 +927,37 @@ 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_r = memvarop#to_address floc in