Skip to content

Commit 19e1350

Browse files
sipmasipma
committed
add more diagnostic logging
1 parent b28b75b commit 19e1350

File tree

7 files changed

+125
-135
lines changed

7 files changed

+125
-135
lines changed

‎CodeHawk/CHB/bchcil/bCHParseCilFile.ml‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
------------------------------------------------------------------------------
55
The MIT License (MIT)
66
7-
Copyright (c) 2021-2024 Aarno Labs LLC
7+
Copyright (c) 2021-2025 Aarno Labs LLC
88
99
Permission is hereby granted, free of charge, to any person obtaining a copy
1010
of this software and associated documentation files (the "Software"), to deal
@@ -52,10 +52,10 @@ let update_symbolic_address_types () =
5252
else
5353
match BCHGlobalMemoryMap.update_global_location_type vinfo with
5454
| Error e ->
55-
ch_error_log#add
56-
"update-global-location-type"
57-
(LBLOCK [
58-
STR "varinfo: "; STR vinfo.bvname; STR (String.concat "; " e)])
55+
log_diagnostics_result
56+
~tag:"update global location type"
57+
__FILE__ __LINE__
58+
["varinfo: " ^ vinfo.bvname ^ (String.concat "; " e)]
5959
| _ -> ()) varinfos
6060

6161

‎CodeHawk/CHB/bchlib/bCHFunctionInterface.ml‎

Lines changed: 15 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1148,8 +1148,21 @@ let record_function_interface_type_constraints
11481148
| [RegisterParameter (reg, _)] ->
11491149
let pvar = add_freg_param_capability reg ftypevar in
11501150
(match mk_btype_constraint pvar ty with
1151-
| Some tyc -> store#add_constraint tyc
1152-
| _ -> ())
1151+
| Some tyc ->
1152+
let _ =
1153+
log_diagnostics_result
1154+
~tag:("function-interface type constraint")
1155+
__FILE__ __LINE__
1156+
[faddr ^ ": " ^ (type_constraint_to_string tyc)] in
1157+
store#add_constraint tyc
1158+
| _ ->
1159+
chlog#add
1160+
"function interface type constraints"
1161+
(LBLOCK [
1162+
STR faddr;
1163+
STR ": ";
1164+
STR "unable to make type constraint for ";
1165+
STR (type_variable_to_string pvar)]))
11531166
| _ ->
11541167
chlog#add
11551168
"function interface type constraints"

‎CodeHawk/CHB/bchlib/bCHSystemInfo.ml‎

