CHB:MIPS: add error handling

Author: sipma

CodeHawk/CHB/bchlibmips32/bCHDisassembleMIPS.ml

@@ -243,6 +243,14 @@ let disassemble_mips_sections () =
               STR "disassemble section:"; NL; h#toPretty; NL; NL] in
         let displacement =
           TR.tget_ok (h#get_addr#subtract_to_int startOfCode) in
+        let _ =
+          chlog#add
+            "disassembly"
+            (LBLOCK [
+                 STR "disassemble section: ";
+                 h#toPretty;
+                 STR " with displacement: ";
+                 INT displacement]) in
         let _ =
           pverbose [
               STR "disassemble section at displacement: ";
@@ -582,23 +590,32 @@ let get_successors (faddr:doubleword_int) (iaddr:doubleword_int)  =
       (get_mips_assembly_instruction iaddr)
 
 
-let trace_block (faddr:doubleword_int) (baddr:doubleword_int) =
+let trace_block
+      (faddr:doubleword_int)
+      (baddr:doubleword_int):
+      (mips_assembly_block_int list * mips_assembly_block_int) TR.traceresult =
 
   let set_block_entry (va: doubleword_int) =
     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
+  let get_instr (iaddr: doubleword_int): mips_assembly_instruction_result =
+    get_mips_assembly_instruction iaddr in
 
   let get_next_instr_addr a = a#add_int 4 in
 
   let mk_ci_succ l =
     List.map
       (fun va -> (make_location {loc_faddr = faddr ; loc_iaddr = va})#ci) l in
 
-  let rec find_last_instr (va: doubleword_int) (prev: doubleword_int) =
+  let rec find_last_instr
+            (va: doubleword_int)
+            (prev: doubleword_int):
+            (ctxt_iaddress_t list option
+             * doubleword_int
+             * mips_assembly_block_int list) TR.traceresult =
     let instr =
       fail_tvalue
         (trerror_record
@@ -610,24 +627,24 @@ let trace_block (faddr:doubleword_int) (baddr:doubleword_int) =
 
     if va#equal wordzero
        || not (!mips_assembly_instructions#is_code_address va) then
-      (Some [],prev,[])
+      Ok (Some [], prev, [])
     else if is_return_instruction instr#get_opcode then
-      (Some [],va#add_int 4,[])
+      Ok (Some [], va#add_int 4, [])
     else if instr#is_block_entry then
-      (None,prev,[])
+      Ok (None, prev, [])
     else if is_nr_call_instruction instr then
-      (Some [],va#add_int 4,[])
+      Ok (Some [], va#add_int 4, [])
     else if is_conditional_jump_instruction instr#get_opcode
             || is_fp_conditional_jump_instruction instr#get_opcode then
       let nextblock = va#add_int 8 in
       let tgtblock = get_direct_jump_target_address instr#get_opcode in
-      (Some (mk_ci_succ [ nextblock ; tgtblock ]),va#add_int 4,[])
+      Ok (Some (mk_ci_succ [nextblock; tgtblock]), va#add_int 4, [])
     else if is_direct_jump_instruction instr#get_opcode then
       let tgtblock = get_direct_jump_target_address instr#get_opcode in
       if functions_data#is_function_entry_point tgtblock then
-        (Some [], va#add_int 4, [])                (* function chaining *)
+        Ok (Some [], va#add_int 4, [])                (* function chaining *)
       else
-        (Some (mk_ci_succ [tgtblock]), va#add_int 4, [])
+        Ok (Some (mk_ci_succ [tgtblock]), va#add_int 4, [])
     else if is_indirect_jump_instruction instr#get_opcode then
       if system_info#has_jump_table_target faddr va then
         let loc = make_location { loc_faddr = faddr ; loc_iaddr = va } in
@@ -638,16 +655,16 @@ let trace_block (faddr:doubleword_int) (baddr:doubleword_int) =
         let reg =
           MIPSRegister (get_indirect_jump_instruction_register instr#get_opcode) in
         let _ = finfo#set_jumptable_target ctxtiaddr jt#get_start_address jt reg in
-        (Some (mk_ci_succ targets), va#add_int 4, [])
+        Ok (Some (mk_ci_succ targets), va#add_int 4, [])
       else if system_info#has_indirect_jump_targets faddr va then
         let targets = system_info#get_indirect_jump_targets faddr va in
-        (Some (mk_ci_succ targets), va#add_int 4, [])
+        Ok (Some (mk_ci_succ targets), va#add_int 4, [])
       else
-        (Some [], va#add_int 4, [])
+        Ok (Some [], va#add_int 4, [])
     else if instr#is_delay_slot then
-      (None, va, [])
+      Ok (None, va, [])
     else if is_halt_instruction instr#get_opcode then
-      (Some [], va, [])
+      Ok (Some [], va, [])
     else if instr#is_inlined_call then
       let a = match instr#get_opcode with
         | BranchLTZeroLink (_,tgt)
@@ -677,44 +694,53 @@ let trace_block (faddr:doubleword_int) (baddr:doubleword_int) =
                  [(make_location {loc_faddr = faddr; loc_iaddr = returnsite})#ci]
               | l -> List.map (fun s -> add_ctxt_to_ctxt_string faddr s ctxt) l in
             make_ctxt_mips_assembly_block ctxt b succ) fn#get_blocks in
-      (Some [ callsucc ],va,inlinedblocks)
+      Ok (Some [callsucc], va, inlinedblocks)
     else
       find_last_instr (nextva ()) va in
 
-  let (succ, lastaddr, inlinedblocks) =
+  let result_r:
+        (ctxt_iaddress_t list option
+         * doubleword_int
+         * mips_assembly_block_int list) TR.traceresult =
+    (* let (succ, lastaddr, inlinedblocks) = *)
     let instr =
       fail_tvalue
         (trerror_record
            (LBLOCK [STR "find_last_instr: "; baddr#toPretty]))
         (get_instr baddr) in
     let opcode = instr#get_opcode in
     if is_return_instruction opcode then
-      (Some [],baddr#add_int 4,[])
+      Ok (Some [], baddr#add_int 4, [])
     else if system_info#is_nonreturning_call faddr baddr then
-      (Some [], baddr#add_int 4, [])
+      Ok (Some [], baddr#add_int 4, [])
     else if is_indirect_jump_instruction opcode then
       if system_info#has_jump_table_target faddr baddr then
         let (jt,_,lb,ub) = system_info#get_jump_table_target faddr baddr in
         let targets = jt#get_targets jt#get_start_address lb ub in
-        (Some (mk_ci_succ targets), baddr#add_int 4, [])
+        Ok (Some (mk_ci_succ targets), baddr#add_int 4, [])
       else
-        (Some [], baddr#add_int 4, [])
+        Ok (Some [], baddr#add_int 4, [])
     else if is_conditional_jump_instruction opcode then
       let nextblock = baddr#add_int 8 in
       let tgtblock = get_direct_jump_target_address opcode in
-      (Some (mk_ci_succ [ nextblock ; tgtblock ]),baddr#add_int 4,[])
+      Ok (Some (mk_ci_succ [nextblock; tgtblock]), baddr#add_int 4, [])
     else if is_direct_jump_instruction opcode then
       let tgtblock = get_direct_jump_target_address opcode in
-      (Some (mk_ci_succ [ tgtblock ]),baddr#add_int 4,[])
+      Ok (Some (mk_ci_succ [tgtblock ]), baddr#add_int 4, [])
     else
       find_last_instr (get_next_instr_addr baddr) baddr in
 
-  let successors =
-    match succ with Some s -> s | _ -> get_successors faddr lastaddr in
-  (inlinedblocks, make_mips_assembly_block faddr baddr lastaddr successors)
+  TR.tmap
+    (fun (succ, lastaddr, inlinedblocks) ->
+      let successors =
+        match succ with
+        | Some s -> s
+        | _ -> get_successors faddr lastaddr in
+      (inlinedblocks, make_mips_assembly_block faddr baddr lastaddr successors))
+    result_r
 
 
-let trace_function (faddr:doubleword_int) =
+let trace_function (faddr:doubleword_int): mips_assembly_function_int =
   let workSet = new DoublewordCollections.set_t in
   let doneSet = new DoublewordCollections.set_t in
   let set_block_entry (baddr: doubleword_int) =
@@ -726,17 +752,26 @@ let trace_function (faddr:doubleword_int) =
   let add_to_workset l =
     List.iter (fun a -> if doneSet#has a then () else workSet#add a) l in
   let blocks = ref [] in
-  let rec add_block (entry:doubleword_int) =
-    let (inlinedblocks,block) = trace_block faddr entry in
-    let blocksuccessors = block#get_successors in
-    begin
-      set_block_entry entry ;
-      workSet#remove entry ;
-      doneSet#add entry ;
-      blocks := (block :: inlinedblocks) @ !blocks ;
-      add_to_workset (List.map get_iaddr blocksuccessors) ;
-      match workSet#choose with Some a -> add_block a | _ -> ()
-    end in
+  let rec add_block (entry: doubleword_int) =
+    let result_r: (mips_assembly_block_int list
+                   * mips_assembly_block_int) TR.traceresult =
+      trace_block faddr entry in
+    TR.titer
+      ~ok:(fun (inlinedblocks, block) ->
+        let blocksuccessors = block#get_successors in
+        begin
+          set_block_entry entry;
+          workSet#remove entry;
+          doneSet#add entry;
+          blocks := (block :: inlinedblocks) @ !blocks;
+          add_to_workset (List.map get_iaddr blocksuccessors);
+          match workSet#choose with Some a -> add_block a | _ -> ()
+        end)
+      ~error:(fun e ->
+        log_error_result
+          ~tag:"trace_function:add block" __FILE__ __LINE__
+          (("faddr: " ^ faddr#to_hex_string) :: e))
+      result_r in
   let _ = add_block faddr in
   let blocklist =
     List.sort (fun b1 b2 ->
@@ -750,9 +785,7 @@ let trace_function (faddr:doubleword_int) =
 
 let construct_mips_assembly_function (_count: int) (faddr: doubleword_int) =
   try
-    let _ = pverbose [STR "  trace function "; faddr#toPretty; NL] in
     let fn = trace_function faddr in
-    let _ = pverbose [STR "  add function "; faddr#toPretty; NL] in
     mips_assembly_functions#add_function fn
   with
   | BCH_failure p ->
@@ -875,7 +908,6 @@ let record_call_targets () =
            (LBLOCK [STR "function "; faddr#toPretty; STR ": "; p]))
 
 
-
 let decorate_functions () =
   begin
     record_call_targets ()

CodeHawk/CHB/bchlibmips32/bCHMIPSAssemblyFunction.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
@@ -78,6 +78,7 @@ object (self)
 	raise
           (BCH_failure
              (LBLOCK [
+                  STR __FILE__; STR ":"; INT __LINE__; STR ": ";
                   STR "No assembly block found at ";
                   STR bctxt;
                   STR " in function ";
@@ -92,7 +93,12 @@ object (self)
     with
     | Not_found ->
        let msg =
-         LBLOCK [STR "assembly_function#get_instruction: "; iaddr#toPretty]  in
+         LBLOCK [
+             STR __FILE__; STR ":"; INT __LINE__; STR ": ";
+             STR "assembly_function#get_instruction: ";
+             iaddr#toPretty;
+             STR " in function ";
+             faddr#toPretty]  in
        begin
          ch_error_log#add "invocation error" msg;
          raise (BCH_failure msg)