Lines changed: 6 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1647,15 +1647,12 @@ object (self)
16471647
method add_data_block (db:data_block_int) =
16481648
begin
16491649
data_blocks#add db;
1650-
(if collect_diagnostics () then
1651-
chlog#add
1652-
"add data block"
1653-
(LBLOCK [
1654-
db#get_start_address#toPretty;
1655-
STR " - ";
1656-
db#get_end_address#toPretty;
1657-
STR ": ";
1658-
STR db#get_name]))
1650+
log_diagnostics_result
1651+
~tag:"add data block"
1652+
__FILE__ __LINE__
1653+
[db#get_start_address#to_hex_string ^ " - "
1654+
^ db#get_end_address#to_hex_string ^ ": "
1655+
^ db#get_name]
16591656
end
16601657

16611658
method get_data_blocks = data_blocks#toList

‎CodeHawk/CHB/bchlib/bCHTypeConstraintStore.ml‎

Lines changed: 83 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
------------------------------------------------------------------------------
55
The MIT License (MIT)
66
7-
Copyright (c) 2024 Aarno Labs LLC
7+
Copyright (c) 2024-2025 Aarno Labs LLC
88
99
Permission is hereby granted, free of charge, to any person obtaining a copy
1010
of this software and associated documentation files (the "Software"), to deal
@@ -47,6 +47,8 @@ let bcd = BCHBCDictionary.bcdictionary
4747
let bd = BCHDictionary.bdictionary
4848
let tcd = BCHTypeConstraintDictionary.type_constraint_dictionary
4949

50+
let p2s = CHPrettyUtil.pretty_to_string
51+
5052

5153
class type_constraint_store_t: type_constraint_store_int =
5254
object (self)
@@ -250,14 +252,12 @@ object (self)
250252
result := !result @ (List.map tcd#get_type_constraint tcs))
251253
iaddrentry in
252254
let _ =
253-
chlog#add
254-
"stack lhs constraints"
255-
(LBLOCK [
256-
INT offset;
257-
STR ": ";
258-
pretty_print_list !result
259-
(fun tc -> STR (type_constraint_to_string tc))
260-
"[" "; " "]"]) in
255+
log_diagnostics_result
256+
~tag:("stack lhs constraints for " ^ faddr)
257+
__FILE__ __LINE__
258+
[(string_of_int offset) ^ ": ["
259+
^ (String.concat "; " (List.map type_constraint_to_string !result))
260+
^ "]"] in
261261
!result
262262
else
263263
[]
@@ -439,28 +439,25 @@ object (self)
439439
let evaluation = self#evaluate_reglhs_type reg faddr iaddr in
440440
let logresults = iaddr = "0xffffffff" in
441441
let log_evaluation () =
442-
chlog#add
443-
("reglhs resolution was not successfull:" ^ faddr)
444-
(LBLOCK [
445-
STR iaddr;
446-
STR " - ";
447-
STR (register_to_string reg);
448-
STR ": ";
449-
pretty_print_list
450-
evaluation
451-
(fun (vars, consts) ->
452-
LBLOCK [
453-
STR "vars: ";
454-
pretty_print_list
455-
vars
456-
(fun v -> STR (type_variable_to_string v))
457-
"[" "; " "]";
458-
STR "; consts: ";
459-
pretty_print_list
460-
consts
461-
(fun c -> STR (type_constant_to_string c))
462-
"[" "; " "]";
463-
NL]) "[[" " -- " "]]"]) in
442+
log_diagnostics_result
443+
~tag:("reglhs resolution not successfull for " ^ faddr)
444+
__FILE__ __LINE__
445+
[iaddr ^ " - " ^ (register_to_string reg) ^ ": "
446+
^ (p2s (pretty_print_list
447+
evaluation
448+
(fun (vars, consts) ->
449+
LBLOCK [
450+
STR "vars: ";
451+
pretty_print_list
452+
vars
453+
(fun v -> STR (type_variable_to_string v))
454+
"[" "; " "]";
455+
STR "; consts: ";
456+
pretty_print_list
457+
consts
458+
(fun c -> STR (type_constant_to_string c))
459+
"[" "; " "]";
460+
NL]) "[[" " -- " "]]"))] in
464461
let result = new IntCollections.set_t in
465462
begin
466463
List.iter (fun (vars, consts) ->
@@ -499,16 +496,13 @@ object (self)
499496
| _ ->
500497
begin
501498
log_evaluation ();
502-
chlog#add
503-
"top type constant in join"
504-
(LBLOCK [
505-
STR iaddr;
506-
STR " --- ";
507-
STR (register_to_string reg);
508-
STR ": ";
509-
pretty_print_list
510-
(List.map bcd#get_typ result#toList)
511-
(fun ty -> STR (btype_to_string ty)) "[" "; " "]"]);
499+
log_diagnostics_result
500+
~tag:("top type constant in join for " ^ faddr)
501+
__FILE__ __LINE__
502+
[iaddr ^ " -- " ^ (register_to_string reg) ^ ": "
503+
^ (p2s (pretty_print_list
504+
(List.map bcd#get_typ result#toList)
505+
(fun ty -> STR (btype_to_string ty)) "[" "; " "]"))];
512506
None
513507
end
514508
end
@@ -517,26 +511,25 @@ object (self)
517511
(offset: int) (faddr: string): btype_t option =
518512
let evaluation = self#evaluate_stack_lhs_type offset faddr in
519513
let log_evaluation () =
520-
chlog#add
521-
("stacklhs resolution was not successfull:" ^ faddr)
522-
(LBLOCK [
523-
INT offset;
524-
STR ": ";
525-
pretty_print_list
526-
evaluation
527-
(fun (vars, consts) ->
528-
LBLOCK [
529-
STR "vars: ";
530-
pretty_print_list
531-
vars
532-
(fun v -> STR (type_variable_to_string v))
533-
"[" "; " "]";
534-
STR "; consts: ";
535-
pretty_print_list
536-
consts
537-
(fun c -> STR (type_constant_to_string c))
538-
"[" "; " "]";
539-
NL]) "[[" " -- " "]]"]) in
514+
log_diagnostics_result
515+
~tag:("stacklhs resolution was not successful for " ^ faddr)
516+
__FILE__ __LINE__
517+
[(string_of_int offset) ^ ": "
518+
^ (p2s (pretty_print_list
519+
evaluation
520+
(fun (vars, consts) ->
521+
LBLOCK [
522+
STR "vars: ";
523+
pretty_print_list
524+
vars
525+
(fun v -> STR (type_variable_to_string v))
526+
"[" "; " "]";
527+
STR "; consts: ";
528+
pretty_print_list
529+
consts
530+
(fun c -> STR (type_constant_to_string c))
531+
"[" "; " "]";
532+
NL]) "[[" " -- " "]]"))] in
540533
let first_field_struct (s: IntCollections.set_t): btype_t option =
541534
(* The type of a data item at a particular stack offset can legally
542535
be both a struct and the type of the first field of the struct.
@@ -566,19 +559,16 @@ object (self)
566559
let _ixftype = bcd#index_typ ftype in
567560
let _ixctype = bcd#index_typ ty in
568561
let _ =
569-
chlog#add
570-
"first field struct check"
571-
(LBLOCK [
572-
INT offset;
573-
STR ": ";
574-
pretty_print_list
575-
s#toList
576-
(fun i -> STR (btype_to_string (bcd#get_typ i)))
577-
"{" "; " "}";
578-
STR ": compinfo: ";
579-
STR cinfo.bcname;
580-
STR ": first field type: ";
581-
STR (btype_to_string ftype)]) in
562+
log_diagnostics_result
563+
~tag:"first field struct check"
564+
__FILE__ __LINE__
565+
[(string_of_int offset) ^ ": "
566+
^ (p2s (pretty_print_list
567+
s#toList
568+
(fun i -> STR (btype_to_string (bcd#get_typ i)))
569+
"{" "; " "}"))
570+
^ ": compinfo: " ^ cinfo.bcname
571+
^ ": first field type: " ^ (btype_to_string ftype)] in
582572
(* TBD: restore this check in a better way
583573
if s#fold (fun acc i -> acc && (i = ixftype || i = ixctype)) true then
584574
Some tstructarray
@@ -597,20 +587,18 @@ object (self)
597587
let ixftype = bcd#index_typ ftype in
598588
let ixctype = bcd#index_typ ty in
599589
let _ =
600-
chlog#add
601-
"first field struct check (TComp case)"
602-
(LBLOCK [
603-
INT offset;
604-
STR ": ";
605-
pretty_print_list
606-
s#toList
607-
(fun i -> STR (btype_to_string (bcd#get_typ i)))
608-
"{" "; " "}";
609-
STR ": compinfo: ";
610-
STR cinfo.bcname;
611-
STR ": first field type: ";
612-
STR (btype_to_string ftype)]) in
613-
if s#fold (fun acc i -> acc && (i = ixftype || i = ixctype)) true then
590+
log_diagnostics_result
591+
~tag:"first field struct check (TComp case)"
592+
__FILE__ __LINE__
593+
[(string_of_int offset) ^ ": "
594+
^ (p2s (pretty_print_list
595+
s#toList
596+
(fun i -> STR (btype_to_string (bcd#get_typ i)))
597+
"{" "; " "}"))
598+
^ ": compinfo: " ^ cinfo.bcname
599+
^ ": first field type: " ^ (btype_to_string ftype)] in
600+
if s#fold
601+
(fun acc i -> acc && (i = ixftype || i = ixctype)) true then
614602
Some ftype
615603
else
616604
None))
@@ -644,14 +632,13 @@ object (self)
644632
| _ ->
645633
begin
646634
log_evaluation ();
647-
chlog#add
648-
"multiple distinct types"
649-
(LBLOCK [
650-
INT offset;
651-
STR "; ";
652-
pretty_print_list
653-
(List.map bcd#get_typ result#toList)
654-
(fun ty -> STR (btype_to_string ty)) "[" "; " "]"]);
635+
log_diagnostics_result
636+
~tag:("multiple distinct types for " ^ faddr)
637+
__FILE__ __LINE__
638+
[(string_of_int offset) ^ ": "
639+
^ (p2s (pretty_print_list
640+
(List.map bcd#get_typ result#toList)
641+
(fun ty -> STR (btype_to_string ty)) "[" "; " "]"))];
655642
None
656643
end
657644
end

‎CodeHawk/CHB/bchlibarm32/bCHARMAnalysisResults.ml‎

Lines changed: 6 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
------------------------------------------------------------------------------
55
The MIT License (MIT)
66
7-
Copyright (c) 2021-2024 Aarno Labs LLC
7+
Copyright (c) 2021-2025 Aarno Labs LLC
88
99
Permission is hereby granted, free of charge, to any person obtaining a copy
1010
of this software and associated documentation files (the "Software"), to deal
@@ -25,9 +25,6 @@
2525
SOFTWARE.
2626
============================================================================= *)
2727

28-
(* chlib *)
29-
open CHPretty
30-
3128
(* chutil *)
3229
open CHLogger
3330
open CHXmlDocument
@@ -138,13 +135,11 @@ object (self)
138135
(fun baddr block ->
139136
let bNode = xmlElement "bl" in
140137
begin
141-
chlog#add
142-
"cfg assembly block"
143-
(LBLOCK [
144-
STR baddr;
145-
STR ": successors: ";
146-
pretty_print_list block#get_successors
147-
(fun s -> STR s) "[" ", " "]"]);
138+
log_diagnostics_result
139+
~tag:"cfg assembly block successors"
140+
__FILE__ __LINE__
141+
[baddr ^ ": ["
142+
^ (String.concat ", " block#get_successors) ^ "]"];
148143
self#write_xml_cfg_block bNode block;
149144
List.iter (fun succ ->
150145
let eNode = xmlElement "e" in

‎CodeHawk/CHB/bchlibarm32/bCHARMAssemblyFunctions.ml‎

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -703,14 +703,12 @@ object (self)
703703
end in
704704
let _ = db#set_data_string datastring in
705705
begin
706-
chlog#add
707-
"add data block"
708-
(LBLOCK [
709-
db#get_start_address#toPretty;
710-
STR " - ";
711-
db#get_end_address#toPretty;
712-
STR ": ";
713-
STR db#get_name]);
706+
(log_diagnostics_result
707+
~tag:"add data block"
708+
__FILE__ __LINE__
709+
[db#get_start_address#to_hex_string ^ " - "
710+
^ db#get_end_address#to_hex_string ^ ": "
711+
^ db#get_name]);
714712
system_info#add_data_block db;
715713
inBlock := false;
716714
count := !count + 1;

‎CodeHawk/CHB/bchlibarm32/bCHFnARMTypeConstraints.ml‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1332,10 +1332,10 @@ object (self)
13321332
end
13331333

13341334
| opc ->
1335-
chlog#add
1336-
"type constraints not yet implemented"
1337-
(LBLOCK [floc#l#toPretty; STR ": "; STR (arm_opcode_to_string opc)])
1338-
1335+
log_diagnostics_result
1336+
~tag:"type constraints not yet implemented"
1337+
__FILE__ __LINE__
1338+
[(p2s floc#l#toPretty) ^ ": " ^ (arm_opcode_to_string opc)]
13391339

13401340
end
13411341

0 commit comments

Comments
 (0)