From b466336e84107276e3d312c0ea0da65d01ea8256 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 11:16:49 +0300 Subject: [PATCH 01/95] Remove practically unused tracking (not tracing!) --- scripts/set_version.sh | 1 - scripts/track_off.sh | 6 ------ scripts/track_on.sh | 6 ------ src/maingoblint.ml | 2 +- src/solvers/generic.ml | 1 - src/util/messages.ml | 3 --- 6 files changed, 1 insertion(+), 18 deletions(-) delete mode 100755 scripts/track_off.sh delete mode 100755 scripts/track_on.sh diff --git a/scripts/set_version.sh b/scripts/set_version.sh index 95cea151fb..e097f3c4af 100755 --- a/scripts/set_version.sh +++ b/scripts/set_version.sh @@ -12,7 +12,6 @@ fi if [ ! -f src/config.ml ]; then { echo "let tracing = false" - echo "let tracking = false" echo "let experimental = false" echo "let cpp = \"cpp\"" } >> src/config.ml diff --git a/scripts/track_off.sh b/scripts/track_off.sh deleted file mode 100755 index 887fe732e2..0000000000 --- a/scripts/track_off.sh +++ /dev/null @@ -1,6 +0,0 @@ -#/usr/bin/env bash -make gen -scripts/set_version.sh -grep -q 'tracking = true' src/config.ml && \ - sed 's/tracking = true/tracking = false/' src/config.ml > src/config.tmp && mv src/config.tmp src/config.ml -make diff --git a/scripts/track_on.sh b/scripts/track_on.sh deleted file mode 100755 index d56760508a..0000000000 --- a/scripts/track_on.sh +++ /dev/null @@ -1,6 +0,0 @@ -#/usr/bin/env bash -make gen -scripts/set_version.sh -grep -q 'tracking = false' src/config.ml && \ - sed 's/tracking = false/tracking = true/' src/config.ml > src/config.tmp && mv src/config.tmp src/config.ml -make diff --git a/src/maingoblint.ml b/src/maingoblint.ml index a688472dbd..2efe2145d8 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -15,7 +15,7 @@ let print_version ch = let f ch b = if b then fprintf ch "enabled" else fprintf ch "disabled" in printf "Goblint version: %s\n" goblint; printf "Cil version: %s (%s)\n" Cil.cilVersion cil; - printf "Configuration: tracing %a, tracking %a\n" f tracing f tracking ; + printf "Configuration: tracing %a\n" f tracing; exit 0 (** Print helpful messages. *) diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 01cb1822a2..93b38dd040 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -296,7 +296,6 @@ struct let eval_rhs_event x = if full_trace then trace "sol" "(Re-)evaluating %a\n" Var.pretty_trace x; - if Config.tracking then M.track "eval"; Goblintutil.evals := !Goblintutil.evals + 1; if (get_bool "dbg.solver-progress") then (incr stack_d; print_int !stack_d; flush stdout) diff --git a/src/util/messages.ml b/src/util/messages.ml index ecb51e1c60..410b60a480 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -238,9 +238,6 @@ let push_warning w = if get_string "result" = "fast_xml" || get_bool "gobview" then warning_table := w :: !warning_table -let track m = - let loc = !Tracing.current_loc in - Printf.fprintf !warn_out "Track (%s); %s\n" (CilType.Location.show loc) m (*Warning files*) let warn_race = ref stdout From 27a3ea7468213754937bbbd33597640dd5276823 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 11:22:14 +0300 Subject: [PATCH 02/95] Remove unused Config.experimental --- scripts/set_version.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/scripts/set_version.sh b/scripts/set_version.sh index e097f3c4af..daa7c65fb1 100755 --- a/scripts/set_version.sh +++ b/scripts/set_version.sh @@ -12,7 +12,6 @@ fi if [ ! -f src/config.ml ]; then { echo "let tracing = false" - echo "let experimental = false" echo "let cpp = \"cpp\"" } >> src/config.ml fi From 36063d2234ce19a87afc4674435571085db6b41e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:20:32 +0300 Subject: [PATCH 03/95] Remove gccwarn option --- src/util/cilType.ml | 1 - src/util/defaults.ml | 4 +--- src/util/messages.ml | 14 ++++---------- 3 files changed, 5 insertions(+), 14 deletions(-) diff --git a/src/util/cilType.ml b/src/util/cilType.ml index 9d45750cbd..35416fca80 100644 --- a/src/util/cilType.ml +++ b/src/util/cilType.ml @@ -27,7 +27,6 @@ struct (* Output *) let show x = - (* Also used for gccwarn, so should be the GCC format *) (* TODO: add special output for locUnknown *) x.file ^ ":" ^ string_of_int x.line ^ ":" ^ string_of_int x.column diff --git a/src/util/defaults.ml b/src/util/defaults.ml index 350c747a6a..e26c39269c 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -65,7 +65,6 @@ let _ = () ; reg Std "justcil" "false" "Just parse and output the CIL." ; reg Std "justcfg" "false" "Only output the CFG in cfg.dot ." ; reg Std "printstats" "false" "Outputs timing information." - ; reg Std "gccwarn" "false" "Output warnings in GCC format." ; reg Std "verify" "true" "Verify that the solver reached a post-fixpoint. Beware that disabling this also disables output of warnings since post-processing of the results is done in the verification phase!" ; reg Std "mainfun" "['main']" "Sets the name of the main functions." ; reg Std "exitfun" "[]" "Sets the name of the cleanup functions." @@ -252,7 +251,7 @@ let _ = () let default_schema = "\ { 'id' : 'root' , 'type' : 'object' -, 'required' : ['outfile', 'includes', 'kernel_includes', 'custom_includes', 'custom_incl', 'custom_libc', 'justcil', 'justcfg', 'printstats', 'gccwarn', 'verify', 'mainfun', 'exitfun', 'otherfun', 'allglobs', 'keepcpp', 'tempDir', 'cppflags', 'kernel', 'dump_globs', 'result', 'warnstyle', 'solver', 'allfuns', 'nonstatic', 'colors', 'g2html'] +, 'required' : ['outfile', 'includes', 'kernel_includes', 'custom_includes', 'custom_incl', 'custom_libc', 'justcil', 'justcfg', 'printstats', 'verify', 'mainfun', 'exitfun', 'otherfun', 'allglobs', 'keepcpp', 'tempDir', 'cppflags', 'kernel', 'dump_globs', 'result', 'warnstyle', 'solver', 'allfuns', 'nonstatic', 'colors', 'g2html'] , 'additionalProps' : false , 'properties' : { 'ana' : @@ -285,7 +284,6 @@ let default_schema = "\ , 'justcil' : {} , 'justcfg' : {} , 'printstats' : {} - , 'gccwarn' : {} , 'verify' : {} , 'mainfun' : {} , 'exitfun' : {} diff --git a/src/util/messages.ml b/src/util/messages.ml index 410b60a480..ee0e1c74e7 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -277,19 +277,13 @@ let print_msg msg loc = let msgc = colorize msg in let msg = colorize ~on:false msg in push_warning (`text (msg, loc)); - if get_bool "gccwarn" then - Printf.printf "%s: warning: %s\n" (CilType.Location.show loc) msg - else - let color = if colors_on () then "{violet}" else "" in - let s = Printf.sprintf "%s %s(%s)" msgc color (CilType.Location.show loc) in - Printf.fprintf !warn_out "%s\n%!" (colorize s) + let color = if colors_on () then "{violet}" else "" in + let s = Printf.sprintf "%s %s(%s)" msgc color (CilType.Location.show loc) in + Printf.fprintf !warn_out "%s\n%!" (colorize s) let print_err msg loc = push_warning (`text (msg, loc)); - if get_bool "gccwarn" then - Printf.printf "%s: error: %s\n" (CilType.Location.show loc) msg - else - Printf.fprintf !warn_out "%s (%s)\n%!" msg (CilType.Location.show loc) + Printf.fprintf !warn_out "%s (%s)\n%!" msg (CilType.Location.show loc) let print_group group_name errors = From f4035f645d34e7447bc88c2f7e3971f129aba836 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:22:33 +0300 Subject: [PATCH 04/95] Remove Messages.waitWhat and StopTheWorld --- src/util/messages.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index ee0e1c74e7..63e0341e46 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -315,10 +315,6 @@ let warn_all ?loc:(loc= !Tracing.current_loc) msg = soundness := false end -exception StopTheWorld -let waitWhat s = - print_msg s (!Tracing.current_loc); - raise StopTheWorld let report_error msg = if !GU.should_warn then begin From d41b6e5dd6ff2a65e8d6b78f8ef9c1662a0500dc Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:23:07 +0300 Subject: [PATCH 05/95] Remove unused Messages.warn_urgent --- src/util/messages.ml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 63e0341e46..039943b5f1 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -302,11 +302,6 @@ let print_group group_name errors = end; ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) -let warn_urgent msg = - if !GU.should_warn then begin - soundness := false; - print_msg msg (!Tracing.current_loc) - end let warn_all ?loc:(loc= !Tracing.current_loc) msg = if !GU.should_warn then begin From 219ef11660b10eaecaa72c38dc41a056dcb90ba8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:24:21 +0300 Subject: [PATCH 06/95] Remove unused Messages.soundness variable --- src/util/messages.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 039943b5f1..82dfc7701e 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -229,7 +229,6 @@ let bailwith s = raise (Bailure s) let warning_table : [`text of string * location | `group of string * ((string * location) list)] list ref = ref [] let warnings = ref false -let soundness = ref true let warn_out = ref stdout let tracing = Config.tracing let xml_file_name = ref "" @@ -306,8 +305,7 @@ let print_group group_name errors = let warn_all ?loc:(loc= !Tracing.current_loc) msg = if !GU.should_warn then begin if !warnings then - print_msg msg loc; - soundness := false + print_msg msg loc end From dedea29ffd22af14daae1f51d0f3a2687743b184 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:25:38 +0300 Subject: [PATCH 07/95] Remove confusing Messages.warnings variable and print warnings regardless of dbg.debug --- src/maingoblint.ml | 1 - src/util/messages.ml | 7 ++----- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 2efe2145d8..1f04728e71 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -132,7 +132,6 @@ let handle_flags () = let has_oil = get_string "ana.osek.oil" <> "" in if has_oil then Osek.Spec.parse_oil (); - if get_bool "dbg.debug" then Messages.warnings := true; if get_bool "dbg.verbose" then ( Printexc.record_backtrace true; Errormsg.debugFlag := true; diff --git a/src/util/messages.ml b/src/util/messages.ml index 82dfc7701e..37cc5501cc 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -228,7 +228,6 @@ exception Bailure of string let bailwith s = raise (Bailure s) let warning_table : [`text of string * location | `group of string * ((string * location) list)] list ref = ref [] -let warnings = ref false let warn_out = ref stdout let tracing = Config.tracing let xml_file_name = ref "" @@ -303,10 +302,8 @@ let print_group group_name errors = let warn_all ?loc:(loc= !Tracing.current_loc) msg = - if !GU.should_warn then begin - if !warnings then - print_msg msg loc - end + if !GU.should_warn then + print_msg msg loc let report_error msg = From 5e86bdbab9969b1f4bae09cccbc898597d1b4745 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 12:26:43 +0300 Subject: [PATCH 08/95] Add warnings to warning_table regardless of options --- src/util/messages.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 37cc5501cc..b20cd5afff 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -233,8 +233,7 @@ let tracing = Config.tracing let xml_file_name = ref "" let push_warning w = - if get_string "result" = "fast_xml" || get_bool "gobview" then - warning_table := w :: !warning_table + warning_table := w :: !warning_table (*Warning files*) From 6c4490328004467ddc358b206792bbab716945fb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:23:11 +0300 Subject: [PATCH 09/95] Add more general Message record, use for deduplication --- src/util/messages.ml | 47 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 37 insertions(+), 10 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index b20cd5afff..8df2314e6e 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -7,20 +7,23 @@ type array_oob = | PastEnd | BeforeStart | Unknown + [@@deriving eq] type undefined_behavior = | ArrayOutOfBounds of array_oob | NullPointerDereference | UseAfterFree + [@@deriving eq] type behavior = | Undefined of undefined_behavior | Implementation | Machine + [@@deriving eq] -type integer = Overflow | DivByZero +type integer = Overflow | DivByZero [@@deriving eq] -type cast = TypeMismatch +type cast = TypeMismatch [@@deriving eq] type warning = | Behavior of behavior @@ -30,10 +33,13 @@ type warning = | Unknown | Debug | Analyzer + [@@deriving eq] module Warning = struct - type t = warning + type t = warning [@@deriving eq] + + let hash x = Hashtbl.hash x (* nested variants, so this is fine *) module Behavior = struct @@ -187,7 +193,9 @@ struct end module Certainty = struct - type t = May | Must + type t = May | Must [@@deriving eq] + + let hash x = Hashtbl.hash x (* variants, so this is fine *) let should_warn e = let to_string e = @@ -224,6 +232,24 @@ struct in warning_tag^certainty_str^(Warning.show warn_type) end +module Message = +struct + type t = { + warn_type: Warning.t; (* TODO: make list of tags *) + certainty: Certainty.t option; (* TODO: change to severity levels, make non-option *) + loc: CilType.Location.t option; + text: string; + (* TODO: context somehow? *) + } [@@deriving eq] + + let hash {warn_type; certainty; loc; text} = + 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text +end + +module MH = Hashtbl.Make (Message) +let messages_table = MH.create 113 + + exception Bailure of string let bailwith s = raise (Bailure s) @@ -315,17 +341,17 @@ let with_context msg = function | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) | _ -> msg -let warn_str_hashtbl = Hashtbl.create 10 -let warn_lin_hashtbl = Hashtbl.create 10 let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin let msg = (WarningWithCertainty.show warning)^(if msg != "" then " "^msg else "") in let msg = with_context msg ctx in - if (Hashtbl.mem warn_str_hashtbl msg == false) then + (* TODO: warn_all still adds loc below? *) + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg} in + if not (MH.mem messages_table m) then begin warn_all msg; - Hashtbl.add warn_str_hashtbl msg true + MH.replace messages_table m () end end @@ -333,10 +359,11 @@ let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") ( if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin let msg = (WarningWithCertainty.show warning)^(if msg != "" then " "^msg else "") in let msg = with_context msg ctx in - if (Hashtbl.mem warn_lin_hashtbl (msg,loc) == false) then + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg} in + if not (MH.mem messages_table m) then begin warn_all ~loc:loc msg; - Hashtbl.add warn_lin_hashtbl (msg,loc) true + MH.replace messages_table m () end end From 5689bb4247285e97d1f05584a9142cce0134f6ee Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:28:36 +0300 Subject: [PATCH 10/95] Deduplicate message string construction --- src/util/messages.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 8df2314e6e..e3889cb5d1 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -244,6 +244,11 @@ struct let hash {warn_type; certainty; loc; text} = 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + + let show {warn_type; certainty; loc; text} = + let msg = (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in + (* let msg = with_context msg ctx in *) + msg end module MH = Hashtbl.Make (Message) @@ -344,25 +349,21 @@ let with_context msg = function let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let msg = (WarningWithCertainty.show warning)^(if msg != "" then " "^msg else "") in - let msg = with_context msg ctx in - (* TODO: warn_all still adds loc below? *) let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg} in + (* TODO: warn_all still adds loc below? *) if not (MH.mem messages_table m) then begin - warn_all msg; + warn_all (Message.show m); MH.replace messages_table m () end end let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let msg = (WarningWithCertainty.show warning)^(if msg != "" then " "^msg else "") in - let msg = with_context msg ctx in let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg} in if not (MH.mem messages_table m) then begin - warn_all ~loc:loc msg; + warn_all ~loc:loc (Message.show m); MH.replace messages_table m () end end From 676ca5cc55f277d364f327987c8ca9cdd45a4f15 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:34:50 +0300 Subject: [PATCH 11/95] Add context to message as Obj.t --- src/util/messages.ml | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index e3889cb5d1..5632ae3dfb 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -239,15 +239,19 @@ struct certainty: Certainty.t option; (* TODO: change to severity levels, make non-option *) loc: CilType.Location.t option; text: string; - (* TODO: context somehow? *) + context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)]) option; (* TODO: this equality is terrible... *) } [@@deriving eq] - let hash {warn_type; certainty; loc; text} = - 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + let hash {warn_type; certainty; loc; text; context} = + 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context - let show {warn_type; certainty; loc; text} = + let with_context msg = function + | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) + | _ -> msg + + let show {warn_type; certainty; loc; text; context} = let msg = (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in - (* let msg = with_context msg ctx in *) + let msg = with_context msg context in msg end @@ -342,14 +346,12 @@ let report_error msg = print_err msg loc end -let with_context msg = function - | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) - | _ -> msg +(* TODO: don't take context as argument, but add global Tracing.current_context *) let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg} in + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = Option.map Obj.repr ctx} in (* TODO: warn_all still adds loc below? *) if not (MH.mem messages_table m) then begin @@ -360,7 +362,7 @@ let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg} in + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = Option.map Obj.repr ctx} in if not (MH.mem messages_table m) then begin warn_all ~loc:loc (Message.show m); From ac2667b38616b2d2307aa111fff3dc0bf1eaf852 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:36:17 +0300 Subject: [PATCH 12/95] Add messages list to keep order --- src/util/messages.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 5632ae3dfb..d2bc559f0a 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -256,7 +256,8 @@ struct end module MH = Hashtbl.Make (Message) -let messages_table = MH.create 113 +let messages_table = MH.create 113 (* messages without order for quick mem lookup *) +let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) exception Bailure of string @@ -356,7 +357,8 @@ let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if not (MH.mem messages_table m) then begin warn_all (Message.show m); - MH.replace messages_table m () + MH.replace messages_table m (); + messages_list := m :: !messages_list end end @@ -366,7 +368,8 @@ let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") ( if not (MH.mem messages_table m) then begin warn_all ~loc:loc (Message.show m); - MH.replace messages_table m () + MH.replace messages_table m (); + messages_list := m :: !messages_list end end From e72cba53a8526044b5683878f7b61a0235bbb539 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:43:19 +0300 Subject: [PATCH 13/95] Remove warn_all usage outside Messages --- src/analyses/osek.ml | 2 +- src/cdomains/intDomain.ml | 2 +- src/cdomains/valueDomain.ml | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/analyses/osek.ml b/src/analyses/osek.ml index e0dac0c30b..b5d9b44ae4 100644 --- a/src/analyses/osek.ml +++ b/src/analyses/osek.ml @@ -485,7 +485,7 @@ struct let unknown_access () = (*M.warn_each ~msg:"unknown access 'with lockset:'" ();*) - Messages.warn_all "Access to unknown address could be global" + Messages.warn_each ~msg:"Access to unknown address could be global" () (* All else must have failed --- making a last ditch effort to generate type invariant if that fails then give up and become unsound. *) diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 104eb852e6..fa56b68113 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -2718,7 +2718,7 @@ module IntDomTupleImpl = struct let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in if n = 1 then Some (List.hd xs) else ( - if n>1 then Messages.warn_all @@ "Inconsistent state! "^String.concat "," @@ List.map show us; (* do not want to abort, but we need some unsound category *) + if n>1 then Messages.warn_each ~msg:("Inconsistent state! "^String.concat "," @@ List.map show us) (); (* do not want to abort, but we need some unsound category *) None ) let to_int = same BI.to_string % mapp2 { fp2 = fun (type a) (module I:S with type t = a and type int_t = int_t) -> I.to_int } diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index da0b31ef5e..fa35dd2dd0 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -442,7 +442,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_all m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.join AD.null_ptr y @@ -469,7 +469,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_all m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.join AD.null_ptr y @@ -497,7 +497,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_all m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.widen AD.null_ptr y @@ -562,7 +562,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_all m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.widen AD.null_ptr y From 57b0eb92e80583a0c34365a1b69779b2800fadcf Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:50:52 +0300 Subject: [PATCH 14/95] Move common code to warn_all --- src/util/messages.ml | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index d2bc559f0a..14fed1f12d 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -336,9 +336,12 @@ let print_group group_name errors = ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) -let warn_all ?loc:(loc= !Tracing.current_loc) msg = - if !GU.should_warn then - print_msg msg loc +let warn_all ?loc:(loc= !Tracing.current_loc) m = + if not (MH.mem messages_table m) then ( + print_msg (Message.show m) loc; + MH.replace messages_table m (); + messages_list := m :: !messages_list + ) let report_error msg = @@ -354,23 +357,13 @@ let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = Option.map Obj.repr ctx} in (* TODO: warn_all still adds loc below? *) - if not (MH.mem messages_table m) then - begin - warn_all (Message.show m); - MH.replace messages_table m (); - messages_list := m :: !messages_list - end + warn_all m end let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = Option.map Obj.repr ctx} in - if not (MH.mem messages_table m) then - begin - warn_all ~loc:loc (Message.show m); - MH.replace messages_table m (); - messages_list := m :: !messages_list - end + warn_all ~loc:loc m end let warn ?must:(must=false) ?ctx ?msg:(msg="") ?warning:(warning=Unknown) () = From c788faca9348b64339cbfc2b845003c4918f8314 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 15:53:28 +0300 Subject: [PATCH 15/95] Remove report_error --- src/cdomains/containDomain.ml | 2 +- src/util/messages.ml | 12 ------------ 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 05a9180bff..01494fd21e 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -262,7 +262,7 @@ struct let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.report_error ("CW: "^x) + Messages.warn_each ~warning:Messages.Analyzer ~msg:("CW: "^x) () (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar diff --git a/src/util/messages.ml b/src/util/messages.ml index 14fed1f12d..7ca86591f7 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -314,10 +314,6 @@ let print_msg msg loc = let s = Printf.sprintf "%s %s(%s)" msgc color (CilType.Location.show loc) in Printf.fprintf !warn_out "%s\n%!" (colorize s) -let print_err msg loc = - push_warning (`text (msg, loc)); - Printf.fprintf !warn_out "%s (%s)\n%!" msg (CilType.Location.show loc) - let print_group group_name errors = (* Add warnings to global warning list *) @@ -343,14 +339,6 @@ let warn_all ?loc:(loc= !Tracing.current_loc) m = messages_list := m :: !messages_list ) - -let report_error msg = - if !GU.should_warn then begin - let loc = !Tracing.current_loc in - print_err msg loc - end - - (* TODO: don't take context as argument, but add global Tracing.current_context *) let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = From 448be7b7ba0f3ed1811224109143e2fd9ecaabb4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 16:06:32 +0300 Subject: [PATCH 16/95] Simplify Messages.debug --- src/util/messages.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 7ca86591f7..6bc51b6483 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -250,6 +250,10 @@ struct | _ -> msg let show {warn_type; certainty; loc; text; context} = + let text = match warn_type with + | Debug -> "{BLUE}"^text (* TODO: don't do it like this *) + | _ -> text + in let msg = (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in let msg = with_context msg context in msg @@ -363,9 +367,9 @@ let warn_each ?must:(must=false) ?ctx ?loc ?msg:(msg="") ?warning:(warning=Unkno | None -> warn_internal_with_loc ~ctx:ctx ~msg:msg (WarningWithCertainty.create ~must:must warning) let debug msg = - if (get_bool "dbg.debug") then warn_internal ~msg:("{BLUE}"^msg) @@ WarningWithCertainty.debug () + warn_internal ~msg @@ WarningWithCertainty.debug () let debug_each msg = - if (get_bool "dbg.debug") then warn_internal_with_loc ~msg:("{blue}"^msg) @@ WarningWithCertainty.debug () + warn_internal_with_loc ~msg @@ WarningWithCertainty.debug () include Tracing From 231d0bb0f1f2c100b0c1b4984883248072c81a70 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 25 Aug 2021 16:29:27 +0300 Subject: [PATCH 17/95] Remove loc argument on warn_all --- src/util/messages.ml | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 6bc51b6483..0a29564326 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -237,19 +237,20 @@ struct type t = { warn_type: Warning.t; (* TODO: make list of tags *) certainty: Certainty.t option; (* TODO: change to severity levels, make non-option *) - loc: CilType.Location.t option; + loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)]) option; (* TODO: this equality is terrible... *) + print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq] - let hash {warn_type; certainty; loc; text; context} = + let hash {warn_type; certainty; loc; text; context; print_loc} = 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context let with_context msg = function | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) | _ -> msg - let show {warn_type; certainty; loc; text; context} = + let show {warn_type; certainty; loc; text; context; print_loc} = let text = match warn_type with | Debug -> "{BLUE}"^text (* TODO: don't do it like this *) | _ -> text @@ -336,9 +337,9 @@ let print_group group_name errors = ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) -let warn_all ?loc:(loc= !Tracing.current_loc) m = +let warn_all m = if not (MH.mem messages_table m) then ( - print_msg (Message.show m) loc; + print_msg (Message.show m) m.print_loc; MH.replace messages_table m (); messages_list := m :: !messages_list ) @@ -347,24 +348,21 @@ let warn_all ?loc:(loc= !Tracing.current_loc) m = let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = Option.map Obj.repr ctx} in - (* TODO: warn_all still adds loc below? *) + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = Option.map Obj.repr ctx; print_loc = !Tracing.current_loc} in warn_all m end let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = Option.map Obj.repr ctx} in - warn_all ~loc:loc m + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = Option.map Obj.repr ctx; print_loc = loc} in + warn_all m end let warn ?must:(must=false) ?ctx ?msg:(msg="") ?warning:(warning=Unknown) () = warn_internal ~ctx:ctx ~msg:msg (WarningWithCertainty.create ~must:must warning) let warn_each ?must:(must=false) ?ctx ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - match loc with - | Some loc -> warn_internal_with_loc ~ctx:ctx ~loc:loc ~msg:msg (WarningWithCertainty.create ~must:must warning) - | None -> warn_internal_with_loc ~ctx:ctx ~msg:msg (WarningWithCertainty.create ~must:must warning) + warn_internal_with_loc ~ctx:ctx ?loc ~msg:msg (WarningWithCertainty.create ~must:must warning) let debug msg = warn_internal ~msg @@ WarningWithCertainty.debug () From f5ddc4c956501717dc90de7f782ae7ca8cbcc8e3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 10:49:10 +0300 Subject: [PATCH 18/95] Replace warn context argument with Messages.current_context --- src/analyses/base.ml | 6 +++--- src/framework/constraints.ml | 3 +++ src/util/messages.ml | 18 +++++++++--------- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 1acf46a07c..2747bd4589 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1958,10 +1958,10 @@ struct (* Expressions with logical connectives like a && b are calculated in temporary variables by CIL. Instead of the original expression, we then see something like tmp___0. So we replace expr in msg by the original source if this is the case. *) let assert_expr = if string_match (regexp ".*assert(\\(.+\\));.*") line 0 then matched_group 1 line else expr in let msg = if expr <> assert_expr then String.nreplace msg expr assert_expr else msg in - M.warn_each ~ctx:ctx.control_context ~msg:(msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) () + M.warn_each ~msg:(msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) () ) ) else - M.warn_each ~ctx:ctx.control_context ~msg:msg () + M.warn_each ~msg:msg () in match check_assert e ctx.local with | `Lifted false -> @@ -1971,7 +1971,7 @@ struct warn ("{green}Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.warn_each ~ctx:ctx.control_context ~msg:("{red}Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)") (); + M.warn_each ~msg:("{red}Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)") (); ctx.local | `Top -> warn ~annot:"UNKNOWN" ("{yellow}Assertion \"" ^ expr ^ "\" is unknown."); diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 76af757598..ae8b2a5b1c 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -746,10 +746,13 @@ struct let tf (v,c) (e,u) getl sidel getg sideg = let old_node = !current_node in + let old_context = !M.current_context in let _ = current_node := Some u in + M.current_context := Some (Obj.repr c); let d = try tf (v,c) (e,u) getl sidel getg sideg with M.Bailure s -> Messages.warn_each ~msg:s (); (getl (u,c)) in let _ = current_node := old_node in + M.current_context := old_context; d let system (v,c) = diff --git a/src/util/messages.ml b/src/util/messages.ml index 0a29564326..ddb1dccc74 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -344,25 +344,25 @@ let warn_all m = messages_list := m :: !messages_list ) -(* TODO: don't take context as argument, but add global Tracing.current_context *) +let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let warn_internal ?ctx ?msg:(msg="") (warning: WarningWithCertainty.t) = +let warn_internal ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = Option.map Obj.repr ctx; print_loc = !Tracing.current_loc} in + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} in warn_all m end -let warn_internal_with_loc ?ctx ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = +let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = Option.map Obj.repr ctx; print_loc = loc} in + let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = !current_context; print_loc = loc} in warn_all m end -let warn ?must:(must=false) ?ctx ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal ~ctx:ctx ~msg:msg (WarningWithCertainty.create ~must:must warning) +let warn ?must:(must=false) ?msg:(msg="") ?warning:(warning=Unknown) () = + warn_internal ~msg:msg (WarningWithCertainty.create ~must:must warning) -let warn_each ?must:(must=false) ?ctx ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal_with_loc ~ctx:ctx ?loc ~msg:msg (WarningWithCertainty.create ~must:must warning) +let warn_each ?must:(must=false) ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = + warn_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create ~must:must warning) let debug msg = warn_internal ~msg @@ WarningWithCertainty.debug () From 33aefa75bd2c0f06dc6b9d0322548c367be8ffcb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 10:57:18 +0300 Subject: [PATCH 19/95] Deduplicate should_warn checks --- src/util/messages.ml | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index ddb1dccc74..1c08257faa 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -338,25 +338,22 @@ let print_group group_name errors = let warn_all m = - if not (MH.mem messages_table m) then ( - print_msg (Message.show m) m.print_loc; - MH.replace messages_table m (); - messages_list := m :: !messages_list + if !GU.should_warn then ( + let wc = WarningWithCertainty.{warn_type = m.Message.warn_type; certainty = m.Message.certainty} in (* TODO: don't reconstruct this *) + if WarningWithCertainty.should_warn wc && not (MH.mem messages_table m) then ( + print_msg (Message.show m) m.print_loc; + MH.replace messages_table m (); + messages_list := m :: !messages_list + ) ) let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) let warn_internal ?msg:(msg="") (warning: WarningWithCertainty.t) = - if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} in - warn_all m - end + warn_all {warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = - if !GU.should_warn && (WarningWithCertainty.should_warn warning) then begin - let m = Message.{warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = !current_context; print_loc = loc} in - warn_all m - end + warn_all {warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = !current_context; print_loc = loc} let warn ?must:(must=false) ?msg:(msg="") ?warning:(warning=Unknown) () = warn_internal ~msg:msg (WarningWithCertainty.create ~must:must warning) From 8a953834048b0297f9c3dd76f4d7a775d8ab6fc6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:06:22 +0300 Subject: [PATCH 20/95] Add severity to messages --- src/util/messages.ml | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 1c08257faa..870a4cbe65 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -232,30 +232,43 @@ struct in warning_tag^certainty_str^(Warning.show warn_type) end +module Severity = +struct + type t = + | Error + | Warning + | Info + | Debug + [@@deriving eq, show { with_path = false }] + + let hash x = Hashtbl.hash x (* variants, so this is fine *) +end + module Message = struct type t = { warn_type: Warning.t; (* TODO: make list of tags *) certainty: Certainty.t option; (* TODO: change to severity levels, make non-option *) + severity: Severity.t; loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)]) option; (* TODO: this equality is terrible... *) print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq] - let hash {warn_type; certainty; loc; text; context; print_loc} = - 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + let hash {warn_type; certainty; severity; loc; text; context; print_loc} = + 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + 13 * Severity.hash severity let with_context msg = function | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) | _ -> msg - let show {warn_type; certainty; loc; text; context; print_loc} = + let show {warn_type; certainty; severity; loc; text; context; print_loc} = let text = match warn_type with | Debug -> "{BLUE}"^text (* TODO: don't do it like this *) | _ -> text in - let msg = (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in + let msg = "[" ^ Severity.show severity ^ "]" ^ (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in let msg = with_context msg context in msg end @@ -350,10 +363,10 @@ let warn_all m = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) let warn_internal ?msg:(msg="") (warning: WarningWithCertainty.t) = - warn_all {warn_type = warning.warn_type; certainty = warning.certainty; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} + warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Warning; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = - warn_all {warn_type = warning.warn_type; certainty = warning.certainty; loc = Some loc; text = msg; context = !current_context; print_loc = loc} + warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Warning; loc = Some loc; text = msg; context = !current_context; print_loc = loc} let warn ?must:(must=false) ?msg:(msg="") ?warning:(warning=Unknown) () = warn_internal ~msg:msg (WarningWithCertainty.create ~must:must warning) @@ -362,9 +375,9 @@ let warn_each ?must:(must=false) ?loc ?msg:(msg="") ?warning:(warning=Unknown) ( warn_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create ~must:must warning) let debug msg = - warn_internal ~msg @@ WarningWithCertainty.debug () + warn_internal ~msg @@ WarningWithCertainty.debug () (* TODO: debug severity *) let debug_each msg = - warn_internal_with_loc ~msg @@ WarningWithCertainty.debug () + warn_internal_with_loc ~msg @@ WarningWithCertainty.debug () (* TODO: debug severity *) include Tracing From e858524d96537e6a68bca55a604b722d4aeea337 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:12:42 +0300 Subject: [PATCH 21/95] Replace must warnings with error severity messages --- src/analyses/base.ml | 2 +- src/cdomains/arrayDomain.ml | 4 ++-- src/cdomains/lvalMapDomain.ml | 4 ++-- src/util/messages.ml | 14 ++++++++++---- 4 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 2747bd4589..3f6617f595 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -803,7 +803,7 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.warn_each ~must:true ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) () + then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) () else if AD.may_be_null adr then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ()); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index cad359526a..494f629082 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,11 +575,11 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.warn_each ~must:true ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) () | Some true, None -> M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) () | Some false, Some true -> - M.warn_each ~must:true ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) () | None, Some true -> M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) () | _ -> diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index 36977a717b..079f849e24 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -252,10 +252,10 @@ struct let warn ?may:(may=false) ?loc:(loc=[!Tracing.current_loc]) msg = match msg |> Str.split (Str.regexp "[ \n\r\x0c\t]+") with - | [] -> Messages.warn_each ~must:(not may) ~loc:(List.last loc) ~msg:msg () + | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~msg:msg () | h :: t -> let warn_type = Messages.Warning.from_string_list (h |> Str.split (Str.regexp "[.]")) - in Messages.warn_each ~must:(not may) ~loc:(List.last loc) ~msg:(String.concat " " t) ~warning:warn_type () + in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~msg:(String.concat " " t) ~warning:warn_type () (* getting keys from Cil Lvals *) let sprint f x = Pretty.sprint 80 (f () x) diff --git a/src/util/messages.ml b/src/util/messages.ml index 870a4cbe65..17d93b471a 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -368,11 +368,17 @@ let warn_internal ?msg:(msg="") (warning: WarningWithCertainty.t) = let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Warning; loc = Some loc; text = msg; context = !current_context; print_loc = loc} -let warn ?must:(must=false) ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal ~msg:msg (WarningWithCertainty.create ~must:must warning) +let warn ?msg:(msg="") ?warning:(warning=Unknown) () = + warn_internal ~msg:msg (WarningWithCertainty.create warning) -let warn_each ?must:(must=false) ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create ~must:must warning) +let warn_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = + warn_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create warning) + +let error_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = + warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Error; loc = Some loc; text = msg; context = !current_context; print_loc = loc} + +let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = + error_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create ~must:true warning) let debug msg = warn_internal ~msg @@ WarningWithCertainty.debug () (* TODO: debug severity *) From 74f0c019d644560e1c914f23071bf3090ec78f29 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:13:53 +0300 Subject: [PATCH 22/95] Consider Error as warning for regression testing --- scripts/update_suite.rb | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/update_suite.rb b/scripts/update_suite.rb index daa70905f3..b6da770932 100755 --- a/scripts/update_suite.rb +++ b/scripts/update_suite.rb @@ -397,6 +397,7 @@ def to_s when /Assertion .* will succeed/ then "success" when /Assertion .* is unknown/ then "unknown" when /^\[Warning\]/ then "warn" + when /^\[Error\]/ then "warn" when /\[Debug\]/ then next # debug "warnings" shouldn't count as other warnings (against NOWARN) else "other" end From 4679fdf2d7a4583112a6c0adb323a404246b886e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:20:33 +0300 Subject: [PATCH 23/95] Remove warning certainty --- src/util/defaults.ml | 8 +++-- src/util/messages.ml | 84 ++++++++++++++------------------------------ 2 files changed, 32 insertions(+), 60 deletions(-) diff --git a/src/util/defaults.ml b/src/util/defaults.ml index e26c39269c..9f275b91c2 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -244,9 +244,11 @@ let _ = () ; reg Warnings "warn.race" "true" "Race warnings" ; reg Warnings "warn.array" "true" "Array (Out_of_bounds of int*int) warnings" ; reg Warnings "warn.unknown" "true" "Unknown (of string) warnings" - ; reg Warnings "warn.debug" "true" "Debug (of string) warnings" - ; reg Warnings "warn.may" "true" "Enable or disable may warnings" - ; reg Warnings "warn.must" "true" "Enable or disable must warnings" + (* ; reg Warnings "warn.debug" "true" "Debug (of string) warnings" *) + ; reg Warnings "warn.error" "true" "Error severity messages" + ; reg Warnings "warn.warning" "true" "Warning severity messages" + ; reg Warnings "warn.info" "true" "Info severity messages" + ; reg Warnings "warn.debug" "true" "Debug severity messages" let default_schema = "\ { 'id' : 'root' diff --git a/src/util/messages.ml b/src/util/messages.ml index 17d93b471a..6108f18329 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -192,45 +192,6 @@ struct | _ -> Unknown end -module Certainty = struct - type t = May | Must [@@deriving eq] - - let hash x = Hashtbl.hash x (* variants, so this is fine *) - - let should_warn e = - let to_string e = - match e with - | May -> "may" - | Must -> "must" - in get_bool ("warn." ^ (to_string e)) - - let show c = - match c with - | May -> "[May]" - | Must -> "[Must]" -end - -module WarningWithCertainty = -struct - type t = { - warn_type : Warning.t; - certainty: Certainty.t option - } - - let should_warn (e:t) = Warning.should_warn e.warn_type && (match e.certainty with Some c -> Certainty.should_warn c | _ -> true) - - let debug () = {warn_type = Debug; certainty = None} - - let create ?must:(must=false) w = {warn_type = w; certainty = Some (if must then Certainty.Must else Certainty.May)} - let show {warn_type; certainty} = - let certainty_str = match certainty with - | Some c -> (Certainty.show c) - | None -> "" - and warning_tag = match warn_type with - | Debug -> "" - | _ -> "[Warning]" - in warning_tag^certainty_str^(Warning.show warn_type) -end module Severity = struct @@ -242,13 +203,21 @@ struct [@@deriving eq, show { with_path = false }] let hash x = Hashtbl.hash x (* variants, so this is fine *) + + let should_warn e = + let to_string = function + | Error -> "error" + | Warning -> "warning" + | Info -> "info" + | Debug -> "debug" + in + get_bool ("warn." ^ (to_string e)) end module Message = struct type t = { warn_type: Warning.t; (* TODO: make list of tags *) - certainty: Certainty.t option; (* TODO: change to severity levels, make non-option *) severity: Severity.t; loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; @@ -256,19 +225,21 @@ struct print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq] - let hash {warn_type; certainty; severity; loc; text; context; print_loc} = - 3 * Warning.hash warn_type + 5 * BatOption.map_default Certainty.hash 1 certainty + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + 13 * Severity.hash severity + (* TODO: add should_warn that considers warn_type and severity *) + + let hash {warn_type; severity; loc; text; context; print_loc} = + 3 * Warning.hash warn_type + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + 13 * Severity.hash severity let with_context msg = function | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) | _ -> msg - let show {warn_type; certainty; severity; loc; text; context; print_loc} = + let show {warn_type; severity; loc; text; context; print_loc} = let text = match warn_type with | Debug -> "{BLUE}"^text (* TODO: don't do it like this *) | _ -> text in - let msg = "[" ^ Severity.show severity ^ "]" ^ (WarningWithCertainty.(show {warn_type; certainty}))^(if text != "" then " "^text else "") in + let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^(if text != "" then " "^text else "") in let msg = with_context msg context in msg end @@ -352,8 +323,7 @@ let print_group group_name errors = let warn_all m = if !GU.should_warn then ( - let wc = WarningWithCertainty.{warn_type = m.Message.warn_type; certainty = m.Message.certainty} in (* TODO: don't reconstruct this *) - if WarningWithCertainty.should_warn wc && not (MH.mem messages_table m) then ( + if Warning.should_warn m.Message.warn_type && not (MH.mem messages_table m) then ( print_msg (Message.show m) m.print_loc; MH.replace messages_table m (); messages_list := m :: !messages_list @@ -362,28 +332,28 @@ let warn_all m = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let warn_internal ?msg:(msg="") (warning: WarningWithCertainty.t) = - warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Warning; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} +let warn_internal ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity = Warning; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} -let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = - warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Warning; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity = Warning; loc = Some loc; text = msg; context = !current_context; print_loc = loc} let warn ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal ~msg:msg (WarningWithCertainty.create warning) + warn_internal ~msg:msg warning let warn_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create warning) + warn_internal_with_loc ?loc ~msg:msg warning -let error_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: WarningWithCertainty.t) = - warn_all {warn_type = warning.warn_type; certainty = warning.certainty; severity = Error; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let error_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity = Error; loc = Some loc; text = msg; context = !current_context; print_loc = loc} let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - error_internal_with_loc ?loc ~msg:msg (WarningWithCertainty.create ~must:true warning) + error_internal_with_loc ?loc ~msg:msg warning let debug msg = - warn_internal ~msg @@ WarningWithCertainty.debug () (* TODO: debug severity *) + warn_internal ~msg @@ Debug (* TODO: debug severity *) let debug_each msg = - warn_internal_with_loc ~msg @@ WarningWithCertainty.debug () (* TODO: debug severity *) + warn_internal_with_loc ~msg @@ Debug (* TODO: debug severity *) include Tracing From b2de8d912a721397bc6b8cf4176f1718eed62427 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:23:16 +0300 Subject: [PATCH 24/95] Remove Debug warning type which is now covered by Debug severity instead --- src/analyses/base.ml | 2 +- src/util/defaults.ml | 1 - src/util/messages.ml | 12 ++---------- 3 files changed, 3 insertions(+), 12 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3f6617f595..d95de483b4 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -832,7 +832,7 @@ struct | `Int i -> i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | `Bot -> Queries.ID.bot () (* TODO: remove? *) (* | v -> M.warn ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) - | v -> M.warn ~warning:M.Debug ~msg:("Query function answered " ^ (VD.show v)) (); Queries.ID.bot () + | v -> M.debug ("Query function answered " ^ (VD.show v)); Queries.ID.bot () in if M.tracing then M.traceu "evalint" "base query_evalint %a -> %a\n" d_exp e Queries.ID.pretty r; r diff --git a/src/util/defaults.ml b/src/util/defaults.ml index 9f275b91c2..ef0c43f009 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -244,7 +244,6 @@ let _ = () ; reg Warnings "warn.race" "true" "Race warnings" ; reg Warnings "warn.array" "true" "Array (Out_of_bounds of int*int) warnings" ; reg Warnings "warn.unknown" "true" "Unknown (of string) warnings" - (* ; reg Warnings "warn.debug" "true" "Debug (of string) warnings" *) ; reg Warnings "warn.error" "true" "Error severity messages" ; reg Warnings "warn.warning" "true" "Warning severity messages" ; reg Warnings "warn.info" "true" "Info severity messages" diff --git a/src/util/messages.ml b/src/util/messages.ml index 6108f18329..e504a80645 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -31,7 +31,6 @@ type warning = | Race | Cast of cast | Unknown - | Debug | Analyzer [@@deriving eq] @@ -165,7 +164,6 @@ struct | Race -> "race" | Cast _ -> "cast" | Unknown -> "unknown" - | Debug -> "debug" | Analyzer -> "analyzer" in get_bool ("warn." ^ (to_string e)) @@ -176,7 +174,6 @@ struct | Race -> "[Race]" | Cast x -> "[Cast > " ^ (Cast.show x) | Unknown -> "[Unknown]" - | Debug -> "[Debug]" | Analyzer -> "[Analyzer]" let from_string_list (s: string list) = @@ -187,7 +184,6 @@ struct | "integer" -> Integer.from_string_list t | "race" -> Race | "cast" -> Cast.from_string_list t - | "debug" -> Debug | "analyzer" -> Analyzer | _ -> Unknown end @@ -235,10 +231,6 @@ struct | _ -> msg let show {warn_type; severity; loc; text; context; print_loc} = - let text = match warn_type with - | Debug -> "{BLUE}"^text (* TODO: don't do it like this *) - | _ -> text - in let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^(if text != "" then " "^text else "") in let msg = with_context msg context in msg @@ -351,9 +343,9 @@ let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = error_internal_with_loc ?loc ~msg:msg warning let debug msg = - warn_internal ~msg @@ Debug (* TODO: debug severity *) + warn_internal ~msg @@ Unknown (* TODO: debug severity *) let debug_each msg = - warn_internal_with_loc ~msg @@ Debug (* TODO: debug severity *) + warn_internal_with_loc ~msg @@ Unknown (* TODO: debug severity *) include Tracing From 757a7b9dd56f2ab77e166d0948e298ac54ab1f1d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:25:01 +0300 Subject: [PATCH 25/95] Use Debug severity for Messages.debug --- src/util/messages.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index e504a80645..78d3c3412f 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -342,10 +342,16 @@ let error_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warn let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = error_internal_with_loc ?loc ~msg:msg warning +let debug_internal ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity = Debug; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} + +let debug_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity = Debug; loc = Some loc; text = msg; context = !current_context; print_loc = loc} + let debug msg = - warn_internal ~msg @@ Unknown (* TODO: debug severity *) + debug_internal ~msg @@ Unknown let debug_each msg = - warn_internal_with_loc ~msg @@ Unknown (* TODO: debug severity *) + debug_internal_with_loc ~msg @@ Unknown include Tracing From db214e5415749eca5865844f8f3632a05fce1cb1 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:28:59 +0300 Subject: [PATCH 26/95] Add should_warn to Message --- src/util/messages.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 78d3c3412f..8d929cb150 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -221,7 +221,8 @@ struct print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq] - (* TODO: add should_warn that considers warn_type and severity *) + let should_warn {warn_type; severity; _} = + Warning.should_warn warn_type && Severity.should_warn severity let hash {warn_type; severity; loc; text; context; print_loc} = 3 * Warning.hash warn_type + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + 13 * Severity.hash severity @@ -315,7 +316,7 @@ let print_group group_name errors = let warn_all m = if !GU.should_warn then ( - if Warning.should_warn m.Message.warn_type && not (MH.mem messages_table m) then ( + if Message.should_warn m && not (MH.mem messages_table m) then ( print_msg (Message.show m) m.print_loc; MH.replace messages_table m (); messages_list := m :: !messages_list From 3f1911e2bda20ec4c9b899e19145086a7deedf0e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:33:09 +0300 Subject: [PATCH 27/95] Deduplicate Messages internal functions --- src/util/messages.ml | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 8d929cb150..f526b69006 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -325,11 +325,14 @@ let warn_all m = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let warn_internal ?msg:(msg="") (warning: Warning.t) = - warn_all {warn_type = warning; severity = Warning; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} +let msg_internal severity ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} -let warn_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = - warn_all {warn_type = warning; severity = Warning; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = + warn_all {warn_type = warning; severity; loc = Some loc; text = msg; context = !current_context; print_loc = loc} + +let warn_internal = msg_internal Warning +let warn_internal_with_loc = msg_internal_with_loc Warning let warn ?msg:(msg="") ?warning:(warning=Unknown) () = warn_internal ~msg:msg warning @@ -337,17 +340,13 @@ let warn ?msg:(msg="") ?warning:(warning=Unknown) () = let warn_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = warn_internal_with_loc ?loc ~msg:msg warning -let error_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = - warn_all {warn_type = warning; severity = Error; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let error_internal_with_loc = msg_internal_with_loc Error let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = error_internal_with_loc ?loc ~msg:msg warning -let debug_internal ?msg:(msg="") (warning: Warning.t) = - warn_all {warn_type = warning; severity = Debug; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} - -let debug_internal_with_loc ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = - warn_all {warn_type = warning; severity = Debug; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let debug_internal = msg_internal Debug +let debug_internal_with_loc = msg_internal_with_loc Debug let debug msg = debug_internal ~msg @@ Unknown From e8cd360f420d4104e93f7d299c379038c5ba57f5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:45:12 +0300 Subject: [PATCH 28/95] Make warning message text mandatory --- src/analyses/base.ml | 4 ++-- src/cdomains/arrayDomain.ml | 10 +++++----- src/util/messages.ml | 16 ++++++++-------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index d95de483b4..0f424c799c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -803,9 +803,9 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) () + then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ~msg:"Must dereference NULL pointer" () else if AD.may_be_null adr - then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ()); + then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ~msg:"May dereference NULL pointer" ()); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 494f629082..87b0a5ef7e 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,15 +575,15 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) ~msg:"Must access array past end" () | Some true, None -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) ~msg:"May access array past end" () | Some false, Some true -> - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) ~msg:"Must access array before start" () | None, Some true -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) ~msg:"May access array before start" () | _ -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.unknown ()) () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.unknown ()) ~msg:"May access array out of bounds" () else () diff --git a/src/util/messages.ml b/src/util/messages.ml index f526b69006..ede0f6c6bd 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -325,25 +325,25 @@ let warn_all m = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg_internal severity ?msg:(msg="") (warning: Warning.t) = +let msg_internal severity ~msg (warning: Warning.t) = warn_all {warn_type = warning; severity; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} -let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ?msg:(msg="") (warning: Warning.t) = +let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ~msg (warning: Warning.t) = warn_all {warn_type = warning; severity; loc = Some loc; text = msg; context = !current_context; print_loc = loc} let warn_internal = msg_internal Warning let warn_internal_with_loc = msg_internal_with_loc Warning -let warn ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal ~msg:msg warning +let warn ~msg ?warning:(warning=Unknown) () = + warn_internal ~msg warning -let warn_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - warn_internal_with_loc ?loc ~msg:msg warning +let warn_each ?loc ~msg ?warning:(warning=Unknown) () = + warn_internal_with_loc ?loc ~msg warning let error_internal_with_loc = msg_internal_with_loc Error -let error_each ?loc ?msg:(msg="") ?warning:(warning=Unknown) () = - error_internal_with_loc ?loc ~msg:msg warning +let error_each ?loc ~msg ?warning:(warning=Unknown) () = + error_internal_with_loc ?loc ~msg warning let debug_internal = msg_internal Debug let debug_internal_with_loc = msg_internal_with_loc Debug From 2d4ebccb602b819e1ee774312e4a276bb216a091 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 11:59:32 +0300 Subject: [PATCH 29/95] Remove unit argument from warning --- src/analyses/base.ml | 46 +++++++++++++++++------------------ src/analyses/commonPriv.ml | 2 +- src/analyses/contain.ml | 4 +-- src/analyses/deadlock.ml | 6 ++--- src/analyses/malloc_null.ml | 2 +- src/analyses/mayLocks.ml | 2 +- src/analyses/mutexAnalysis.ml | 2 +- src/analyses/osek.ml | 2 +- src/analyses/region.ml | 2 +- src/analyses/spec.ml | 4 +-- src/analyses/symbLocks.ml | 4 +-- src/analyses/uninit.ml | 8 +++--- src/cdomains/arrayDomain.ml | 10 ++++---- src/cdomains/containDomain.ml | 10 ++++---- src/cdomains/intDomain.ml | 4 +-- src/cdomains/lvalMapDomain.ml | 4 +-- src/cdomains/regionDomain.ml | 2 +- src/cdomains/shapeDomain.ml | 2 +- src/cdomains/valueDomain.ml | 32 ++++++++++++------------ src/framework/analyses.ml | 2 +- src/framework/constraints.ml | 6 ++--- src/framework/control.ml | 2 +- src/util/cilfacade.ml | 2 +- src/util/messages.ml | 6 ++--- 24 files changed, 83 insertions(+), 83 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 0f424c799c..b28fb1a7c7 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -343,12 +343,12 @@ struct let get_ptrs (vals: value list): address list = let f x acc = match x with | `Address adrs when AD.is_top adrs -> - M.warn_each ~msg:"Unknown address given as function argument" (); acc + M.warn_each "Unknown address given as function argument"; acc | `Address adrs when AD.to_var_may adrs = [] -> acc | `Address adrs -> let typ = AD.get_type adrs in if isFunctionType typ then acc else adrs :: acc - | `Top -> M.warn_each ~msg:"Unknown value type given as function argument" (); acc + | `Top -> M.warn_each "Unknown value type given as function argument"; acc | _ -> acc in List.fold_right f vals [] @@ -359,11 +359,11 @@ struct match value with | `Top -> let warning = "Unknown value in " ^ description ^ " could be an escaped pointer address!" in - if VD.is_immediate_type t then () else M.warn_each ~msg:warning (); empty + if VD.is_immediate_type t then () else M.warn_each warning; empty | `Bot -> (*M.debug "A bottom value when computing reachable addresses!";*) empty | `Address adrs when AD.is_top adrs -> let warning = "Unknown address in " ^ description ^ " has escaped." in - M.warn_each ~msg:warning (); AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) + M.warn_each warning; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) (* The main thing is to track where pointers go: *) | `Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) @@ -678,7 +678,7 @@ struct if contains_vla t || contains_vla (get_type_addr a) then begin (* TODO: Is this ok? *) - M.warn ~msg:"Casting involving a VLA is assumed to work" (); + M.warn "Casting involving a VLA is assumed to work"; true end else @@ -803,9 +803,9 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ~msg:"Must dereference NULL pointer" () + then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) "Must dereference NULL pointer" else if AD.may_be_null adr - then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) ~msg:"May dereference NULL pointer" ()); + then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) "May dereference NULL pointer"); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in @@ -856,12 +856,12 @@ struct try let fp = eval_fv (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in if AD.mem Addr.UnknownPtr fp then begin - M.warn_each ~msg:("Function pointer " ^ sprint d_exp fval ^ " may contain unknown functions.") (); + M.warn_each ("Function pointer " ^ sprint d_exp fval ^ " may contain unknown functions."); dummyFunDec.svar :: AD.to_var_may fp end else AD.to_var_may fp with SetDomain.Unsupported _ -> - M.warn_each ~msg:("Unknown call to function " ^ sprint d_exp fval ^ ".") (); + M.warn_each ("Unknown call to function " ^ sprint d_exp fval ^ "."); [dummyFunDec.svar] (* interpreter end *) @@ -1069,7 +1069,7 @@ struct with Cilfacade.TypeOfError _ -> (* If we cannot determine the correct type here, we go with the one of the LVal *) (* This will usually lead to a type mismatch in the ValueDomain (and hence supertop) *) - M.warn ~msg:("Cilfacade.typeOfLval failed Could not obtain the type of "^ sprint d_lval (Var x, cil_offset)) (); + M.warn ("Cilfacade.typeOfLval failed Could not obtain the type of "^ sprint d_lval (Var x, cil_offset)); lval_type in let update_offset old_value = @@ -1184,7 +1184,7 @@ struct (* If any of the addresses are unknown, we ignore it!?! *) | SetDomain.Unsupported x -> (* if M.tracing then M.tracel "setosek" ~var:firstvar "set got an exception '%s'\n" x; *) - M.warn_each ~msg:"Assignment to unknown address" (); st + M.warn_each "Assignment to unknown address"; st let set_many ?ctx a (gs:glob_fun) (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) @@ -1382,7 +1382,7 @@ struct else set a gs st addr t_lval new_val ~invariant:true ~ctx:(Some ctx) (* no *_raw because this is not a real assignment *) | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; - M.warn_each ~msg:("Invariant failed: expression \"" ^ sprint d_plainexp exp ^ "\" not understood.") (); + M.warn_each ("Invariant failed: expression \"" ^ sprint d_plainexp exp ^ "\" not understood."); st let invariant ctx a gs st exp tv: store = @@ -1395,7 +1395,7 @@ struct let inv_bin_int (a, b) ikind c op = let warn_and_top_on_zero x = if GU.opt_predicate (BI.equal BI.zero) (ID.to_int x) then - (M.warn ~msg:"Must Undefined Behavior: Second argument of div or mod is 0, continuing with top" (); + (M.warn "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; ID.top_of ikind) else x @@ -1777,7 +1777,7 @@ struct | None -> nst | Some exp -> let t_override = match Cilfacade.fundec_return_type fundec with - | TVoid _ -> M.warn ~msg:"Returning a value from a void function" (); assert false + | TVoid _ -> M.warn "Returning a value from a void function"; assert false | ret -> ret in (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1814,7 +1814,7 @@ struct let invalidate ?ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; - if exps <> [] then M.warn_each ~msg:("Invalidating expressions: " ^ sprint (d_list ", " d_plainexp) exps) (); + if exps <> [] then M.warn_each ("Invalidating expressions: " ^ sprint (d_list ", " d_plainexp) exps); (* To invalidate a single address, we create a pair with its corresponding * top value. *) let invalidate_address st a = @@ -1899,7 +1899,7 @@ struct in Some (lval, v, args) else ( - M.warn_each ~msg:("Not creating a thread from " ^ v.vname ^ " because its type is " ^ sprint d_type v.vtype) (); + M.warn_each ("Not creating a thread from " ^ v.vname ^ " because its type is " ^ sprint d_type v.vtype); None ) in @@ -1928,7 +1928,7 @@ struct in let flist = collect_funargs (Analyses.ask_of_ctx ctx) ctx.global ctx.local args in let addrs = List.concat (List.map AD.to_var_may flist) in - if addrs <> [] then M.warn_each ~msg:("Spawning functions from unknown function: " ^ sprint (d_list ", " d_varinfo) addrs) (); + if addrs <> [] then M.warn_each ("Spawning functions from unknown function: " ^ sprint (d_list ", " d_varinfo) addrs); List.filter_map (create_thread None None) addrs end | _ -> [] @@ -1958,10 +1958,10 @@ struct (* Expressions with logical connectives like a && b are calculated in temporary variables by CIL. Instead of the original expression, we then see something like tmp___0. So we replace expr in msg by the original source if this is the case. *) let assert_expr = if string_match (regexp ".*assert(\\(.+\\));.*") line 0 then matched_group 1 line else expr in let msg = if expr <> assert_expr then String.nreplace msg expr assert_expr else msg in - M.warn_each ~msg:(msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) () + M.warn_each (msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) ) ) else - M.warn_each ~msg:msg () + M.warn_each msg in match check_assert e ctx.local with | `Lifted false -> @@ -1971,7 +1971,7 @@ struct warn ("{green}Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.warn_each ~msg:("{red}Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)") (); + M.warn_each ("{red}Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> warn ~annot:"UNKNOWN" ("{yellow}Assertion \"" ^ expr ^ "\" is unknown."); @@ -1984,11 +1984,11 @@ struct end let special_unknown_invalidate ctx ask gs st f args = - (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn_each ~msg:("Function definition missing for " ^ f.vname) ()); - (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn_each ~msg:"Unknown function ptr called" ()); + (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn_each ("Function definition missing for " ^ f.vname)); + (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn_each "Unknown function ptr called"); let addrs = if get_bool "sem.unknown_function.invalidate.globals" then ( - M.warn_each ~msg:"INVALIDATING ALL GLOBALS!" (); + M.warn_each "INVALIDATING ALL GLOBALS!"; foldGlobals !Cilfacade.current_file (fun acc global -> match global with | GVar (vi, _, _) when not (is_static vi) -> diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 2aff2fde60..82ec6d34fa 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -34,7 +34,7 @@ struct let mutex_addr_to_varinfo = function | LockDomain.Addr.Addr (v, `NoOffset) -> v | LockDomain.Addr.Addr (v, offs) -> - M.warn_each ~msg:(Pretty.sprint ~width:800 @@ Pretty.dprintf "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs) (); + M.warn_each (Pretty.sprint ~width:800 @@ Pretty.dprintf "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs); v | _ -> failwith "MutexGlobalsBase.mutex_addr_to_varinfo" end diff --git a/src/analyses/contain.ml b/src/analyses/contain.ml index f1ae86c19c..804741c0b8 100644 --- a/src/analyses/contain.ml +++ b/src/analyses/contain.ml @@ -100,7 +100,7 @@ struct | [] -> () | f :: _ -> try - Messages.warn_each ~msg:"Problems for safe objects from SAFE.json are suppressed!" (); + Messages.warn_each "Problems for safe objects from SAFE.json are suppressed!"; let safe_tbl = objekt (JsonParser.value JsonLexer.token (Lexing.from_channel (open_in f))) in Object.iter (add_htbl_re D.safe_vars) !(objekt !(field safe_tbl "variables")); Object.iter (add_htbl_re D.safe_methods) !(objekt !(field safe_tbl "methods")); @@ -521,7 +521,7 @@ struct let fns = D.get_fptr_items ctx.global in let add_svar x y = match ContainDomain.FuncName.from_fun_name x with - | Some x -> Messages.warn_each ~msg:("fptr check: "^x.vname ) ();(x)::y + | Some x -> Messages.warn_each ("fptr check: "^x.vname );(x)::y | _ -> y in ContainDomain.VarNameSet.fold (fun x y -> add_svar x y) fns [] diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index 292bea6783..d1768aa7ea 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -29,9 +29,9 @@ struct D.iter (fun e -> List.iter (fun (a,b) -> if ((MyLock.equal a e) && (MyLock.equal b newLock)) then ( let msg = (sprintf "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show e.addr) (ValueDomain.Addr.show newLock.addr) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc) (CilType.Location.show b.loc) (CilType.Location.show a.loc)) in - Messages.warn_each ~msg:msg (); + Messages.warn_each msg; let msg = (sprintf "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show newLock.addr) (ValueDomain.Addr.show e.addr) (CilType.Location.show b.loc) (CilType.Location.show a.loc) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc)) in - Messages.warn_each ~loc:a.loc ~msg:msg (); + Messages.warn_each ~loc:a.loc msg; ) else () ) !forbiddenList ) lockList; @@ -97,7 +97,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn ~msg:("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'.") (); [] + | b -> Messages.warn ("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'."); [] (* Called when calling a special/unknown function *) let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index 4b9296edfe..4f8d45acfa 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -47,7 +47,7 @@ struct if D.exists (fun x -> List.exists (fun x -> is_prefix_of x v) (Addr.to_var_offset x)) st then let var = Addr.from_var_offset v in - Messages.warn_each ~msg:("Possible dereferencing of null on variable '" ^ (Addr.show var) ^ "'.") ~warning:(Messages.Warning.Behavior.Undefined.nullpointer_dereference ()) () + Messages.warn_each ("Possible dereferencing of null on variable '" ^ (Addr.show var) ^ "'.") ~warning:(Messages.Warning.Behavior.Undefined.nullpointer_dereference ()) with SetDomain.Unsupported _ -> () (* Warn null-lval dereferences, but not normal (null-) lvals*) diff --git a/src/analyses/mayLocks.ml b/src/analyses/mayLocks.ml index 6cf6e07221..32921f4b8c 100644 --- a/src/analyses/mayLocks.ml +++ b/src/analyses/mayLocks.ml @@ -34,7 +34,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn ~msg:("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'.") (); [] + | b -> Messages.warn ("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'."); [] (* locking logic -- add all locks we can add *) let lock ctx rw may_fail return_value_on_success a lv arglist ls : D.ReverseAddrSet.t = diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index 450fa9c98c..b0113d5db6 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -148,7 +148,7 @@ struct let ls = Lockset.filter snd ctx.local in let el = P.effect_fun ~write:w ls in ctx.sideg v el - | None -> M.warn ~msg:"Write to unknown address: privatization is unsound." () + | None -> M.warn "Write to unknown address: privatization is unsound." end; (*partitions & locks*) diff --git a/src/analyses/osek.ml b/src/analyses/osek.ml index b5d9b44ae4..1378d673e3 100644 --- a/src/analyses/osek.ml +++ b/src/analyses/osek.ml @@ -485,7 +485,7 @@ struct let unknown_access () = (*M.warn_each ~msg:"unknown access 'with lockset:'" ();*) - Messages.warn_each ~msg:"Access to unknown address could be global" () + Messages.warn_each "Access to unknown address could be global" (* All else must have failed --- making a last ditch effort to generate type invariant if that fails then give up and become unsound. *) diff --git a/src/analyses/region.ml b/src/analyses/region.ml index 9f5eb1dbfc..ebbd1ffa64 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -27,7 +27,7 @@ struct let ev = Reg.eval_exp exp in let to_exp (v,f) = (v,Lval.Fields.to_offs' f) in List.map to_exp (Reg.related_globals ev (part,reg)) - | `Top -> Messages.warn ~msg:"Region state is broken :(" (); [] + | `Top -> Messages.warn "Region state is broken :("; [] | `Bot -> [] let is_bullet exp part st : bool = diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml index dddb8d9b67..2b60f3d936 100644 --- a/src/analyses/spec.ml +++ b/src/analyses/spec.ml @@ -82,7 +82,7 @@ struct | b -> (match Queries.ID.to_int b with Some b -> (Int64.of_int a)=(IntOps.BigIntOps.to_int64 b) | None -> false) ) | `Float a, Const(CReal (b, fkind, str_opt)) -> a=b - | `Float a, _ -> M.warn_each ~msg:"EQUAL Float: unsupported!" (); false + | `Float a, _ -> M.warn_each "EQUAL Float: unsupported!"; false (* arg is a key. currently there can only be one key per constraint, so we already used it for lookup. TODO multiple keys? *) | `Var a, b -> true (* arg is a identifier we use for matching constraints. TODO save in domain *) @@ -90,7 +90,7 @@ struct | `Error s, b -> failwith @@ "Spec error: "^s (* wildcard matches anything *) | `Free, b -> true - | a,b -> M.warn_each ~msg:"EQUAL? Unmatched case - assume true..." (); true + | a,b -> M.warn_each "EQUAL? Unmatched case - assume true..."; true let check_constraint ctx get_key matches m new_a old_key (a,ws,fwd,b,c as edge) = (* If we have come to a wildcard, we match it instantly, but since there is no way of determining a key diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index adcf066779..7f578fb273 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -82,7 +82,7 @@ struct | `Unlock -> D.remove (Analyses.ask_of_ctx ctx) (List.hd arglist) ctx.local | `Unknown fn when VarEq.safe_fn fn -> - Messages.warn ~msg:("Assume that "^fn^" does not change lockset.") (); + Messages.warn ("Assume that "^fn^" does not change lockset."); ctx.local | `Unknown x -> begin let st = @@ -175,7 +175,7 @@ struct let lock = ValueDomain.Addr.from_var_offset (v, conv_const_offset o) in LSSet.add ("i-lock",ValueDomain.Addr.show lock) xs | _ -> - Messages.warn ~msg:"Internal error: found a strange lockstep pattern." (); + Messages.warn "Internal error: found a strange lockstep pattern."; xs in let do_perel e xs = diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index 11f4da297a..cf6e6b3f57 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -46,7 +46,7 @@ struct let to_extra (v,o) xs = (v, Base.Offs.from_offset (conv_offset o), write) :: xs in Queries.LS.fold to_extra a [] | _ -> - M.warn ~msg:"Access to unknown address could be global" (); [] + M.warn "Access to unknown address could be global"; [] let rec access_one_byval a rw (exp:exp) = match exp with @@ -123,7 +123,7 @@ struct List.exists (is_prefix_of a) (Addr.to_var_offset addr) in if D.exists f st then begin - Messages.warn_each ~msg:("Uninitialized variable " ^ (Addr.show (Addr.from_var_offset a)) ^ " accessed.") (); + Messages.warn_each ("Uninitialized variable " ^ (Addr.show (Addr.from_var_offset a)) ^ " accessed."); false end else t in @@ -162,7 +162,7 @@ struct | x::xs, y::ys -> [] (* found a mismatch *) | _ -> - M.warn ~msg:("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx))) ^ " -- did not find " ^ tf.fname) (); + M.warn ("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx))) ^ " -- did not find " ^ tf.fname); [] in let utar, uoth = unrollType target, unrollType other in @@ -190,7 +190,7 @@ struct (* step into all other fields *) List.concat (List.rev_map (fun oth_f -> get_pfx v (`Field (oth_f, cx)) ofs utar oth_f.ftype) c2.cfields) | _ -> - M.warn ~msg:("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx)))) (); + M.warn ("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx)))); [] diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 87b0a5ef7e..0d0a1d8295 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,15 +575,15 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) ~msg:"Must access array past end" () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "Must access array past end" | Some true, None -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) ~msg:"May access array past end" () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "May access array past end" | Some false, Some true -> - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) ~msg:"Must access array before start" () + M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "Must access array before start" | None, Some true -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) ~msg:"May access array before start" () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "May access array before start" | _ -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.unknown ()) ~msg:"May access array out of bounds" () + M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.unknown ()) "May access array out of bounds" else () diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 01494fd21e..6f42358617 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -41,7 +41,7 @@ let report x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~msg:("CW: "^x) () + Messages.warn_each ("CW: "^x) module FieldVars = struct @@ -173,7 +173,7 @@ struct let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && (!Goblintutil.in_verifying_stage|| !final) then (*filter noise*) - Messages.warn_each ~msg:("CW: "^x) () + Messages.warn_each ("CW: "^x) module Danger = struct @@ -256,13 +256,13 @@ struct if enable_dbg && loc.line>=dbg_line_start && loc.line<=dbg_line_end then (*counter := !counter + 1;*) if not (loc.file ="LLVM INTERNAL") || not (loc.line=1) then (*filter noise*) - Messages.warn_each ~msg:((*(string_of_int !counter)^*)"CW: "^x) () + Messages.warn_each ((*(string_of_int !counter)^*)"CW: "^x) let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~warning:Messages.Analyzer ~msg:("CW: "^x) () (* TODO: used to call report_error, add error severity *) + Messages.warn_each ~warning:Messages.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar @@ -1332,7 +1332,7 @@ struct let assign_argmap fs lval exp (fd, st, df) must_assign glob = (*keep track of used fun args*) match used_args st exp with | s when ArgSet.is_top s -> - Messages.warn ~msg:("Expression "^(sprint 160 (d_exp () exp))^" too complicated.") (); + Messages.warn ("Expression "^(sprint 160 (d_exp () exp))^" too complicated."); fd, st, df | s when ArgSet.is_bot s -> let vars= get_vars exp in let s = List.fold_left (fun y x->if not (is_safe_name x.vname) then begin ArgSet.add (FieldVars.gen x) y end else y) (ArgSet.empty()) vars in diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index fa56b68113..3229ea1d2d 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -1296,7 +1296,7 @@ struct v ) else if should_ignore_overflow ik then ( - M.warn ~warning:(M.Warning.Integer.overflow ()) ~msg:"DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot" (); + M.warn ~warning:(M.Warning.Integer.overflow ()) "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; `Bot ) else ( @@ -2718,7 +2718,7 @@ module IntDomTupleImpl = struct let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in if n = 1 then Some (List.hd xs) else ( - if n>1 then Messages.warn_each ~msg:("Inconsistent state! "^String.concat "," @@ List.map show us) (); (* do not want to abort, but we need some unsound category *) + if n>1 then Messages.warn_each ("Inconsistent state! "^String.concat "," @@ List.map show us); (* do not want to abort, but we need some unsound category *) None ) let to_int = same BI.to_string % mapp2 { fp2 = fun (type a) (module I:S with type t = a and type int_t = int_t) -> I.to_int } diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index 079f849e24..b0a9c48a43 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -252,10 +252,10 @@ struct let warn ?may:(may=false) ?loc:(loc=[!Tracing.current_loc]) msg = match msg |> Str.split (Str.regexp "[ \n\r\x0c\t]+") with - | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~msg:msg () + | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) msg | h :: t -> let warn_type = Messages.Warning.from_string_list (h |> Str.split (Str.regexp "[.]")) - in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~msg:(String.concat " " t) ~warning:warn_type () + in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~warning:warn_type (String.concat " " t) (* getting keys from Cil Lvals *) let sprint f x = Pretty.sprint 80 (f () x) diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index 91d17af91d..a8480ef301 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -256,7 +256,7 @@ struct List.map (add_o os) (RS.to_vf_list vfd_class) | Some (false, vfd, os) -> if is_global vfd then [vfd] else [] - | None -> Messages.warn ~msg:"Access to unknown address could be global" (); [] + | None -> Messages.warn "Access to unknown address could be global"; [] end (* TODO: remove Lift *) diff --git a/src/cdomains/shapeDomain.ml b/src/cdomains/shapeDomain.ml index 9c19b6851f..2735978d91 100644 --- a/src/cdomains/shapeDomain.ml +++ b/src/cdomains/shapeDomain.ml @@ -180,7 +180,7 @@ let eval_lp ask (e:exp) : lexp option = | _ -> None -let warn_todo s = Messages.warn ~msg:("NotImplemented exception! "^s) () +let warn_todo s = Messages.warn ("NotImplemented exception! "^s) let alias_top lp = SHMap.remove lp diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index fa35dd2dd0..c51e7a982e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -324,7 +324,7 @@ struct a (* probably garbage, but this is deref's problem *) (*raise (CastError s)*) | SizeOfError (s,t) -> - M.warn_each ~msg:("size of error: " ^ s) (); + M.warn_each ("size of error: " ^ s); a end | x -> x (* TODO we should also keep track of the type here *) @@ -442,7 +442,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.join AD.null_ptr y @@ -469,7 +469,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.join AD.null_ptr y @@ -497,7 +497,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.widen AD.null_ptr y @@ -562,7 +562,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each ~msg:m (); `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.widen AD.null_ptr y @@ -764,14 +764,14 @@ struct (*hack for lists*) begin match f ad with | `List l -> `Address (Lists.entry_rand l) - | _ -> M.warn ~msg:"Trying to read a field, but was not given a struct" (); top () + | _ -> M.warn "Trying to read a field, but was not given a struct"; top () end | `Struct str -> let x = Structs.get str fld in let l', o' = shift_one_over l o in do_eval_offset ask f x offs exp l' o' v t | `Top -> M.debug "Trying to read a field, but the struct is unknown"; top () - | _ -> M.warn ~msg:"Trying to read a field, but was not given a struct" (); top () + | _ -> M.warn "Trying to read a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin match x with @@ -781,7 +781,7 @@ struct do_eval_offset ask f x offs exp l' o' v t | `Union (_, valu) -> top () | `Top -> M.debug "Trying to read a field, but the union is unknown"; top () - | _ -> M.warn ~msg:"Trying to read a field, but was not given a union" (); top () + | _ -> M.warn "Trying to read a field, but was not given a union"; top () end | `Index (idx, offs) -> begin let l', o' = shift_one_over l o in @@ -795,7 +795,7 @@ struct end | x when Goblintutil.opt_predicate (BI.equal (BI.zero)) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t | `Top -> M.debug "Trying to read an index, but the array is unknown"; top () - | _ -> M.warn ~msg:("Trying to read an index, but was not given an array ("^show x^")") (); top () + | _ -> M.warn ("Trying to read an index, but was not given an array ("^show x^")"); top () end in let l, o = match exp with @@ -856,8 +856,8 @@ struct let strc = init_comp fld.fcomp in let l', o' = shift_one_over l o in `Struct (Structs.replace strc fld (do_update_offset ask `Bot offs value exp l' o' v t)) - | `Top -> M.warn ~msg:"Trying to update a field, but the struct is unknown" (); top () - | _ -> M.warn ~msg:"Trying to update a field, but was not given a struct" (); top () + | `Top -> M.warn "Trying to update a field, but the struct is unknown"; top () + | _ -> M.warn "Trying to update a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin let t = fld.ftype in @@ -885,14 +885,14 @@ struct | `Index (idx, _) when IndexDomain.equal idx (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero) -> (* Why does cil index unions? We'll just pick the first field. *) top (), `Field (List.nth fld.fcomp.cfields 0,`NoOffset) - | _ -> M.warn_each ~msg:"Why are you indexing on a union? Normal people give a field name." (); + | _ -> M.warn_each "Why are you indexing on a union? Normal people give a field name."; top (), offs end in `Union (`Lifted fld, do_update_offset ask tempval tempoffs value exp l' o' v t) | `Bot -> `Union (`Lifted fld, do_update_offset ask `Bot offs value exp l' o' v t) - | `Top -> M.warn ~msg:"Trying to update a field, but the union is unknown" (); top () - | _ -> M.warn_each ~msg:"Trying to update a field, but was not given a union" (); top () + | `Top -> M.warn "Trying to update a field, but the union is unknown"; top () + | _ -> M.warn_each "Trying to update a field, but was not given a union"; top () end | `Index (idx, offs) -> begin let l', o' = shift_one_over l o in @@ -914,9 +914,9 @@ struct let new_value_at_index = do_update_offset ask `Bot offs value exp l' o' v t in let new_array_value = CArrays.set ask x' (e, idx) new_value_at_index in `Array new_array_value - | `Top -> M.warn ~msg:"Trying to update an index, but the array is unknown" (); top () + | `Top -> M.warn "Trying to update an index, but the array is unknown"; top () | x when Goblintutil.opt_predicate (BI.equal BI.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t - | _ -> M.warn_each ~msg:("Trying to update an index, but was not given an array("^show x^")") (); top () + | _ -> M.warn_each ("Trying to update an index, but was not given an array("^show x^")"); top () end in mu result in diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index cb8d8f4a7d..605a0aeb9b 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -481,7 +481,7 @@ struct let vdecl ctx _ = ctx.local let asm x = - ignore (M.warn ~msg:"ASM statement ignored." ()); + ignore (M.warn "ASM statement ignored."); x.local (* Just ignore. *) let skip x = x.local (* Just ignore. *) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index ae8b2a5b1c..272367c32d 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -562,7 +562,7 @@ struct ignore (getl (Function fd, c)) | exception Not_found -> (* unknown function *) - M.warn_each ~msg:("Created a thread from unknown function " ^ f.vname) () + M.warn_each ("Created a thread from unknown function " ^ f.vname) (* actual implementation (e.g. invalidation) is done by threadenter *) ) ds in @@ -695,7 +695,7 @@ struct let one_function f = match Cilfacade.find_varinfo_fundec f with | fd when LibraryFunctions.use_special f.vname -> - M.warn_each ~msg:("Using special for defined function " ^ f.vname) (); + M.warn_each ("Using special for defined function " ^ f.vname); tf_special_call ctx lv f args | fd -> tf_normal_call ctx lv e fd args getl sidel getg sideg @@ -750,7 +750,7 @@ struct let _ = current_node := Some u in M.current_context := Some (Obj.repr c); let d = try tf (v,c) (e,u) getl sidel getg sideg - with M.Bailure s -> Messages.warn_each ~msg:s (); (getl (u,c)) in + with M.Bailure s -> Messages.warn_each s; (getl (u,c)) in let _ = current_node := old_node in M.current_context := old_context; d diff --git a/src/framework/control.ml b/src/framework/control.ml index 18425c3815..b41b86a69b 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -167,7 +167,7 @@ struct (* If the function is not defined, and yet has been included to the * analysis result, we generate a warning. *) with Not_found -> - Messages.warn ~msg:("Calculated state for undefined function: unexpected node "^Ana.sprint Node.pretty_plain n) () + Messages.warn ("Calculated state for undefined function: unexpected node "^Ana.sprint Node.pretty_plain n) in LHT.iter add_local_var h; res diff --git a/src/util/cilfacade.ml b/src/util/cilfacade.ml index 19d3b04729..8e699ecdc6 100644 --- a/src/util/cilfacade.ml +++ b/src/util/cilfacade.ml @@ -239,7 +239,7 @@ let rec get_ikind t = | TEnum ({ekind = ik; _},_) -> ik | TPtr _ -> get_ikind !Cil.upointType | _ -> - Messages.warn_each ~msg:"Something that we expected to be an integer type has a different type, assuming it is an IInt" (); + Messages.warn_each "Something that we expected to be an integer type has a different type, assuming it is an IInt"; Cil.IInt let ptrdiff_ikind () = get_ikind !ptrdiffType diff --git a/src/util/messages.ml b/src/util/messages.ml index ede0f6c6bd..a5626e1da1 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -334,15 +334,15 @@ let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ~msg (warnin let warn_internal = msg_internal Warning let warn_internal_with_loc = msg_internal_with_loc Warning -let warn ~msg ?warning:(warning=Unknown) () = +let warn ?warning:(warning=Unknown) msg = warn_internal ~msg warning -let warn_each ?loc ~msg ?warning:(warning=Unknown) () = +let warn_each ?loc ?warning:(warning=Unknown) msg = warn_internal_with_loc ?loc ~msg warning let error_internal_with_loc = msg_internal_with_loc Error -let error_each ?loc ~msg ?warning:(warning=Unknown) () = +let error_each ?loc ?warning:(warning=Unknown) msg = error_internal_with_loc ?loc ~msg warning let debug_internal = msg_internal Debug From 7ee34cac0132d060c7b1b19297c3ac989cc1d336 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:07:14 +0300 Subject: [PATCH 30/95] Inline some internal Messages functions --- src/util/messages.ml | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index a5626e1da1..539f68c656 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -331,27 +331,20 @@ let msg_internal severity ~msg (warning: Warning.t) = let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ~msg (warning: Warning.t) = warn_all {warn_type = warning; severity; loc = Some loc; text = msg; context = !current_context; print_loc = loc} -let warn_internal = msg_internal Warning -let warn_internal_with_loc = msg_internal_with_loc Warning let warn ?warning:(warning=Unknown) msg = - warn_internal ~msg warning + msg_internal Warning ~msg warning let warn_each ?loc ?warning:(warning=Unknown) msg = - warn_internal_with_loc ?loc ~msg warning - -let error_internal_with_loc = msg_internal_with_loc Error + msg_internal_with_loc Warning ?loc ~msg warning let error_each ?loc ?warning:(warning=Unknown) msg = - error_internal_with_loc ?loc ~msg warning - -let debug_internal = msg_internal Debug -let debug_internal_with_loc = msg_internal_with_loc Debug + msg_internal_with_loc Error ?loc ~msg warning let debug msg = - debug_internal ~msg @@ Unknown + msg_internal Debug ~msg @@ Unknown let debug_each msg = - debug_internal_with_loc ~msg @@ Unknown + msg_internal_with_loc Debug ~msg @@ Unknown include Tracing From 6f24f29d88a8c676c3bc0285d1c62fc48664ea87 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:11:27 +0300 Subject: [PATCH 31/95] Generalize severity message functions further --- src/util/messages.ml | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 539f68c656..2e61bb4c89 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -332,19 +332,18 @@ let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ~msg (warnin warn_all {warn_type = warning; severity; loc = Some loc; text = msg; context = !current_context; print_loc = loc} -let warn ?warning:(warning=Unknown) msg = - msg_internal Warning ~msg warning - -let warn_each ?loc ?warning:(warning=Unknown) msg = - msg_internal_with_loc Warning ?loc ~msg warning - -let error_each ?loc ?warning:(warning=Unknown) msg = - msg_internal_with_loc Error ?loc ~msg warning - -let debug msg = - msg_internal Debug ~msg @@ Unknown - -let debug_each msg = - msg_internal_with_loc Debug ~msg @@ Unknown +let msg severity ?warning:(warning=Unknown) msg = + msg_internal severity ~msg warning + +let msg_each severity ?loc ?warning:(warning=Unknown) msg = + msg_internal_with_loc severity ?loc ~msg warning + +let warn = msg Warning +let warn_each = msg_each Warning +(* TODO: error? *) +let error_each = msg_each Error +(* TODO: info *) +let debug = msg Debug +let debug_each = msg_each Debug include Tracing From db4767393f814ad339ae7c99cfec641842b94847 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:16:09 +0300 Subject: [PATCH 32/95] Inline remaining internal Messages functions --- src/util/messages.ml | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 2e61bb4c89..1f597a42ec 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -325,18 +325,12 @@ let warn_all m = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg_internal severity ~msg (warning: Warning.t) = - warn_all {warn_type = warning; severity; loc = None; text = msg; context = !current_context; print_loc = !Tracing.current_loc} -let msg_internal_with_loc severity ?loc:(loc= !Tracing.current_loc) ~msg (warning: Warning.t) = - warn_all {warn_type = warning; severity; loc = Some loc; text = msg; context = !current_context; print_loc = loc} +let msg severity ?warning:(warning=Unknown) text = + warn_all {warn_type = warning; severity; loc = None; text; context = !current_context; print_loc = !Tracing.current_loc} - -let msg severity ?warning:(warning=Unknown) msg = - msg_internal severity ~msg warning - -let msg_each severity ?loc ?warning:(warning=Unknown) msg = - msg_internal_with_loc severity ?loc ~msg warning +let msg_each severity ?loc:(loc= !Tracing.current_loc) ?warning:(warning=Unknown) text = + warn_all {warn_type = warning; severity; loc = Some loc; text; context = !current_context; print_loc = loc} let warn = msg Warning let warn_each = msg_each Warning From 97b23292b437077888b9346bfbd0208ba79ea7e6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:19:43 +0300 Subject: [PATCH 33/95] Rename Messages.warn_all -> add --- src/util/messages.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 1f597a42ec..ff37245318 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -314,7 +314,7 @@ let print_group group_name errors = ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) -let warn_all m = +let add m = if !GU.should_warn then ( if Message.should_warn m && not (MH.mem messages_table m) then ( print_msg (Message.show m) m.print_loc; @@ -327,10 +327,10 @@ let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) conte let msg severity ?warning:(warning=Unknown) text = - warn_all {warn_type = warning; severity; loc = None; text; context = !current_context; print_loc = !Tracing.current_loc} + add {warn_type = warning; severity; loc = None; text; context = !current_context; print_loc = !Tracing.current_loc} let msg_each severity ?loc:(loc= !Tracing.current_loc) ?warning:(warning=Unknown) text = - warn_all {warn_type = warning; severity; loc = Some loc; text; context = !current_context; print_loc = loc} + add {warn_type = warning; severity; loc = Some loc; text; context = !current_context; print_loc = loc} let warn = msg Warning let warn_each = msg_each Warning From 2a62cce26abdd20b4fbb6aa9923bbd800d9ea3fb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:20:48 +0300 Subject: [PATCH 34/95] Remove empty text case from Messages.Message.show --- src/util/messages.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index ff37245318..31bb7a557b 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -232,7 +232,7 @@ struct | _ -> msg let show {warn_type; severity; loc; text; context; print_loc} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^(if text != "" then " "^text else "") in + let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^text in let msg = with_context msg context in msg end From b3bca0508f7bba02618f56d1515b713f749e7ed5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 12:40:03 +0300 Subject: [PATCH 35/95] Remove unused printXmlGlobals which was a duplicate of printXmlWarning --- src/framework/analyses.ml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 605a0aeb9b..a07c6008de 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -155,17 +155,6 @@ struct let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in List.iter (one_w f) !Messages.warning_table - let printXmlGlobals f () = - let one_text f (m,l) = - BatPrintf.fprintf f "\n%s" l.file l.line l.column m - in - let one_w f = function - | `text (m,l) -> one_text f (m,l) - | `group (n,e) -> - BatPrintf.fprintf f "%a\n" n (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e - in - List.iter (one_w f) !Messages.warning_table - let output table gtable gtfxml (file: file) = let out = Messages.get_out result_name !GU.out in match get_string "result" with From 054cb770c30818cb8d58846fdf187af00b1e749d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 13:47:17 +0300 Subject: [PATCH 36/95] Add test where bailure is unsound --- tests/regression/04-mutex/58-strange-spawn.c | 23 ++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 tests/regression/04-mutex/58-strange-spawn.c diff --git a/tests/regression/04-mutex/58-strange-spawn.c b/tests/regression/04-mutex/58-strange-spawn.c new file mode 100644 index 0000000000..fa5548fcad --- /dev/null +++ b/tests/regression/04-mutex/58-strange-spawn.c @@ -0,0 +1,23 @@ +#include +#include + +int myglobal; +pthread_mutex_t mutex1 = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t mutex2 = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + pthread_mutex_lock(&mutex1); + myglobal=myglobal+1; // RACE! + pthread_mutex_unlock(&mutex1); + return NULL; +} + +int main(void) { + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL, NULL); // strange pthread_create, should be treated as unknown and spawn (instead of unsoundly bailing) + pthread_mutex_lock(&mutex2); + myglobal=myglobal+1; // RACE! + pthread_mutex_unlock(&mutex2); + pthread_join (id, NULL); + return 0; +} From a8ba110f160bb565718d10b64892db7c7d5614dd Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 13:50:44 +0300 Subject: [PATCH 37/95] Remove unsound bailure --- src/analyses/base.ml | 14 +++++++------- src/analyses/contain.ml | 2 +- src/analyses/libraryFunctions.ml | 14 +++++++------- src/cdomains/lval.ml | 2 +- src/cdomains/shapeDomain.ml | 8 ++++---- src/domains/access.ml | 2 +- src/framework/constraints.ml | 3 +-- src/util/messages.ml | 2 -- 8 files changed, 22 insertions(+), 25 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index b28fb1a7c7..fcf849c065 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -755,7 +755,7 @@ struct and eval_tv a (gs:glob_fun) st (exp:exp): AD.t = match (eval_rv a gs st exp) with | `Address x -> x - | _ -> M.bailwith "Problems evaluating expression to function calls!" + | _ -> failwith "Problems evaluating expression to function calls!" and eval_int a gs st exp = match eval_rv a gs st exp with | `Int x -> x @@ -772,7 +772,7 @@ struct | `Int i -> `Index (iDtoIdx i, convert_offset a gs st ofs) | `Top -> `Index (IdxDom.top (), convert_offset a gs st ofs) | `Bot -> `Index (IdxDom.bot (), convert_offset a gs st ofs) - | _ -> M.bailwith "Index not an integer value" + | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) and eval_lv (a: Q.ask) (gs:glob_fun) st (lval:lval): AD.t = let rec do_offs def = function @@ -2035,14 +2035,14 @@ struct failwith "strcpy: expecting first argument to be a pointer!" in assign ctx (get_lval dst) src - | _ -> M.bailwith "strcpy arguments are strange/complicated." + | _ -> failwith "strcpy arguments are strange/complicated." end | `Unknown "F1" -> begin match args with | [dst; data; len] -> (* memset: write char to dst len times *) let dst_lval = mkMem ~addr:dst ~off:NoOffset in assign ctx dst_lval data (* this is only ok because we use ArrayDomain.Trivial per default, i.e., there's no difference between the first element or the whole array *) - | _ -> M.bailwith "memset arguments are strange/complicated." + | _ -> failwith "memset arguments are strange/complicated." end | `Unknown "list_add" when (get_bool "exp.list-type") -> begin match args with @@ -2059,7 +2059,7 @@ struct s2 | _ -> set ~ctx:(Some ctx) (Analyses.ask_of_ctx ctx) ctx.global ctx.local ladr lst.vtype `Top end - | _ -> M.bailwith "List function arguments are strange/complicated." + | _ -> failwith "List function arguments are strange/complicated." end | `Unknown "list_del" when (get_bool "exp.list-type") -> begin match args with @@ -2081,7 +2081,7 @@ struct end | _ -> s1 end - | _ -> M.bailwith "List function arguments are strange/complicated." + | _ -> failwith "List function arguments are strange/complicated." end | `Unknown "__builtin" -> begin match args with @@ -2164,7 +2164,7 @@ struct let st = set ~ctx:(Some ctx) (Analyses.ask_of_ctx ctx) ctx.global ctx.local (eval_lv (Analyses.ask_of_ctx ctx) ctx.global st lv) (Cilfacade.typeOfLval lv) `Top in st | _ -> - M.bailwith "Function __goblint_unknown expected one address-of argument." + failwith "Function __goblint_unknown expected one address-of argument." end (* Handling the assertions *) | `Unknown "__assert_rtn" -> raise Deadcode (* gcc's built-in assert *) diff --git a/src/analyses/contain.ml b/src/analyses/contain.ml index 804741c0b8..b24c9fd100 100644 --- a/src/analyses/contain.ml +++ b/src/analyses/contain.ml @@ -76,7 +76,7 @@ struct in (*read CXX.json; FIXME: use mangled names including namespaces*) let json= match List.filter (fun x -> Str.string_match (Str.regexp ".*CXX\\.json$") x 0) !Goblintutil.jsonFiles with - | [] -> Messages.bailwith "Containment analysis needs a CXX.json file." + | [] -> failwith "Containment analysis needs a CXX.json file." | f :: _ -> begin try diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 0ad279603c..4f7403df74 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -23,37 +23,37 @@ let classify' fn exps = | "pthread_create" -> begin match exps with | [id;_;fn;x] -> `ThreadCreate (id, fn, x) - | _ -> M.bailwith "pthread_create arguments are strange." + | _ -> failwith "pthread_create arguments are strange." end | "pthread_join" -> begin match exps with | [id; ret_var] -> `ThreadJoin (id, ret_var) - | _ -> M.bailwith "pthread_join arguments are strange!" + | _ -> failwith "pthread_join arguments are strange!" end | "malloc" | "kmalloc" | "__kmalloc" | "usb_alloc_urb" | "__builtin_alloca" -> begin match exps with | size::_ -> `Malloc size - | _ -> M.bailwith (fn^" arguments are strange!") + | _ -> failwith (fn^" arguments are strange!") end | "kzalloc" -> begin match exps with | size::_ -> `Calloc (Cil.one, size) - | _ -> M.bailwith (fn^" arguments are strange!") + | _ -> failwith (fn^" arguments are strange!") end | "calloc" -> begin match exps with | n::size::_ -> `Calloc (n, size) - | _ -> M.bailwith (fn^" arguments are strange!") + | _ -> failwith (fn^" arguments are strange!") end | "realloc" -> begin match exps with | p::size::_ -> `Realloc (p, size) - | _ -> M.bailwith (fn^" arguments are strange!") + | _ -> failwith (fn^" arguments are strange!") end | "assert" -> begin match exps with | [e] -> `Assert e - | _ -> M.bailwith "Assert argument mismatch!" + | _ -> failwith "Assert argument mismatch!" end | "_spin_trylock" | "spin_trylock" | "mutex_trylock" | "_spin_trylock_irqsave" -> `Lock(true, true, true) diff --git a/src/cdomains/lval.ml b/src/cdomains/lval.ml index acf61e7ee3..cc81b43264 100644 --- a/src/cdomains/lval.ml +++ b/src/cdomains/lval.ml @@ -21,7 +21,7 @@ let rec listify ofs = match ofs with | `NoOffset -> [] | `Field (x,ofs) -> x :: listify ofs - | _ -> Messages.bailwith "Indexing not supported here!" + | _ -> failwith "Indexing not supported here!" module Offset (Idx: IntDomain.Z) = struct diff --git a/src/cdomains/shapeDomain.ml b/src/cdomains/shapeDomain.ml index 2735978d91..1c149908c8 100644 --- a/src/cdomains/shapeDomain.ml +++ b/src/cdomains/shapeDomain.ml @@ -290,7 +290,7 @@ let proper_list_segment ask gl (lp1:ListPtr.t) (sm:SHMap.t) : bool = let app_edge' f s = function | `Lifted1 s -> f s | `Lifted2 s -> f s - | `Bot -> Messages.bailwith "not implemented1" + | `Bot -> failwith "not implemented1" | `Top -> s () in let point_to_me lp = @@ -300,7 +300,7 @@ let proper_list_segment ask gl (lp1:ListPtr.t) (sm:SHMap.t) : bool = if Edges.is_top n || app_edge' (fun x -> ListPtrSet.is_empty x) (fun () -> true) n then None else - let lp' = app_edge' ListPtrSet.choose (fun () -> Messages.bailwith "not implemented2") n in + let lp' = app_edge' ListPtrSet.choose (fun () -> failwith "not implemented2") n in if app_edge (ListPtrSet.for_all point_to_me) n then Some lp' else None in @@ -326,7 +326,7 @@ let proper_list_segment' ask gl (lp1:ListPtr.t) (lp2:ListPtr.t) (sm:SHMap.t) : b let app_edge' f s = function | `Lifted1 s -> f s | `Lifted2 s -> f s - | `Bot -> Messages.bailwith "not implemented1" + | `Bot -> failwith "not implemented1" | `Top -> s () in let point_to_me lp = @@ -335,7 +335,7 @@ let proper_list_segment' ask gl (lp1:ListPtr.t) (lp2:ListPtr.t) (sm:SHMap.t) : b in app_edge' (fun x -> not (ListPtrSet.is_top x)) (fun () -> false) n && app_edge' (fun x -> not (ListPtrSet.is_top x)) (fun () -> false) p && - let lp' = app_edge' ListPtrSet.choose (fun () -> Messages.bailwith "not implemented2") n in + let lp' = app_edge' ListPtrSet.choose (fun () -> failwith "not implemented2") n in app_edge (ListPtrSet.for_all point_to_me) n && (* app_edge (ListPtrSet.mem lp1) p && *) if ListPtr.equal lp1 lp2 then true else diff --git a/src/domains/access.ml b/src/domains/access.ml index 0fe6bba1a3..f8a336a502 100644 --- a/src/domains/access.ml +++ b/src/domains/access.ml @@ -338,7 +338,7 @@ let add_propagate e w conf ty ls p = let fi = match f with | `Field (fi,_) -> fi - | _ -> Messages.bailwith "add_propagate: no field found" + | _ -> failwith "add_propagate: no field found" in let ts = typeSig (TComp (fi.fcomp,[])) in let vars = Ht.find_all typeVar ts in diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 272367c32d..cb2f9ba361 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -749,8 +749,7 @@ struct let old_context = !M.current_context in let _ = current_node := Some u in M.current_context := Some (Obj.repr c); - let d = try tf (v,c) (e,u) getl sidel getg sideg - with M.Bailure s -> Messages.warn_each s; (getl (u,c)) in + let d = tf (v,c) (e,u) getl sidel getg sideg in let _ = current_node := old_node in M.current_context := old_context; d diff --git a/src/util/messages.ml b/src/util/messages.ml index 31bb7a557b..1c1adf5047 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -242,8 +242,6 @@ let messages_table = MH.create 113 (* messages without order for quick mem looku let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) -exception Bailure of string -let bailwith s = raise (Bailure s) let warning_table : [`text of string * location | `group of string * ((string * location) list)] list ref = ref [] let warn_out = ref stdout From 717b7c1a894812ed1d19aaac3202dcfe128c64f5 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 14:03:24 +0300 Subject: [PATCH 38/95] Replace strange library function failures with warnings --- src/analyses/libraryFunctions.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 4f7403df74..242cb6b33c 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -23,37 +23,37 @@ let classify' fn exps = | "pthread_create" -> begin match exps with | [id;_;fn;x] -> `ThreadCreate (id, fn, x) - | _ -> failwith "pthread_create arguments are strange." + | _ -> M.warn_each "pthread_create arguments are strange."; `Unknown fn end | "pthread_join" -> begin match exps with | [id; ret_var] -> `ThreadJoin (id, ret_var) - | _ -> failwith "pthread_join arguments are strange!" + | _ -> M.warn_each "pthread_join arguments are strange!"; `Unknown fn end | "malloc" | "kmalloc" | "__kmalloc" | "usb_alloc_urb" | "__builtin_alloca" -> begin match exps with | size::_ -> `Malloc size - | _ -> failwith (fn^" arguments are strange!") + | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn end | "kzalloc" -> begin match exps with | size::_ -> `Calloc (Cil.one, size) - | _ -> failwith (fn^" arguments are strange!") + | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn end | "calloc" -> begin match exps with | n::size::_ -> `Calloc (n, size) - | _ -> failwith (fn^" arguments are strange!") + | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn end | "realloc" -> begin match exps with | p::size::_ -> `Realloc (p, size) - | _ -> failwith (fn^" arguments are strange!") + | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn end | "assert" -> begin match exps with | [e] -> `Assert e - | _ -> failwith "Assert argument mismatch!" + | _ -> M.warn_each "Assert argument mismatch!"; `Unknown fn end | "_spin_trylock" | "spin_trylock" | "mutex_trylock" | "_spin_trylock_irqsave" -> `Lock(true, true, true) From b42e902250fa4e91da4711182760a9a0a2a56bf0 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 16:25:12 +0300 Subject: [PATCH 39/95] Fix invalidation of pthread_create --- src/analyses/libraryFunctions.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 242cb6b33c..88c6b50c0f 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -396,7 +396,7 @@ let invalidate_actions = ref [ "dev_driver_string", readsAll; "__spin_lock_init", writes [1]; "kmem_cache_create", readsAll; - "pthread_create", onlyWrites [1]; + "pthread_create", onlyWrites [0; 2]; (* TODO: onlyWrites/keep is 0-indexed now, WTF? *) "__builtin_prefetch", readsAll; "idr_pre_get", readsAll; "zil_replay", writes [1;2;3;5]; From f59035d552ba677664a212cf74c40511312c64d3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 16:46:41 +0300 Subject: [PATCH 40/95] Extract piece from message --- src/util/messages.ml | 40 +++++++++++++++++++++++++++------------- 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 1c1adf5047..09c5f5a6eb 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -210,33 +210,47 @@ struct get_bool ("warn." ^ (to_string e)) end -module Message = +module Piece = struct type t = { - warn_type: Warning.t; (* TODO: make list of tags *) - severity: Severity.t; loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)]) option; (* TODO: this equality is terrible... *) print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq] - let should_warn {warn_type; severity; _} = - Warning.should_warn warn_type && Severity.should_warn severity - - let hash {warn_type; severity; loc; text; context; print_loc} = - 3 * Warning.hash warn_type + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context + 13 * Severity.hash severity + let hash {loc; text; context; print_loc} = + 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context let with_context msg = function | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) | _ -> msg - let show {warn_type; severity; loc; text; context; print_loc} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^text in + let show {loc; text; context; print_loc} = + let msg = " "^text in let msg = with_context msg context in msg end +module Message = +struct + type t = { + warn_type: Warning.t; (* TODO: make list of tags *) + severity: Severity.t; + piece: Piece.t; + } [@@deriving eq] + + let should_warn {warn_type; severity; _} = + Warning.should_warn warn_type && Severity.should_warn severity + + let hash {warn_type; severity; piece} = + 3 * Warning.hash warn_type + 7 * Piece.hash piece + 13 * Severity.hash severity + + let show {warn_type; severity; piece} = + let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^ Piece.show piece in + msg +end + module MH = Hashtbl.Make (Message) let messages_table = MH.create 113 (* messages without order for quick mem lookup *) let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) @@ -315,7 +329,7 @@ let print_group group_name errors = let add m = if !GU.should_warn then ( if Message.should_warn m && not (MH.mem messages_table m) then ( - print_msg (Message.show m) m.print_loc; + print_msg (Message.show m) m.piece.print_loc; MH.replace messages_table m (); messages_list := m :: !messages_list ) @@ -325,10 +339,10 @@ let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) conte let msg severity ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; loc = None; text; context = !current_context; print_loc = !Tracing.current_loc} + add {warn_type = warning; severity; piece = {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} let msg_each severity ?loc:(loc= !Tracing.current_loc) ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; loc = Some loc; text; context = !current_context; print_loc = loc} + add {warn_type = warning; severity; piece = {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning let warn_each = msg_each Warning From 0ded1e87b8f449568d9bc1d56ed8deb47c25118c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 16:56:33 +0300 Subject: [PATCH 41/95] Add support for group messages in new table --- src/util/messages.ml | 34 ++++++++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 8 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 09c5f5a6eb..08a3cd3f24 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -232,22 +232,40 @@ struct msg end +module MultiPiece = +struct + type t = + | Single of Piece.t + | Group of {group_text: string; pieces: Piece.t list} + [@@ deriving eq] + + let hash = function + | Single piece -> Piece.hash piece + | Group {group_text; pieces} -> + Hashtbl.hash group_text + 3 * (List.fold_left (fun xs x -> xs + Piece.hash x) 996699 pieces) (* copied from Printable.Liszt *) + + let show = function + | Single piece -> Piece.show piece + | Group {group_text; pieces} -> + List.fold_left (fun acc piece -> acc ^ "\n " ^ Piece.show piece) group_text pieces +end + module Message = struct type t = { warn_type: Warning.t; (* TODO: make list of tags *) severity: Severity.t; - piece: Piece.t; + multipiece: MultiPiece.t; } [@@deriving eq] let should_warn {warn_type; severity; _} = Warning.should_warn warn_type && Severity.should_warn severity - let hash {warn_type; severity; piece} = - 3 * Warning.hash warn_type + 7 * Piece.hash piece + 13 * Severity.hash severity + let hash {warn_type; severity; multipiece} = + 3 * Warning.hash warn_type + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity - let show {warn_type; severity; piece} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^ Piece.show piece in + let show {warn_type; severity; multipiece} = + let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^ MultiPiece.show multipiece in msg end @@ -329,7 +347,7 @@ let print_group group_name errors = let add m = if !GU.should_warn then ( if Message.should_warn m && not (MH.mem messages_table m) then ( - print_msg (Message.show m) m.piece.print_loc; + print_msg (Message.show m) (match m.multipiece with Single piece -> piece.print_loc | Group _ -> locUnknown); (* TODO: don't use locUnknown *) MH.replace messages_table m (); messages_list := m :: !messages_list ) @@ -339,10 +357,10 @@ let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) conte let msg severity ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; piece = {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} + add {warn_type = warning; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} let msg_each severity ?loc:(loc= !Tracing.current_loc) ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; piece = {loc = Some loc; text; context = !current_context; print_loc = loc}} + add {warn_type = warning; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning let warn_each = msg_each Warning From 8e2be9650235d0ac4e3c522de2dc3f4a9dbd2c3e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 17:37:08 +0300 Subject: [PATCH 42/95] Reimplement Messages.print_group in new system --- src/util/messages.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 08a3cd3f24..bb948ec266 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -227,9 +227,7 @@ struct | _ -> msg let show {loc; text; context; print_loc} = - let msg = " "^text in - let msg = with_context msg context in - msg + with_context text context end module MultiPiece = @@ -344,15 +342,40 @@ let print_group group_name errors = ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) +let print ?(out= !warn_out) (m: Message.t) = + let show_piece piece = + colorize @@ Piece.show piece ^ " {violet}(" ^ CilType.Location.show piece.print_loc ^ ")" + in + let prefix = "[" ^ Severity.show m.severity ^ "]" ^ Warning.show m.warn_type in + match m.multipiece with + | Single piece -> + Printf.fprintf out "%s %s\n%!" prefix (show_piece piece) + | Group {group_text; pieces} -> + Printf.fprintf out "%s %s\n%!" prefix (List.fold_left (fun acc piece -> acc ^ "\n " ^ show_piece piece) (group_text ^ ":") pieces) + let add m = if !GU.should_warn then ( if Message.should_warn m && not (MH.mem messages_table m) then ( - print_msg (Message.show m) (match m.multipiece with Single piece -> piece.print_loc | Group _ -> locUnknown); (* TODO: don't use locUnknown *) + print m; MH.replace messages_table m (); messages_list := m :: !messages_list ) ) +let print_group group_name errors = + let m = Message.{warn_type = Unknown; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in + add m; + + if (get_bool "ana.osek.warnfiles") then + match (String.sub group_name 0 6) with + | "Safely" -> print ~out:!warn_safe m + | "Datara" -> print ~out:!warn_race m + | "High r" -> print ~out:!warn_higr m + | "High w" -> print ~out:!warn_higw m + | "Low re" -> print ~out:!warn_lowr m + | "Low wr" -> print ~out:!warn_loww m + | _ -> () + let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) From 5b0a15ca8c2a4e6f9d96075258fc0696021e16e2 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 17:53:13 +0300 Subject: [PATCH 43/95] Switch from warnings_table to messages_list --- src/framework/analyses.ml | 10 +++++----- src/framework/control.ml | 2 +- src/solvers/generic.ml | 14 +++++++------- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index a07c6008de..e865480a24 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -144,16 +144,16 @@ struct iter print_one xs let printXmlWarning f () = - let one_text f (m,l) = + let one_text f Messages.Piece.{print_loc = l; text = m; _} = BatPrintf.fprintf f "\n%s" l.file l.line l.column (GU.escape m) in - let one_w f = function - | `text (m,l) -> one_text f (m,l) - | `group (n,e) -> + let one_w f (m: Messages.Message.t) = match m.multipiece with + | Single piece -> one_text f piece + | Group {group_text = n; pieces = e} -> BatPrintf.fprintf f "%a\n" n (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e in let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in - List.iter (one_w f) !Messages.warning_table + List.iter (one_w f) !Messages.messages_list let output table gtable gtfxml (file: file) = let out = Messages.get_out result_name !GU.out in diff --git a/src/framework/control.ml b/src/framework/control.ml index b41b86a69b..f90d84eb78 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -444,7 +444,7 @@ struct ); Serialize.marshal !MCP.analyses_table analyses; Serialize.marshal (file, Cabs2cil.environment) cil; - Serialize.marshal !Messages.warning_table warnings; + Serialize.marshal !Messages.messages_list warnings; Serialize.marshal (Stats.top, Gc.quick_stat ()) stats ); Goblintutil.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); (* write solver_stats after solving (otherwise no rows if faster than dbg.solver-stats-interval). TODO better way to write solver_stats without terminal output? *) diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 93b38dd040..81066df04c 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -140,12 +140,12 @@ struct let warning_id = ref 1 let writeXmlWarnings () = - let one_text f (m,l) = + let one_text f Messages.Piece.{print_loc = l; text = m; _} = fprintf f "\n%s" l.file l.line l.column m in - let one_w f = function - | `text (m,l) -> one_text f (m,l) - | `group (n,e) -> + let one_w f (m: Messages.Message.t) = match m.multipiece with + | Single piece -> one_text f piece + | Group {group_text = n; pieces = e} -> fprintf f "%a\n" n (List.print ~first:"" ~last:"" ~sep:"" one_text) e in let one_w x f = fprintf f "\n%a" one_w x in @@ -155,7 +155,7 @@ struct incr warning_id; File.with_file_out ~mode:[`create;`excl;`text] full_name (one_w x) in - List.iter write_warning !Messages.warning_table + List.iter write_warning !Messages.messages_list module SSH = Hashtbl.Make (struct include String let hash (x:string) = Hashtbl.hash x end) let funs = SSH.create 100 @@ -197,8 +197,8 @@ struct NH.iter (fun v () -> fprintf f "%a\n" Var.printXml v) updated_l; GH.iter (fun v () -> fprintf f "\n%a\n" GVar.printXml v) updated_g; let g n _ = fprintf f "\n" (n + !warning_id) in - List.iteri g !Messages.warning_table; - (* List.iter write_warning !Messages.warning_table *) + List.iteri g !Messages.messages_list; + (* List.iter write_warning !Messages.messages_list *) fprintf f "\n"; in File.with_file_out ~mode:[`excl;`create;`text] full_name write_updates From c38250d705f486c6bc8ebd98bdccf7509f9dc5af Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 17:53:38 +0300 Subject: [PATCH 44/95] Remove old warnings_table and print functions --- src/framework/control.ml | 2 +- src/maingoblint.ml | 2 +- src/util/messages.ml | 31 ------------------------------- 3 files changed, 2 insertions(+), 33 deletions(-) diff --git a/src/framework/control.ml b/src/framework/control.ml index f90d84eb78..e90d189ce1 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -554,7 +554,7 @@ struct (* Use "normal" constraint solving *) let timeout_reached () = - M.print_msg "Timeout reached!" (!Tracing.current_loc); + M.error_each ~loc:!Tracing.current_loc "Timeout reached!"; (* let module S = Generic.SolverStats (EQSys) (LHT) in *) (* Can't call Generic.SolverStats...print_stats :( print_stats is triggered by dbg.solver-signal, so we send that signal to ourself in maingoblint before re-raising Timeout. diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 1f04728e71..88743bd82c 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -318,7 +318,7 @@ let do_analyze change_info merged_AST = with e -> let backtrace = Printexc.get_raw_backtrace () in (* capture backtrace immediately, otherwise the following loses it (internal exception usage without raise_notrace?) *) let loc = !Tracing.current_loc in - Messages.print_msg "{RED}About to crash!" loc; + Messages.error_each ~loc "{RED}About to crash!"; (* TODO: move severity coloring to Messages *) (* trigger Generic.SolverStats...print_stats *) Goblintutil.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); do_stats (); diff --git a/src/util/messages.ml b/src/util/messages.ml index bb948ec266..328b3abc32 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -1,5 +1,3 @@ -open Cil -open Pretty open GobConfig module GU = Goblintutil @@ -272,14 +270,10 @@ let messages_table = MH.create 113 (* messages without order for quick mem looku let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) - -let warning_table : [`text of string * location | `group of string * ((string * location) list)] list ref = ref [] let warn_out = ref stdout let tracing = Config.tracing let xml_file_name = ref "" -let push_warning w = - warning_table := w :: !warning_table (*Warning files*) @@ -316,31 +310,6 @@ let colorize ?on:(on=colors_on ()) msg = let msg = List.fold_right replace colors msg in msg^(if on then "\027[0;0;00m" else "") (* reset at end *) -let print_msg msg loc = - let msgc = colorize msg in - let msg = colorize ~on:false msg in - push_warning (`text (msg, loc)); - let color = if colors_on () then "{violet}" else "" in - let s = Printf.sprintf "%s %s(%s)" msgc color (CilType.Location.show loc) in - Printf.fprintf !warn_out "%s\n%!" (colorize s) - - -let print_group group_name errors = - (* Add warnings to global warning list *) - push_warning (`group (group_name, errors)); - let f (msg,loc): doc = Pretty.dprintf "%s (%a)" msg CilType.Location.pretty loc in - if (get_bool "ana.osek.warnfiles") then begin - match (String.sub group_name 0 6) with - | "Safely" -> ignore (Pretty.fprintf !warn_safe "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | "Datara" -> ignore (Pretty.fprintf !warn_race "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | "High r" -> ignore (Pretty.fprintf !warn_higr "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | "High w" -> ignore (Pretty.fprintf !warn_higw "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | "Low re" -> ignore (Pretty.fprintf !warn_lowr "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | "Low wr" -> ignore (Pretty.fprintf !warn_loww "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - | _ -> () - end; - ignore (Pretty.fprintf !warn_out "%s:\n @[%a@]\n" group_name (docList ~sep:line f) errors) - let print ?(out= !warn_out) (m: Message.t) = let show_piece piece = From 35ce918ce4f5fb9805a3e82d9176ccacea34e1b8 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 17:59:26 +0300 Subject: [PATCH 45/95] Rename Messages.print_group -> warn_group_old --- src/analyses/osek.ml | 38 +++++++++++++++++++------------------- src/domains/access.ml | 2 +- src/util/messages.ml | 4 +++- 3 files changed, 23 insertions(+), 21 deletions(-) diff --git a/src/analyses/osek.ml b/src/analyses/osek.ml index 1378d673e3..0d899f0411 100644 --- a/src/analyses/osek.ml +++ b/src/analyses/osek.ml @@ -1130,7 +1130,7 @@ struct if (List.mem gl.vname (List.map Json.string @@ get_list "ana.osek.safe_vars")) then begin suppressed := !suppressed+1; if (get_bool "allglobs") then - print_group (safe_str "safe variable") warnings + warn_group_old (safe_str "safe variable") warnings else ignore (printf "Suppressed warning: %s is not guarded\n" var_str) end else begin @@ -1141,7 +1141,7 @@ struct if safe_funs = [] then begin race_free := false; let warn = def_warn ^ " at " ^ var_str in - print_group warn warnings + warn_group_old warn warnings end else begin filtered := !filtered +1; (*((_, dom_elem,_),_) -> let lock_names_list = names (Lockset.ReverseAddrSet.elements dom_elem) in @@ -1154,43 +1154,43 @@ struct | Race -> begin race_free := false; let warn = "Datarace at " ^ var_str in - print_group warn warnings + warn_group_old warn warnings end | Guarded locks -> let lock_str = Mutex.Lockset.show locks in if (get_bool "allglobs") then - print_group (safe_str "common mutex after filtering") warnings + warn_group_old (safe_str "common mutex after filtering") warnings else ignore (printf "Found correlation: %s is guarded by lockset %s after filtering\n" var_str lock_str) | Priority pry -> if (get_bool "allglobs") then - print_group (safe_str "same priority after filtering") warnings + warn_group_old (safe_str "same priority after filtering") warnings else ignore (printf "Found correlation: %s is guarded by priority %s after filtering\n" var_str (string_of_int pry)) | Defence (defpry,offpry) -> if (get_bool "allglobs") then - print_group (safe_str "defensive priority exceeds offensive priority after filtering") warnings + warn_group_old (safe_str "defensive priority exceeds offensive priority after filtering") warnings else ignore (printf "Found correlation: %s is guarded by defensive priority %s against offensive priority %s after filtering\n" var_str (string_of_int defpry) (string_of_int offpry)) | Flag (flagvar) -> if (get_bool "allglobs") then - print_group (safe_str ("variable "^flagvar ^" used to prevent concurrent accesses after filtering") ) warnings + warn_group_old (safe_str ("variable "^flagvar ^" used to prevent concurrent accesses after filtering") ) warnings else ignore (printf "Found correlation: %s is guarded by flag %s after filtering\n" var_str flagvar) | ReadOnly -> if (get_bool "allglobs") then - print_group (safe_str "only read after filtering") warnings + warn_group_old (safe_str "only read after filtering") warnings | ThreadLocal -> if (get_bool "allglobs") then - print_group (safe_str "thread local after filtering") warnings + warn_group_old (safe_str "thread local after filtering") warnings | BadFlag -> begin race_free := false; let warn = "Writerace at 'flag' " ^ var_str in - print_group warn warnings + warn_group_old warn warnings end | GoodFlag -> begin if (get_bool "allglobs") then begin - print_group (safe_str "is a flag after filtering") warnings + warn_group_old (safe_str "is a flag after filtering") warnings end else begin ignore (printf "Found flag behaviour after filtering: %s\n" var_str) end @@ -1208,38 +1208,38 @@ struct | Guarded locks -> let lock_str = Mutex.Lockset.show locks in if (get_bool "allglobs") then - print_group (safe_str "common mutex") warnings + warn_group_old (safe_str "common mutex") warnings else ignore (printf "Found correlation: %s is guarded by lockset %s\n" var_str lock_str) | Priority pry -> if (get_bool "allglobs") then - print_group (safe_str "same priority") warnings + warn_group_old (safe_str "same priority") warnings else ignore (printf "Found correlation: %s is guarded by priority %s\n" var_str (string_of_int pry)) | Defence (defpry,offpry) -> if (get_bool "allglobs") then - print_group (safe_str "defensive priority exceeds offensive priority") warnings + warn_group_old (safe_str "defensive priority exceeds offensive priority") warnings else ignore (printf "Found correlation: %s is guarded by defensive priority %s against offensive priority %s\n" var_str (string_of_int defpry) (string_of_int offpry)) | Flag (flagvar) -> if (get_bool "allglobs") then - print_group (safe_str ("variable "^flagvar ^" used to prevent concurrent accesses") ) warnings + warn_group_old (safe_str ("variable "^flagvar ^" used to prevent concurrent accesses") ) warnings else ignore (printf "Found correlation: %s is guarded by flag %s\n" var_str flagvar) | ReadOnly -> if (get_bool "allglobs") then - print_group (safe_str "only read") warnings + warn_group_old (safe_str "only read") warnings | ThreadLocal -> if (get_bool "allglobs") then - print_group (safe_str "thread local") warnings + warn_group_old (safe_str "thread local") warnings | BadFlag -> begin race_free := false; let warn = "Writerace at 'flag' " ^ var_str in - print_group warn warnings + warn_group_old warn warnings end | GoodFlag -> begin if (get_bool "allglobs") then begin - print_group (safe_str "is a flag") warnings + warn_group_old (safe_str "is a flag") warnings end else begin ignore (printf "Found flag behaviour: %s\n" var_str) end diff --git a/src/domains/access.ml b/src/domains/access.ml index f8a336a502..1d313ccbc6 100644 --- a/src/domains/access.ml +++ b/src/domains/access.ml @@ -508,7 +508,7 @@ let print_races_oldscool () = sprint 80 (dprintf "Datarace at %a" d_memo (ty,lv)) in if not safe || allglobs then - Messages.print_group groupname xs + Messages.warn_group_old groupname xs in let f ty = LvalOptHash.iter (h ty) in TypeHash.iter f accs diff --git a/src/util/messages.ml b/src/util/messages.ml index 328b3abc32..7f0fdfa72f 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -331,7 +331,9 @@ let add m = ) ) -let print_group group_name errors = +(** Adapts old [print_group] to new message structure. + Don't use for new (group) warnings. *) +let warn_group_old group_name errors = let m = Message.{warn_type = Unknown; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in add m; From e6573d27e2fbdb620112bf5d201f6932d0656873 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 18:08:42 +0300 Subject: [PATCH 46/95] Add message severity colors to terminal output --- src/util/messages.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 7f0fdfa72f..6e980341e3 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -313,14 +313,20 @@ let colorize ?on:(on=colors_on ()) msg = let print ?(out= !warn_out) (m: Message.t) = let show_piece piece = - colorize @@ Piece.show piece ^ " {violet}(" ^ CilType.Location.show piece.print_loc ^ ")" + Piece.show piece ^ " {violet}(" ^ CilType.Location.show piece.print_loc ^ ")" in - let prefix = "[" ^ Severity.show m.severity ^ "]" ^ Warning.show m.warn_type in + let severity_color = match m.severity with + | Error -> "{red}" + | Warning -> "{yellow}" + | Info -> "{blue}" + | Debug -> "{white}" (* non-bright white is actually some gray *) + in + let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Warning.show m.warn_type in match m.multipiece with | Single piece -> - Printf.fprintf out "%s %s\n%!" prefix (show_piece piece) + Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ show_piece piece) | Group {group_text; pieces} -> - Printf.fprintf out "%s %s\n%!" prefix (List.fold_left (fun acc piece -> acc ^ "\n " ^ show_piece piece) (group_text ^ ":") pieces) + Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ List.fold_left (fun acc piece -> acc ^ "\n " ^ severity_color ^ show_piece piece) (group_text ^ ":") pieces) let add m = if !GU.should_warn then ( From a9273b4431d7aa73af83e2d8572cc240a62d5ff6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 18:17:00 +0300 Subject: [PATCH 47/95] Add Success severity, use severities for assert coloring --- src/analyses/base.ml | 14 +++++++------- src/util/defaults.ml | 1 + src/util/messages.ml | 5 +++++ 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index fcf849c065..02492f8ffc 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1947,7 +1947,7 @@ struct | _ -> `Top in let expr = sprint d_exp e in - let warn ?annot msg = if should_warn then + let warn warn_fn ?annot msg = if should_warn then if get_bool "dbg.regression" then ( (* This only prints unexpected results (with the difference) as indicated by the comment behind the assert (same as used by the regression test script). *) let loc = !M.current_loc in let line = List.at (List.of_enum @@ File.lines_of loc.file) (loc.line-1) in @@ -1958,23 +1958,23 @@ struct (* Expressions with logical connectives like a && b are calculated in temporary variables by CIL. Instead of the original expression, we then see something like tmp___0. So we replace expr in msg by the original source if this is the case. *) let assert_expr = if string_match (regexp ".*assert(\\(.+\\));.*") line 0 then matched_group 1 line else expr in let msg = if expr <> assert_expr then String.nreplace msg expr assert_expr else msg in - M.warn_each (msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) + warn_fn (msg ^ " Expected: " ^ (expected |? "SUCCESS") ^ " -> " ^ result) ) ) else - M.warn_each msg + warn_fn msg in match check_assert e ctx.local with | `Lifted false -> - warn ~annot:"FAIL" ("{red}Assertion \"" ^ expr ^ "\" will fail."); + warn M.error_each ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn ("{green}Assertion \"" ^ expr ^ "\" will succeed"); + warn M.success_each ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.warn_each ("{red}Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error_each ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn ~annot:"UNKNOWN" ("{yellow}Assertion \"" ^ expr ^ "\" is unknown."); + warn M.warn_each ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in diff --git a/src/util/defaults.ml b/src/util/defaults.ml index ef0c43f009..b70657aeec 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -248,6 +248,7 @@ let _ = () ; reg Warnings "warn.warning" "true" "Warning severity messages" ; reg Warnings "warn.info" "true" "Info severity messages" ; reg Warnings "warn.debug" "true" "Debug severity messages" + ; reg Warnings "warn.success" "true" "Success severity messages" let default_schema = "\ { 'id' : 'root' diff --git a/src/util/messages.ml b/src/util/messages.ml index 6e980341e3..52c7977fbc 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -194,6 +194,7 @@ struct | Warning | Info | Debug + | Success [@@deriving eq, show { with_path = false }] let hash x = Hashtbl.hash x (* variants, so this is fine *) @@ -204,6 +205,7 @@ struct | Warning -> "warning" | Info -> "info" | Debug -> "debug" + | Success -> "success" in get_bool ("warn." ^ (to_string e)) end @@ -320,6 +322,7 @@ let print ?(out= !warn_out) (m: Message.t) = | Warning -> "{yellow}" | Info -> "{blue}" | Debug -> "{white}" (* non-bright white is actually some gray *) + | Success -> "{green}" in let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Warning.show m.warn_type in match m.multipiece with @@ -369,5 +372,7 @@ let error_each = msg_each Error (* TODO: info *) let debug = msg Debug let debug_each = msg_each Debug +(* TODO: success? *) +let success_each = msg_each Success include Tracing From 623e02c2aabc54bc7a000e9960a659000e330e9c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 18:19:04 +0300 Subject: [PATCH 48/95] Remove unnecessary color from about to crash error_each already adds red color. --- src/maingoblint.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 88743bd82c..7a19264f11 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -318,7 +318,7 @@ let do_analyze change_info merged_AST = with e -> let backtrace = Printexc.get_raw_backtrace () in (* capture backtrace immediately, otherwise the following loses it (internal exception usage without raise_notrace?) *) let loc = !Tracing.current_loc in - Messages.error_each ~loc "{RED}About to crash!"; (* TODO: move severity coloring to Messages *) + Messages.error_each ~loc "About to crash!"; (* TODO: move severity coloring to Messages *) (* trigger Generic.SolverStats...print_stats *) Goblintutil.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); do_stats (); From 1e1c51bdf991bd1103e396cdbe5218ae2f0f6a3a Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 30 Aug 2021 18:25:04 +0300 Subject: [PATCH 49/95] Add Assert type to messages --- src/analyses/base.ml | 8 ++++---- src/util/defaults.ml | 1 + src/util/messages.ml | 4 ++++ 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 02492f8ffc..7b05589db9 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1965,16 +1965,16 @@ struct in match check_assert e ctx.local with | `Lifted false -> - warn M.error_each ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); + warn (M.error_each ~warning:M.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn M.success_each ("Assertion \"" ^ expr ^ "\" will succeed"); + warn (M.success_each ~warning:M.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.error_each ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error_each ~warning:M.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn M.warn_each ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); + warn (M.warn_each ~warning:M.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in diff --git a/src/util/defaults.ml b/src/util/defaults.ml index b70657aeec..d9760bd9bd 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -238,6 +238,7 @@ let _ = () (* {4 category [Warnings]} *) let _ = () + ; reg Warnings "warn.assert" "true" "Assert messages" ; reg Warnings "warn.behavior" "true" "undefined behavior warnings" ; reg Warnings "warn.integer" "true" "integer (Overflow, Div_by_zero) warnings" ; reg Warnings "warn.cast" "true" "Cast (Type_mismatch(bug) warnings" diff --git a/src/util/messages.ml b/src/util/messages.ml index 52c7977fbc..fdfefa974d 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -24,6 +24,7 @@ type integer = Overflow | DivByZero [@@deriving eq] type cast = TypeMismatch [@@deriving eq] type warning = + | Assert | Behavior of behavior | Integer of integer | Race @@ -157,6 +158,7 @@ struct let should_warn e = let to_string e = match e with + | Assert -> "assert" | Behavior _ -> "behavior" | Integer _ -> "integer" | Race -> "race" @@ -167,6 +169,7 @@ struct let show e = match e with + | Assert -> "[Assert]" | Behavior x -> "[Behavior > " ^ (Behavior.show x) | Integer x -> "[Integer > " ^ (Integer.show x) | Race -> "[Race]" @@ -178,6 +181,7 @@ struct match s with | [] -> Unknown | h :: t -> match h with + | "assert" -> Assert | "behavior" -> Behavior.from_string_list t | "integer" -> Integer.from_string_list t | "race" -> Race From d37ed2ed6f0568f8b24f4a356279b9f98f227010 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 11:44:31 +0300 Subject: [PATCH 50/95] Rename message warning type to category --- src/analyses/base.ml | 12 +++--- src/analyses/malloc_null.ml | 2 +- src/cdomains/arrayDomain.ml | 10 ++--- src/cdomains/containDomain.ml | 2 +- src/cdomains/intDomain.ml | 2 +- src/cdomains/lvalMapDomain.ml | 4 +- src/util/messageCategory.ml | 0 src/util/messages.ml | 76 +++++++++++++++++------------------ 8 files changed, 54 insertions(+), 54 deletions(-) create mode 100644 src/util/messageCategory.ml diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7b05589db9..8355f8cafc 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -803,9 +803,9 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) "Must dereference NULL pointer" + then M.error_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) "Must dereference NULL pointer" else if AD.may_be_null adr - then M.warn_each ~warning:(M.Warning.Behavior.Undefined.nullpointer_dereference ()) "May dereference NULL pointer"); + then M.warn_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) "May dereference NULL pointer"); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in @@ -1965,16 +1965,16 @@ struct in match check_assert e ctx.local with | `Lifted false -> - warn (M.error_each ~warning:M.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); + warn (M.error_each ~category:M.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn (M.success_each ~warning:M.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); + warn (M.success_each ~category:M.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.error_each ~warning:M.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error_each ~category:M.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn (M.warn_each ~warning:M.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); + warn (M.warn_each ~category:M.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index 4f8d45acfa..da7ffe7b3b 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -47,7 +47,7 @@ struct if D.exists (fun x -> List.exists (fun x -> is_prefix_of x v) (Addr.to_var_offset x)) st then let var = Addr.from_var_offset v in - Messages.warn_each ("Possible dereferencing of null on variable '" ^ (Addr.show var) ^ "'.") ~warning:(Messages.Warning.Behavior.Undefined.nullpointer_dereference ()) + Messages.warn_each ~category:(Messages.Category.Behavior.Undefined.nullpointer_dereference ()) ("Possible dereferencing of null on variable '" ^ (Addr.show var) ^ "'.") with SetDomain.Unsupported _ -> () (* Warn null-lval dereferences, but not normal (null-) lvals*) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 0d0a1d8295..75bbfdbb88 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,15 +575,15 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "Must access array past end" + M.error_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "Must access array past end" | Some true, None -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "May access array past end" + M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "May access array past end" | Some false, Some true -> - M.error_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "Must access array before start" + M.error_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "Must access array before start" | None, Some true -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "May access array before start" + M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "May access array before start" | _ -> - M.warn_each ~warning:(M.Warning.Behavior.Undefined.ArrayOutOfBounds.unknown ()) "May access array out of bounds" + M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown ()) "May access array out of bounds" else () diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 6f42358617..043d58cf45 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -262,7 +262,7 @@ struct let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~warning:Messages.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) + Messages.warn_each ~category:Messages.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 3229ea1d2d..1a32d3cc1b 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -1296,7 +1296,7 @@ struct v ) else if should_ignore_overflow ik then ( - M.warn ~warning:(M.Warning.Integer.overflow ()) "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + M.warn ~category:(M.Category.Integer.overflow ()) "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; `Bot ) else ( diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index b0a9c48a43..5e7da3646c 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -254,8 +254,8 @@ struct match msg |> Str.split (Str.regexp "[ \n\r\x0c\t]+") with | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) msg | h :: t -> - let warn_type = Messages.Warning.from_string_list (h |> Str.split (Str.regexp "[.]")) - in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~warning:warn_type (String.concat " " t) + let warn_type = Messages.Category.from_string_list (h |> Str.split (Str.regexp "[.]")) + in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~category:warn_type (String.concat " " t) (* getting keys from Cil Lvals *) let sprint f x = Pretty.sprint 80 (f () x) diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/util/messages.ml b/src/util/messages.ml index fdfefa974d..5bff20a385 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -23,7 +23,7 @@ type integer = Overflow | DivByZero [@@deriving eq] type cast = TypeMismatch [@@deriving eq] -type warning = +type category = | Assert | Behavior of behavior | Integer of integer @@ -33,9 +33,9 @@ type warning = | Analyzer [@@deriving eq] -module Warning = +module Category = struct - type t = warning [@@deriving eq] + type t = category [@@deriving eq] let hash x = Hashtbl.hash x (* nested variants, so this is fine *) @@ -43,30 +43,30 @@ struct struct type t = behavior - let create (e: t): warning = Behavior e - let undefined e: warning = create @@ Undefined e - let implementation (): warning = create @@ Implementation - let machine (): warning = create @@ Machine + let create (e: t): category = Behavior e + let undefined e: category = create @@ Undefined e + let implementation (): category = create @@ Implementation + let machine (): category = create @@ Machine module Undefined = struct type t = undefined_behavior - let create (e: t): warning = undefined e - let array_out_of_bounds e: warning = create @@ ArrayOutOfBounds e - let nullpointer_dereference (): warning = create @@ NullPointerDereference - let use_after_free (): warning = create @@ UseAfterFree + let create (e: t): category = undefined e + let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e + let nullpointer_dereference (): category = create @@ NullPointerDereference + let use_after_free (): category = create @@ UseAfterFree module ArrayOutOfBounds = struct type t = array_oob - let create (e: t): warning = array_out_of_bounds e - let past_end (): warning = create PastEnd - let before_start (): warning = create BeforeStart - let unknown (): warning = create Unknown + let create (e: t): category = array_out_of_bounds e + let past_end (): category = create PastEnd + let before_start (): category = create BeforeStart + let unknown (): category = create Unknown - let from_string_list (s: string list): warning = + let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> match h with @@ -82,7 +82,7 @@ struct | Unknown -> "Unknown]" ^ " Not enough information about index." end - let from_string_list (s: string list): warning = + let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> match h with @@ -98,7 +98,7 @@ struct | UseAfterFree -> "UseAfterFree]" end - let from_string_list (s: string list): warning = + let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> ();match h with @@ -118,11 +118,11 @@ struct struct type t = integer - let create (e: t): warning = Integer e - let overflow (): warning = create Overflow - let div_by_zero (): warning = create DivByZero + let create (e: t): category = Integer e + let overflow (): category = create Overflow + let div_by_zero (): category = create DivByZero - let from_string_list (s: string list): warning = + let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> ();match h with @@ -140,10 +140,10 @@ struct struct type t = cast - let create (e: t): warning = Cast e - let type_mismatch (): warning = create TypeMismatch + let create (e: t): category = Cast e + let type_mismatch (): category = create TypeMismatch - let from_string_list (s: string list): warning = + let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> ();match h with @@ -255,19 +255,19 @@ end module Message = struct type t = { - warn_type: Warning.t; (* TODO: make list of tags *) + category: Category.t; (* TODO: make list of tags *) severity: Severity.t; multipiece: MultiPiece.t; } [@@deriving eq] - let should_warn {warn_type; severity; _} = - Warning.should_warn warn_type && Severity.should_warn severity + let should_warn {category; severity; _} = + Category.should_warn category && Severity.should_warn severity - let hash {warn_type; severity; multipiece} = - 3 * Warning.hash warn_type + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity + let hash {category; severity; multipiece} = + 3 * Category.hash category + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity - let show {warn_type; severity; multipiece} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Warning.show warn_type)^" "^ MultiPiece.show multipiece in + let show {category; severity; multipiece} = + let msg = "[" ^ Severity.show severity ^ "]" ^ (Category.show category)^" "^ MultiPiece.show multipiece in msg end @@ -328,7 +328,7 @@ let print ?(out= !warn_out) (m: Message.t) = | Debug -> "{white}" (* non-bright white is actually some gray *) | Success -> "{green}" in - let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Warning.show m.warn_type in + let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Category.show m.category in match m.multipiece with | Single piece -> Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ show_piece piece) @@ -347,7 +347,7 @@ let add m = (** Adapts old [print_group] to new message structure. Don't use for new (group) warnings. *) let warn_group_old group_name errors = - let m = Message.{warn_type = Unknown; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in + let m = Message.{category = Unknown; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in add m; if (get_bool "ana.osek.warnfiles") then @@ -363,11 +363,11 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg severity ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} +let msg severity ?(category=Unknown) text = + add {category; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} -let msg_each severity ?loc:(loc= !Tracing.current_loc) ?warning:(warning=Unknown) text = - add {warn_type = warning; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} +let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(category=Unknown) text = + add {category; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning let warn_each = msg_each Warning From eab6bbb0f581c0bacf65c9b89ab1b1c5b880906b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 11:50:54 +0300 Subject: [PATCH 51/95] Move message category definitions to separate file --- src/util/messageCategory.ml | 190 ++++++++++++++++++++++++++++++++++++ src/util/messages.ml | 189 +---------------------------------- 2 files changed, 191 insertions(+), 188 deletions(-) diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index e69de29bb2..bcf942e1ca 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -0,0 +1,190 @@ +open GobConfig + +type array_oob = + | PastEnd + | BeforeStart + | Unknown + [@@deriving eq] + +type undefined_behavior = + | ArrayOutOfBounds of array_oob + | NullPointerDereference + | UseAfterFree + [@@deriving eq] + +type behavior = + | Undefined of undefined_behavior + | Implementation + | Machine + [@@deriving eq] + +type integer = Overflow | DivByZero [@@deriving eq] + +type cast = TypeMismatch [@@deriving eq] + +type category = + | Assert + | Behavior of behavior + | Integer of integer + | Race + | Cast of cast + | Unknown + | Analyzer + [@@deriving eq] + +module Category = +struct + type t = category [@@deriving eq] + + let hash x = Hashtbl.hash x (* nested variants, so this is fine *) + + module Behavior = + struct + type t = behavior + + let create (e: t): category = Behavior e + let undefined e: category = create @@ Undefined e + let implementation (): category = create @@ Implementation + let machine (): category = create @@ Machine + + module Undefined = + struct + type t = undefined_behavior + + let create (e: t): category = undefined e + let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e + let nullpointer_dereference (): category = create @@ NullPointerDereference + let use_after_free (): category = create @@ UseAfterFree + + module ArrayOutOfBounds = + struct + type t = array_oob + + let create (e: t): category = array_out_of_bounds e + let past_end (): category = create PastEnd + let before_start (): category = create BeforeStart + let unknown (): category = create Unknown + + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> match h with + | "past_end" -> past_end () + | "before_start" -> before_start () + | "unknown" -> unknown () + | _ -> Unknown + + let show (e: t): string = + match e with + | PastEnd -> "PastEnd]" ^ " Index is past the end of the array." + | BeforeStart -> "BeforeStart]" ^ " Index is before start of the array." + | Unknown -> "Unknown]" ^ " Not enough information about index." + end + + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> match h with + | "array_out_of_bounds" -> ArrayOutOfBounds.from_string_list t + | "nullpointer_dereference" -> nullpointer_dereference () + | "use_after_free" -> use_after_free () + | _ -> Unknown + + let show (e: t): string = + match e with + | ArrayOutOfBounds e -> "ArrayOutOfBounds > "^(ArrayOutOfBounds.show e) + | NullPointerDereference -> "NullPointerDereference]" + | UseAfterFree -> "UseAfterFree]" + end + + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> ();match h with + | "undefined" -> Undefined.from_string_list t + | "implementation" -> implementation () + | "machine" -> machine () + | _ -> Unknown + + let show (e: t): string = + match e with + | Undefined u -> "Undefined > "^(Undefined.show u) + | Implementation -> "Implementation > " + | Machine -> "Machine > " + end + + module Integer = + struct + type t = integer + + let create (e: t): category = Integer e + let overflow (): category = create Overflow + let div_by_zero (): category = create DivByZero + + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> ();match h with + | "overflow" -> overflow () + | "div_by_zero" -> div_by_zero () + | _ -> Unknown + + let show (e: t): string = + match e with + | Overflow -> "Overflow]" + | DivByZero -> "DivByZero]" + end + + module Cast = + struct + type t = cast + + let create (e: t): category = Cast e + let type_mismatch (): category = create TypeMismatch + + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> ();match h with + | "type_mismatch" -> type_mismatch () + | _ -> Unknown + + let show (e: t): string = + match e with + | TypeMismatch -> "TypeMismatch]" + end + + let should_warn e = + let to_string e = + match e with + | Assert -> "assert" + | Behavior _ -> "behavior" + | Integer _ -> "integer" + | Race -> "race" + | Cast _ -> "cast" + | Unknown -> "unknown" + | Analyzer -> "analyzer" + in get_bool ("warn." ^ (to_string e)) + + let show e = + match e with + | Assert -> "[Assert]" + | Behavior x -> "[Behavior > " ^ (Behavior.show x) + | Integer x -> "[Integer > " ^ (Integer.show x) + | Race -> "[Race]" + | Cast x -> "[Cast > " ^ (Cast.show x) + | Unknown -> "[Unknown]" + | Analyzer -> "[Analyzer]" + + let from_string_list (s: string list) = + match s with + | [] -> Unknown + | h :: t -> match h with + | "assert" -> Assert + | "behavior" -> Behavior.from_string_list t + | "integer" -> Integer.from_string_list t + | "race" -> Race + | "cast" -> Cast.from_string_list t + | "analyzer" -> Analyzer + | _ -> Unknown +end diff --git a/src/util/messages.ml b/src/util/messages.ml index 5bff20a385..2d10eaf796 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -1,194 +1,7 @@ open GobConfig module GU = Goblintutil -type array_oob = - | PastEnd - | BeforeStart - | Unknown - [@@deriving eq] - -type undefined_behavior = - | ArrayOutOfBounds of array_oob - | NullPointerDereference - | UseAfterFree - [@@deriving eq] - -type behavior = - | Undefined of undefined_behavior - | Implementation - | Machine - [@@deriving eq] - -type integer = Overflow | DivByZero [@@deriving eq] - -type cast = TypeMismatch [@@deriving eq] - -type category = - | Assert - | Behavior of behavior - | Integer of integer - | Race - | Cast of cast - | Unknown - | Analyzer - [@@deriving eq] - -module Category = -struct - type t = category [@@deriving eq] - - let hash x = Hashtbl.hash x (* nested variants, so this is fine *) - - module Behavior = - struct - type t = behavior - - let create (e: t): category = Behavior e - let undefined e: category = create @@ Undefined e - let implementation (): category = create @@ Implementation - let machine (): category = create @@ Machine - - module Undefined = - struct - type t = undefined_behavior - - let create (e: t): category = undefined e - let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e - let nullpointer_dereference (): category = create @@ NullPointerDereference - let use_after_free (): category = create @@ UseAfterFree - - module ArrayOutOfBounds = - struct - type t = array_oob - - let create (e: t): category = array_out_of_bounds e - let past_end (): category = create PastEnd - let before_start (): category = create BeforeStart - let unknown (): category = create Unknown - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> match h with - | "past_end" -> past_end () - | "before_start" -> before_start () - | "unknown" -> unknown () - | _ -> Unknown - - let show (e: t): string = - match e with - | PastEnd -> "PastEnd]" ^ " Index is past the end of the array." - | BeforeStart -> "BeforeStart]" ^ " Index is before start of the array." - | Unknown -> "Unknown]" ^ " Not enough information about index." - end - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> match h with - | "array_out_of_bounds" -> ArrayOutOfBounds.from_string_list t - | "nullpointer_dereference" -> nullpointer_dereference () - | "use_after_free" -> use_after_free () - | _ -> Unknown - - let show (e: t): string = - match e with - | ArrayOutOfBounds e -> "ArrayOutOfBounds > "^(ArrayOutOfBounds.show e) - | NullPointerDereference -> "NullPointerDereference]" - | UseAfterFree -> "UseAfterFree]" - end - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> ();match h with - | "undefined" -> Undefined.from_string_list t - | "implementation" -> implementation () - | "machine" -> machine () - | _ -> Unknown - - let show (e: t): string = - match e with - | Undefined u -> "Undefined > "^(Undefined.show u) - | Implementation -> "Implementation > " - | Machine -> "Machine > " - end - - module Integer = - struct - type t = integer - - let create (e: t): category = Integer e - let overflow (): category = create Overflow - let div_by_zero (): category = create DivByZero - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> ();match h with - | "overflow" -> overflow () - | "div_by_zero" -> div_by_zero () - | _ -> Unknown - - let show (e: t): string = - match e with - | Overflow -> "Overflow]" - | DivByZero -> "DivByZero]" - end - - module Cast = - struct - type t = cast - - let create (e: t): category = Cast e - let type_mismatch (): category = create TypeMismatch - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> ();match h with - | "type_mismatch" -> type_mismatch () - | _ -> Unknown - - let show (e: t): string = - match e with - | TypeMismatch -> "TypeMismatch]" - end - - let should_warn e = - let to_string e = - match e with - | Assert -> "assert" - | Behavior _ -> "behavior" - | Integer _ -> "integer" - | Race -> "race" - | Cast _ -> "cast" - | Unknown -> "unknown" - | Analyzer -> "analyzer" - in get_bool ("warn." ^ (to_string e)) - - let show e = - match e with - | Assert -> "[Assert]" - | Behavior x -> "[Behavior > " ^ (Behavior.show x) - | Integer x -> "[Integer > " ^ (Integer.show x) - | Race -> "[Race]" - | Cast x -> "[Cast > " ^ (Cast.show x) - | Unknown -> "[Unknown]" - | Analyzer -> "[Analyzer]" - - let from_string_list (s: string list) = - match s with - | [] -> Unknown - | h :: t -> match h with - | "assert" -> Assert - | "behavior" -> Behavior.from_string_list t - | "integer" -> Integer.from_string_list t - | "race" -> Race - | "cast" -> Cast.from_string_list t - | "analyzer" -> Analyzer - | _ -> Unknown -end +include MessageCategory module Severity = From 935e722d3c213520f1272bb64c0142f5532836b9 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 11:54:09 +0300 Subject: [PATCH 52/95] Remove unnecessary wrapper module in MessageCategory --- src/analyses/base.ml | 8 +- src/cdomains/containDomain.ml | 2 +- src/util/messageCategory.ml | 231 +++++++++++++++++----------------- src/util/messages.ml | 6 +- 4 files changed, 122 insertions(+), 125 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 8355f8cafc..33c1a7cb23 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1965,16 +1965,16 @@ struct in match check_assert e ctx.local with | `Lifted false -> - warn (M.error_each ~category:M.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); + warn (M.error_each ~category:M.Category.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn (M.success_each ~category:M.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); + warn (M.success_each ~category:M.Category.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.error_each ~category:M.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error_each ~category:M.Category.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn (M.warn_each ~category:M.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); + warn (M.warn_each ~category:M.Category.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 043d58cf45..edb1020a6b 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -262,7 +262,7 @@ struct let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~category:Messages.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) + Messages.warn_each ~category:Messages.Category.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index bcf942e1ca..594e5e3b39 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -32,159 +32,156 @@ type category = | Analyzer [@@deriving eq] -module Category = +type t = category [@@deriving eq] + +let hash x = Hashtbl.hash x (* nested variants, so this is fine *) + +module Behavior = struct - type t = category [@@deriving eq] + type t = behavior - let hash x = Hashtbl.hash x (* nested variants, so this is fine *) + let create (e: t): category = Behavior e + let undefined e: category = create @@ Undefined e + let implementation (): category = create @@ Implementation + let machine (): category = create @@ Machine - module Behavior = + module Undefined = struct - type t = behavior + type t = undefined_behavior - let create (e: t): category = Behavior e - let undefined e: category = create @@ Undefined e - let implementation (): category = create @@ Implementation - let machine (): category = create @@ Machine + let create (e: t): category = undefined e + let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e + let nullpointer_dereference (): category = create @@ NullPointerDereference + let use_after_free (): category = create @@ UseAfterFree - module Undefined = + module ArrayOutOfBounds = struct - type t = undefined_behavior - - let create (e: t): category = undefined e - let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e - let nullpointer_dereference (): category = create @@ NullPointerDereference - let use_after_free (): category = create @@ UseAfterFree - - module ArrayOutOfBounds = - struct - type t = array_oob - - let create (e: t): category = array_out_of_bounds e - let past_end (): category = create PastEnd - let before_start (): category = create BeforeStart - let unknown (): category = create Unknown - - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> match h with - | "past_end" -> past_end () - | "before_start" -> before_start () - | "unknown" -> unknown () - | _ -> Unknown - - let show (e: t): string = - match e with - | PastEnd -> "PastEnd]" ^ " Index is past the end of the array." - | BeforeStart -> "BeforeStart]" ^ " Index is before start of the array." - | Unknown -> "Unknown]" ^ " Not enough information about index." - end + type t = array_oob + + let create (e: t): category = array_out_of_bounds e + let past_end (): category = create PastEnd + let before_start (): category = create BeforeStart + let unknown (): category = create Unknown let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> match h with - | "array_out_of_bounds" -> ArrayOutOfBounds.from_string_list t - | "nullpointer_dereference" -> nullpointer_dereference () - | "use_after_free" -> use_after_free () + | "past_end" -> past_end () + | "before_start" -> before_start () + | "unknown" -> unknown () | _ -> Unknown let show (e: t): string = match e with - | ArrayOutOfBounds e -> "ArrayOutOfBounds > "^(ArrayOutOfBounds.show e) - | NullPointerDereference -> "NullPointerDereference]" - | UseAfterFree -> "UseAfterFree]" + | PastEnd -> "PastEnd]" ^ " Index is past the end of the array." + | BeforeStart -> "BeforeStart]" ^ " Index is before start of the array." + | Unknown -> "Unknown]" ^ " Not enough information about index." end let from_string_list (s: string list): category = match s with | [] -> Unknown - | h :: t -> ();match h with - | "undefined" -> Undefined.from_string_list t - | "implementation" -> implementation () - | "machine" -> machine () + | h :: t -> match h with + | "array_out_of_bounds" -> ArrayOutOfBounds.from_string_list t + | "nullpointer_dereference" -> nullpointer_dereference () + | "use_after_free" -> use_after_free () | _ -> Unknown let show (e: t): string = match e with - | Undefined u -> "Undefined > "^(Undefined.show u) - | Implementation -> "Implementation > " - | Machine -> "Machine > " + | ArrayOutOfBounds e -> "ArrayOutOfBounds > "^(ArrayOutOfBounds.show e) + | NullPointerDereference -> "NullPointerDereference]" + | UseAfterFree -> "UseAfterFree]" end - module Integer = - struct - type t = integer + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> ();match h with + | "undefined" -> Undefined.from_string_list t + | "implementation" -> implementation () + | "machine" -> machine () + | _ -> Unknown - let create (e: t): category = Integer e - let overflow (): category = create Overflow - let div_by_zero (): category = create DivByZero + let show (e: t): string = + match e with + | Undefined u -> "Undefined > "^(Undefined.show u) + | Implementation -> "Implementation > " + | Machine -> "Machine > " +end - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> ();match h with - | "overflow" -> overflow () - | "div_by_zero" -> div_by_zero () - | _ -> Unknown +module Integer = +struct + type t = integer - let show (e: t): string = - match e with - | Overflow -> "Overflow]" - | DivByZero -> "DivByZero]" - end + let create (e: t): category = Integer e + let overflow (): category = create Overflow + let div_by_zero (): category = create DivByZero - module Cast = - struct - type t = cast + let from_string_list (s: string list): category = + match s with + | [] -> Unknown + | h :: t -> ();match h with + | "overflow" -> overflow () + | "div_by_zero" -> div_by_zero () + | _ -> Unknown - let create (e: t): category = Cast e - let type_mismatch (): category = create TypeMismatch + let show (e: t): string = + match e with + | Overflow -> "Overflow]" + | DivByZero -> "DivByZero]" +end - let from_string_list (s: string list): category = - match s with - | [] -> Unknown - | h :: t -> ();match h with - | "type_mismatch" -> type_mismatch () - | _ -> Unknown +module Cast = +struct + type t = cast - let show (e: t): string = - match e with - | TypeMismatch -> "TypeMismatch]" - end + let create (e: t): category = Cast e + let type_mismatch (): category = create TypeMismatch - let should_warn e = - let to_string e = - match e with - | Assert -> "assert" - | Behavior _ -> "behavior" - | Integer _ -> "integer" - | Race -> "race" - | Cast _ -> "cast" - | Unknown -> "unknown" - | Analyzer -> "analyzer" - in get_bool ("warn." ^ (to_string e)) - - let show e = - match e with - | Assert -> "[Assert]" - | Behavior x -> "[Behavior > " ^ (Behavior.show x) - | Integer x -> "[Integer > " ^ (Integer.show x) - | Race -> "[Race]" - | Cast x -> "[Cast > " ^ (Cast.show x) - | Unknown -> "[Unknown]" - | Analyzer -> "[Analyzer]" - - let from_string_list (s: string list) = + let from_string_list (s: string list): category = match s with | [] -> Unknown - | h :: t -> match h with - | "assert" -> Assert - | "behavior" -> Behavior.from_string_list t - | "integer" -> Integer.from_string_list t - | "race" -> Race - | "cast" -> Cast.from_string_list t - | "analyzer" -> Analyzer + | h :: t -> ();match h with + | "type_mismatch" -> type_mismatch () | _ -> Unknown + + let show (e: t): string = + match e with + | TypeMismatch -> "TypeMismatch]" end + +let should_warn e = + let to_string e = + match e with + | Assert -> "assert" + | Behavior _ -> "behavior" + | Integer _ -> "integer" + | Race -> "race" + | Cast _ -> "cast" + | Unknown -> "unknown" + | Analyzer -> "analyzer" + in get_bool ("warn." ^ (to_string e)) + +let show e = + match e with + | Assert -> "[Assert]" + | Behavior x -> "[Behavior > " ^ (Behavior.show x) + | Integer x -> "[Integer > " ^ (Integer.show x) + | Race -> "[Race]" + | Cast x -> "[Cast > " ^ (Cast.show x) + | Unknown -> "[Unknown]" + | Analyzer -> "[Analyzer]" + +let from_string_list (s: string list) = + match s with + | [] -> Unknown + | h :: t -> match h with + | "assert" -> Assert + | "behavior" -> Behavior.from_string_list t + | "integer" -> Integer.from_string_list t + | "race" -> Race + | "cast" -> Cast.from_string_list t + | "analyzer" -> Analyzer + | _ -> Unknown diff --git a/src/util/messages.ml b/src/util/messages.ml index 2d10eaf796..a242cd5c0a 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -1,7 +1,7 @@ open GobConfig module GU = Goblintutil -include MessageCategory +module Category = MessageCategory module Severity = @@ -176,10 +176,10 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg severity ?(category=Unknown) text = +let msg severity ?(category=Category.Unknown) text = add {category; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} -let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(category=Unknown) text = +let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(category=Category.Unknown) text = add {category; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning From 52eb20bb457c9b55d7bba6be4af005ccfad370b4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 12:02:36 +0300 Subject: [PATCH 53/95] Replace message category with list of tags --- src/util/messages.ml | 49 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 38 insertions(+), 11 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index a242cd5c0a..a19668e7a2 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -65,22 +65,49 @@ struct List.fold_left (fun acc piece -> acc ^ "\n " ^ Piece.show piece) group_text pieces end +module Tag = +struct + type t = + | Category of Category.t + [@@deriving eq] + + let hash = function + | Category category -> Category.hash category + + let show = function + | Category category -> Category.show category + + let should_warn = function + | Category category -> Category.should_warn category +end + +module Tags = +struct + type t = Tag.t list [@@deriving eq] + + let hash tags = List.fold_left (fun xs x -> xs + Tag.hash x) 996699 tags (* copied from Printable.Liszt *) + + let show tags = List.fold_left (fun acc tag -> acc ^ Tag.show tag) "" tags + + let should_warn tags = List.exists Tag.should_warn tags +end + module Message = struct type t = { - category: Category.t; (* TODO: make list of tags *) + tags: Tags.t; severity: Severity.t; multipiece: MultiPiece.t; } [@@deriving eq] - let should_warn {category; severity; _} = - Category.should_warn category && Severity.should_warn severity + let should_warn {tags; severity; _} = + Tags.should_warn tags && Severity.should_warn severity - let hash {category; severity; multipiece} = - 3 * Category.hash category + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity + let hash {tags; severity; multipiece} = + 3 * Tags.hash tags + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity - let show {category; severity; multipiece} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Category.show category)^" "^ MultiPiece.show multipiece in + let show {tags; severity; multipiece} = + let msg = "[" ^ Severity.show severity ^ "]" ^ (Tags.show tags)^" "^ MultiPiece.show multipiece in msg end @@ -141,7 +168,7 @@ let print ?(out= !warn_out) (m: Message.t) = | Debug -> "{white}" (* non-bright white is actually some gray *) | Success -> "{green}" in - let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Category.show m.category in + let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Tags.show m.tags in match m.multipiece with | Single piece -> Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ show_piece piece) @@ -160,7 +187,7 @@ let add m = (** Adapts old [print_group] to new message structure. Don't use for new (group) warnings. *) let warn_group_old group_name errors = - let m = Message.{category = Unknown; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in + let m = Message.{tags = [Category Unknown]; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in add m; if (get_bool "ana.osek.warnfiles") then @@ -177,10 +204,10 @@ let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) conte let msg severity ?(category=Category.Unknown) text = - add {category; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} + add {tags = [Category category]; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(category=Category.Unknown) text = - add {category; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} + add {tags = [Category category]; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning let warn_each = msg_each Warning From 8c87f204573f119d8f2425e5b3c64a16370f823d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 12:05:18 +0300 Subject: [PATCH 54/95] Add CWE tag for messages --- src/util/messages.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/util/messages.ml b/src/util/messages.ml index a19668e7a2..4278e325d7 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -69,16 +69,20 @@ module Tag = struct type t = | Category of Category.t + | CWE of int [@@deriving eq] let hash = function | Category category -> Category.hash category + | CWE n -> n let show = function | Category category -> Category.show category + | CWE n -> "CWE-" ^ string_of_int n let should_warn = function | Category category -> Category.should_warn category + | CWE _ -> false (* TODO: options for CWEs? *) end module Tags = From 0e558645f36dc81a934ee1f85d7c68435f6b5fa9 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 12:12:05 +0300 Subject: [PATCH 55/95] Add CWE tag to integer overflow --- src/cdomains/intDomain.ml | 6 ++++-- src/util/messages.ml | 10 +++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 1a32d3cc1b..38b3807ca2 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -537,8 +537,10 @@ struct if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq let set_overflow_flag ik = - if Cil.isSigned ik && !GU.in_verifying_stage then - Goblintutil.did_overflow := true + if Cil.isSigned ik && !GU.in_verifying_stage then ( + Goblintutil.did_overflow := true; + M.warn ~category:(M.Category.Integer.overflow ()) ~tags:[M.Tag.CWE 190] "Integer overflow" + ) let norm ik = function None -> None | Some (x,y) -> if Ints_t.compare x y > 0 then None diff --git a/src/util/messages.ml b/src/util/messages.ml index 4278e325d7..6202aa62c7 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -78,7 +78,7 @@ struct let show = function | Category category -> Category.show category - | CWE n -> "CWE-" ^ string_of_int n + | CWE n -> "[CWE-" ^ string_of_int n ^ "]" let should_warn = function | Category category -> Category.should_warn category @@ -207,11 +207,11 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg severity ?(category=Category.Unknown) text = - add {tags = [Category category]; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} +let msg severity ?(tags=[]) ?(category=Category.Unknown) text = + add {tags = Category category :: tags; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} -let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(category=Category.Unknown) text = - add {tags = [Category category]; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} +let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) text = + add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} let warn = msg Warning let warn_each = msg_each Warning From 59fa71fa24dcfd0ef5879118ffdafe6d2bc02e7d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 12:13:42 +0300 Subject: [PATCH 56/95] Add CWE tag to NULL pointer dereference --- src/analyses/base.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 33c1a7cb23..cdfb9815c6 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -803,9 +803,9 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) "Must dereference NULL pointer" + then M.error_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) ~tags:[M.Tag.CWE 476] "Must dereference NULL pointer" else if AD.may_be_null adr - then M.warn_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) "May dereference NULL pointer"); + then M.warn_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) ~tags:[M.Tag.CWE 476] "May dereference NULL pointer"); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in From 3c75f8733c02d5be9a8169cd4b3b1c5788bf46fe Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 13:46:35 +0300 Subject: [PATCH 57/95] Use Format for printing messages --- src/util/messages.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 6202aa62c7..13fec78f0d 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -162,9 +162,6 @@ let colorize ?on:(on=colors_on ()) msg = let print ?(out= !warn_out) (m: Message.t) = - let show_piece piece = - Piece.show piece ^ " {violet}(" ^ CilType.Location.show piece.print_loc ^ ")" - in let severity_color = match m.severity with | Error -> "{red}" | Warning -> "{yellow}" @@ -172,12 +169,16 @@ let print ?(out= !warn_out) (m: Message.t) = | Debug -> "{white}" (* non-bright white is actually some gray *) | Success -> "{green}" in - let prefix = severity_color ^ "[" ^ Severity.show m.severity ^ "]" ^ Tags.show m.tags in + let ppf = Format.formatter_of_out_channel out in + let prefix = Format.dprintf "%s[%s]%s" severity_color (Severity.show m.severity) (Tags.show m.tags) in + let show_piece ppf piece = + Format.fprintf ppf "%s {violet}(%s)" (Piece.show piece) (CilType.Location.show piece.print_loc) + in match m.multipiece with | Single piece -> - Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ show_piece piece) + Format.fprintf ppf "%t %a\n%!" prefix show_piece piece | Group {group_text; pieces} -> - Printf.fprintf out "%s\n%!" (colorize @@ prefix ^ " " ^ List.fold_left (fun acc piece -> acc ^ "\n " ^ severity_color ^ show_piece piece) (group_text ^ ":") pieces) + Format.fprintf ppf "@[%t %s:@,@[%a@]@]\n%!" prefix group_text (Format.pp_print_list show_piece) pieces let add m = if !GU.should_warn then ( From 4ceddf47812dd253fbb2eef36d45977b5d19ce9b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 14:01:16 +0300 Subject: [PATCH 58/95] Add terminal output colors to Format --- src/util/messages.ml | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 13fec78f0d..ad931c46d0 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -162,23 +162,41 @@ let colorize ?on:(on=colors_on ()) msg = let print ?(out= !warn_out) (m: Message.t) = - let severity_color = match m.severity with - | Error -> "{red}" - | Warning -> "{yellow}" - | Info -> "{blue}" - | Debug -> "{white}" (* non-bright white is actually some gray *) - | Success -> "{green}" + let severity_stag = match m.severity with + | Error -> "red" + | Warning -> "yellow" + | Info -> "blue" + | Debug -> "white" (* non-bright white is actually some gray *) + | Success -> "green" in let ppf = Format.formatter_of_out_channel out in - let prefix = Format.dprintf "%s[%s]%s" severity_color (Severity.show m.severity) (Tags.show m.tags) in + let stag_functions = Format.pp_get_formatter_stag_functions ppf () in + let stag_functions' = {stag_functions with + mark_open_stag = (function + | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31" + | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33" + | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34" + | Format.String_tag "white" -> Format.sprintf "\027[%sm" "0;37" + | Format.String_tag "green" -> Format.sprintf "\027[%sm" "0;32" + | Format.String_tag "violet" -> Format.sprintf "\027[%sm" "0;35" + | Format.String_tag s -> Format.sprintf "{%s}" s + | _ -> ""); + mark_close_stag = (function + | Format.String_tag _ -> "\027[0m" + | _ -> ""); + } + in + Format.pp_set_formatter_stag_functions ppf stag_functions'; + Format.pp_set_mark_tags ppf true; + let prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in let show_piece ppf piece = - Format.fprintf ppf "%s {violet}(%s)" (Piece.show piece) (CilType.Location.show piece.print_loc) + Format.fprintf ppf "@{<%s>%s@} @{(%s)@}" severity_stag (Piece.show piece) (CilType.Location.show piece.print_loc) in match m.multipiece with | Single piece -> Format.fprintf ppf "%t %a\n%!" prefix show_piece piece | Group {group_text; pieces} -> - Format.fprintf ppf "@[%t %s:@,@[%a@]@]\n%!" prefix group_text (Format.pp_print_list show_piece) pieces + Format.fprintf ppf "@[%t @{<%s>%s@}:@,@[%a@]@]\n%!" prefix severity_stag group_text (Format.pp_print_list show_piece) pieces let add m = if !GU.should_warn then ( From 48ea43eda686b3c1a33ba2598a5d7018c48f69bf Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 14:09:13 +0300 Subject: [PATCH 59/95] Refactor message Format logic --- src/util/messages.ml | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index ad931c46d0..d8741896a4 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -170,9 +170,11 @@ let print ?(out= !warn_out) (m: Message.t) = | Success -> "green" in let ppf = Format.formatter_of_out_channel out in + (* TODO: extract this elsewhere *) let stag_functions = Format.pp_get_formatter_stag_functions ppf () in let stag_functions' = {stag_functions with mark_open_stag = (function + (* TODO: support all colors like colorize *) | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31" | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33" | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34" @@ -188,15 +190,18 @@ let print ?(out= !warn_out) (m: Message.t) = in Format.pp_set_formatter_stag_functions ppf stag_functions'; Format.pp_set_mark_tags ppf true; - let prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in - let show_piece ppf piece = + let pp_prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in + let pp_piece ppf piece = Format.fprintf ppf "@{<%s>%s@} @{(%s)@}" severity_stag (Piece.show piece) (CilType.Location.show piece.print_loc) in - match m.multipiece with - | Single piece -> - Format.fprintf ppf "%t %a\n%!" prefix show_piece piece - | Group {group_text; pieces} -> - Format.fprintf ppf "@[%t @{<%s>%s@}:@,@[%a@]@]\n%!" prefix severity_stag group_text (Format.pp_print_list show_piece) pieces + let pp_multipiece ppf = match m.multipiece with + | Single piece -> + pp_piece ppf piece + | Group {group_text; pieces} -> + Format.fprintf ppf "@{<%s>%s:@}@,@[%a@]" severity_stag group_text (Format.pp_print_list pp_piece) pieces + in + Format.fprintf ppf "@[%t %t@]\n%!" pp_prefix pp_multipiece + let add m = if !GU.should_warn then ( From c161068eaa5efa6ef93e2e82aa102695380d27ad Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:03:12 +0300 Subject: [PATCH 60/95] Move Messages.colorize to MessageUtil --- src/maingoblint.ml | 6 +++--- src/util/arincUtil.ml | 2 +- src/util/messageUtil.ml | 15 +++++++++++++++ src/util/messages.ml | 14 +------------- 4 files changed, 20 insertions(+), 17 deletions(-) create mode 100644 src/util/messageUtil.ml diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 7a19264f11..ce84eb920a 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -358,7 +358,7 @@ let do_html_output () = ) let check_arguments () = - let eprint_color m = eprintf "%s\n" (Messages.colorize m) in + let eprint_color m = eprintf "%s\n" (MessageUtil.colorize m) in let fail m = let m = "Option failure: " ^ m in eprint_color ("{red}"^m); failwith m in let warn m = eprint_color ("{yellow}Option warning: "^m) in let partial_context = get_bool "exp.addr-context" || get_bool "exp.no-int-context" || get_bool "exp.no-interval-context" in @@ -469,10 +469,10 @@ let main () = exit 1 | Sys.Break -> (* raised on Ctrl-C if `Sys.catch_break true` *) (* Printexc.print_backtrace BatInnerIO.stderr *) - eprintf "%s\n" (Messages.colorize ("{RED}Analysis was aborted by SIGINT (Ctrl-C)!")); + eprintf "%s\n" (MessageUtil.colorize ("{RED}Analysis was aborted by SIGINT (Ctrl-C)!")); exit 131 (* same exit code as without `Sys.catch_break true`, otherwise 0 *) | Timeout -> - eprintf "%s\n" (Messages.colorize ("{RED}Analysis was aborted because it reached the set timeout of " ^ get_string "dbg.timeout" ^ " or was signalled SIGPROF!")); + eprintf "%s\n" (MessageUtil.colorize ("{RED}Analysis was aborted because it reached the set timeout of " ^ get_string "dbg.timeout" ^ " or was signalled SIGPROF!")); exit 124 (* The actual entry point is in the auto-generated goblint.ml module, and is defined as: *) diff --git a/src/util/arincUtil.ml b/src/util/arincUtil.ml index 5d12148488..3fa1377103 100644 --- a/src/util/arincUtil.ml +++ b/src/util/arincUtil.ml @@ -1,7 +1,7 @@ open Prelude open Cil (* we don't want to use M.debug_each because everything here should be done after the analysis, so the location would be some old value for all invocations *) -let debug_each msg = print_endline @@ Messages.colorize @@ "{blue}"^msg +let debug_each msg = print_endline @@ MessageUtil.colorize @@ "{blue}"^msg (* ARINC types and Hashtables for collecting CFG *) type resource = Process | Function | Semaphore | Event | Logbook | SamplingPort | QueuingPort | Buffer | Blackboard [@@deriving show { with_path = false }] diff --git a/src/util/messageUtil.ml b/src/util/messageUtil.ml new file mode 100644 index 0000000000..447e7d1d4c --- /dev/null +++ b/src/util/messageUtil.ml @@ -0,0 +1,15 @@ +open GobConfig + +let colors_on () = (* use colors? *) + let c = get_string "colors" in + c = "always" || c = "auto" && Unix.(isatty stdout) + +let colorize ?on:(on=colors_on ()) msg = + let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); + ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in + let replace (color,code) = + let modes = [(fun x -> x), "0" (* normal *); String.uppercase_ascii, "1" (* bold *)] in + List.fold_right (fun (f,m) -> Str.global_replace (Str.regexp ("{"^f color^"}")) (if on then "\027["^m^";"^code^"m" else "")) modes + in + let msg = List.fold_right replace colors msg in + msg^(if on then "\027[0;0;00m" else "") (* reset at end *) diff --git a/src/util/messages.ml b/src/util/messages.ml index d8741896a4..1183e4ec44 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -146,19 +146,7 @@ let get_out name alternative = match get_string "dbg.dump" with | "" -> alternative | path -> open_out (Filename.concat path (name ^ ".out")) -let colors_on () = (* use colors? *) - let c = get_string "colors" in - c = "always" || c = "auto" && Unix.(isatty stdout) - -let colorize ?on:(on=colors_on ()) msg = - let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); - ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in - let replace (color,code) = - let modes = [(fun x -> x), "0" (* normal *); String.uppercase_ascii, "1" (* bold *)] in - List.fold_right (fun (f,m) -> Str.global_replace (Str.regexp ("{"^f color^"}")) (if on then "\027["^m^";"^code^"m" else "")) modes - in - let msg = List.fold_right replace colors msg in - msg^(if on then "\027[0;0;00m" else "") (* reset at end *) + let print ?(out= !warn_out) (m: Message.t) = From 064cd0a406f82048607f0cb1880cb0b9c39037dd Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:07:42 +0300 Subject: [PATCH 61/95] Move Format ANSI color tags to GobFormat --- src/util/gobFormat.ml | 21 +++++++++++++++++++++ src/util/messages.ml | 21 +-------------------- 2 files changed, 22 insertions(+), 20 deletions(-) create mode 100644 src/util/gobFormat.ml diff --git a/src/util/gobFormat.ml b/src/util/gobFormat.ml new file mode 100644 index 0000000000..66b5fccf24 --- /dev/null +++ b/src/util/gobFormat.ml @@ -0,0 +1,21 @@ + +let pp_set_ansi_color_tags ppf = + let stag_functions = Format.pp_get_formatter_stag_functions ppf () in + let stag_functions' = {stag_functions with + mark_open_stag = (function + (* TODO: support all colors like colorize *) + | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31" + | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33" + | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34" + | Format.String_tag "white" -> Format.sprintf "\027[%sm" "0;37" + | Format.String_tag "green" -> Format.sprintf "\027[%sm" "0;32" + | Format.String_tag "violet" -> Format.sprintf "\027[%sm" "0;35" + | Format.String_tag s -> Format.sprintf "{%s}" s + | _ -> ""); + mark_close_stag = (function + | Format.String_tag _ -> "\027[0m" + | _ -> ""); + } + in + Format.pp_set_formatter_stag_functions ppf stag_functions'; + Format.pp_set_mark_tags ppf true diff --git a/src/util/messages.ml b/src/util/messages.ml index 1183e4ec44..a8765166e7 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -158,26 +158,7 @@ let print ?(out= !warn_out) (m: Message.t) = | Success -> "green" in let ppf = Format.formatter_of_out_channel out in - (* TODO: extract this elsewhere *) - let stag_functions = Format.pp_get_formatter_stag_functions ppf () in - let stag_functions' = {stag_functions with - mark_open_stag = (function - (* TODO: support all colors like colorize *) - | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31" - | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33" - | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34" - | Format.String_tag "white" -> Format.sprintf "\027[%sm" "0;37" - | Format.String_tag "green" -> Format.sprintf "\027[%sm" "0;32" - | Format.String_tag "violet" -> Format.sprintf "\027[%sm" "0;35" - | Format.String_tag s -> Format.sprintf "{%s}" s - | _ -> ""); - mark_close_stag = (function - | Format.String_tag _ -> "\027[0m" - | _ -> ""); - } - in - Format.pp_set_formatter_stag_functions ppf stag_functions'; - Format.pp_set_mark_tags ppf true; + GobFormat.pp_set_ansi_color_tags ppf; let pp_prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in let pp_piece ppf piece = Format.fprintf ppf "@{<%s>%s@} @{(%s)@}" severity_stag (Piece.show piece) (CilType.Location.show piece.print_loc) From 9944f21f2dbd708dd94af0f26a96197d6b0aeb58 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:14:20 +0300 Subject: [PATCH 62/95] Generalize ANSI color table in MessageUtil --- src/util/messageUtil.ml | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/util/messageUtil.ml b/src/util/messageUtil.ml index 447e7d1d4c..31c9f46af7 100644 --- a/src/util/messageUtil.ml +++ b/src/util/messageUtil.ml @@ -1,15 +1,22 @@ open GobConfig +let ansi_color_table = + let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); + ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in + let modes = [(Fun.id, "0" (* normal *)); (String.uppercase_ascii, "1" (* bold *))] in + List.concat_map (fun (color, color_code) -> + List.map (fun (mode_fn, mode_code) -> + (mode_fn color, Format.sprintf "\027[%s;%sm" mode_code color_code) + ) modes + ) colors + let colors_on () = (* use colors? *) let c = get_string "colors" in c = "always" || c = "auto" && Unix.(isatty stdout) let colorize ?on:(on=colors_on ()) msg = - let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); - ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in let replace (color,code) = - let modes = [(fun x -> x), "0" (* normal *); String.uppercase_ascii, "1" (* bold *)] in - List.fold_right (fun (f,m) -> Str.global_replace (Str.regexp ("{"^f color^"}")) (if on then "\027["^m^";"^code^"m" else "")) modes + Str.global_replace (Str.regexp ("{"^color^"}")) (if on then code else "") in - let msg = List.fold_right replace colors msg in + let msg = List.fold_right replace ansi_color_table msg in msg^(if on then "\027[0;0;00m" else "") (* reset at end *) From 3515e091330ff58de99db81be1008406ab248d87 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:17:04 +0300 Subject: [PATCH 63/95] Use ANSI color table in GobFormat --- src/util/gobFormat.ml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/util/gobFormat.ml b/src/util/gobFormat.ml index 66b5fccf24..53b545fb38 100644 --- a/src/util/gobFormat.ml +++ b/src/util/gobFormat.ml @@ -1,19 +1,17 @@ let pp_set_ansi_color_tags ppf = let stag_functions = Format.pp_get_formatter_stag_functions ppf () in + let reset_code = List.assoc "reset" MessageUtil.ansi_color_table in (* assoc only once *) let stag_functions' = {stag_functions with mark_open_stag = (function - (* TODO: support all colors like colorize *) - | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31" - | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33" - | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34" - | Format.String_tag "white" -> Format.sprintf "\027[%sm" "0;37" - | Format.String_tag "green" -> Format.sprintf "\027[%sm" "0;32" - | Format.String_tag "violet" -> Format.sprintf "\027[%sm" "0;35" - | Format.String_tag s -> Format.sprintf "{%s}" s + | Format.String_tag s -> + begin match List.assoc_opt s MessageUtil.ansi_color_table with + | Some code -> code + | None -> Format.sprintf "{%s}" s + end | _ -> ""); mark_close_stag = (function - | Format.String_tag _ -> "\027[0m" + | Format.String_tag _ -> reset_code | _ -> ""); } in From 95697367109d79f4a5dcc9b15fe395c6e068dd30 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:19:09 +0300 Subject: [PATCH 64/95] Reformat GobFormat.pp_set_ansi_color_tags --- src/util/gobFormat.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/util/gobFormat.ml b/src/util/gobFormat.ml index 53b545fb38..af10bf00bf 100644 --- a/src/util/gobFormat.ml +++ b/src/util/gobFormat.ml @@ -1,19 +1,19 @@ let pp_set_ansi_color_tags ppf = let stag_functions = Format.pp_get_formatter_stag_functions ppf () in + let mark_open_stag = function + | Format.String_tag s -> + begin match List.assoc_opt s MessageUtil.ansi_color_table with + | Some code -> code + | None -> Format.sprintf "{%s}" s + end + | _ -> "" + in let reset_code = List.assoc "reset" MessageUtil.ansi_color_table in (* assoc only once *) - let stag_functions' = {stag_functions with - mark_open_stag = (function - | Format.String_tag s -> - begin match List.assoc_opt s MessageUtil.ansi_color_table with - | Some code -> code - | None -> Format.sprintf "{%s}" s - end - | _ -> ""); - mark_close_stag = (function - | Format.String_tag _ -> reset_code - | _ -> ""); - } + let mark_close_stag = function + | Format.String_tag _ -> reset_code + | _ -> "" in + let stag_functions' = {stag_functions with mark_open_stag; mark_close_stag} in Format.pp_set_formatter_stag_functions ppf stag_functions'; Format.pp_set_mark_tags ppf true From 5ee7ebb94dd170a44fe31b72b0d0c6310fbed11d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:34:34 +0300 Subject: [PATCH 65/95] Replace Messages.warn_out with formatter --- src/analyses/mCP.ml | 2 +- src/maingoblint.ml | 2 +- src/util/messages.ml | 12 ++++++++---- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/analyses/mCP.ml b/src/analyses/mCP.ml index 7ecd84c126..accf8f0d67 100644 --- a/src/analyses/mCP.ml +++ b/src/analyses/mCP.ml @@ -253,7 +253,7 @@ struct if not (exists (fun (y',_) -> y=y') xs) then begin let xn = assoc x !analyses_table in let yn = assoc y !analyses_table in - Legacy.Printf.fprintf !Messages.warn_out "Activated analysis '%s' depends on '%s' and '%s' is not activated.\n" xn yn yn; + Legacy.Printf.eprintf "Activated analysis '%s' depends on '%s' and '%s' is not activated.\n" xn yn yn; raise Exit end in diff --git a/src/maingoblint.ml b/src/maingoblint.ml index ce84eb920a..5b0fa49b88 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -141,7 +141,7 @@ let handle_flags () = match get_string "dbg.dump" with | "" -> () | path -> - Messages.warn_out := Legacy.open_out (Legacy.Filename.concat path "warnings.out"); + Messages.formatter := Format.formatter_of_out_channel (Legacy.open_out (Legacy.Filename.concat path "warnings.out")); set_string "outfile" "" (** Use gcc to preprocess a file. Returns the path to the preprocessed file. *) diff --git a/src/util/messages.ml b/src/util/messages.ml index a8765166e7..93b9116767 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -120,7 +120,12 @@ let messages_table = MH.create 113 (* messages without order for quick mem looku let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) -let warn_out = ref stdout +let formatter = ref Format.std_formatter +let () = AfterConfig.register (fun () -> + if !formatter == Format.std_formatter && MessageUtil.colors_on () then + GobFormat.pp_set_ansi_color_tags !formatter + ) + let tracing = Config.tracing let xml_file_name = ref "" @@ -149,7 +154,7 @@ let get_out name alternative = match get_string "dbg.dump" with -let print ?(out= !warn_out) (m: Message.t) = +let print ?(ppf= !formatter) (m: Message.t) = let severity_stag = match m.severity with | Error -> "red" | Warning -> "yellow" @@ -157,8 +162,6 @@ let print ?(out= !warn_out) (m: Message.t) = | Debug -> "white" (* non-bright white is actually some gray *) | Success -> "green" in - let ppf = Format.formatter_of_out_channel out in - GobFormat.pp_set_ansi_color_tags ppf; let pp_prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in let pp_piece ppf piece = Format.fprintf ppf "@{<%s>%s@} @{(%s)@}" severity_stag (Piece.show piece) (CilType.Location.show piece.print_loc) @@ -188,6 +191,7 @@ let warn_group_old group_name errors = add m; if (get_bool "ana.osek.warnfiles") then + let print ~out = print ~ppf:(Format.formatter_of_out_channel out) in match (String.sub group_name 0 6) with | "Safely" -> print ~out:!warn_safe m | "Datara" -> print ~out:!warn_race m From 5c973e5a071600a8f11f186f1acf5245377cfdcb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:38:00 +0300 Subject: [PATCH 66/95] Add pp to CilType.Location --- src/util/cilType.ml | 7 ++++++- src/util/messages.ml | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/util/cilType.ml b/src/util/cilType.ml index 35416fca80..a8f0588f11 100644 --- a/src/util/cilType.ml +++ b/src/util/cilType.ml @@ -12,7 +12,11 @@ struct include Printable.Std end -module Location: S with type t = location = +module Location: +sig + include S with type t = location + val pp: Format.formatter -> t -> unit (* for Messages *) +end = struct include Std @@ -33,6 +37,7 @@ struct let pretty () x = Pretty.text (show x) let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) let to_yojson x = `String (show x) + let pp fmt x = Format.fprintf fmt "%s" (show x) (* for Messages *) end module Varinfo: diff --git a/src/util/messages.ml b/src/util/messages.ml index 93b9116767..2bdcfe0a9e 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -164,7 +164,7 @@ let print ?(ppf= !formatter) (m: Message.t) = in let pp_prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in let pp_piece ppf piece = - Format.fprintf ppf "@{<%s>%s@} @{(%s)@}" severity_stag (Piece.show piece) (CilType.Location.show piece.print_loc) + Format.fprintf ppf "@{<%s>%s@} @{(%a)@}" severity_stag (Piece.show piece) CilType.Location.pp piece.print_loc in let pp_multipiece ppf = match m.multipiece with | Single piece -> From fe0b25137fe6b62783185e7120ec75e72b83e9ce Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 15:41:21 +0300 Subject: [PATCH 67/95] Remove unused show functions in Messages --- src/util/messages.ml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 2bdcfe0a9e..bb0b97afa4 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -58,11 +58,6 @@ struct | Single piece -> Piece.hash piece | Group {group_text; pieces} -> Hashtbl.hash group_text + 3 * (List.fold_left (fun xs x -> xs + Piece.hash x) 996699 pieces) (* copied from Printable.Liszt *) - - let show = function - | Single piece -> Piece.show piece - | Group {group_text; pieces} -> - List.fold_left (fun acc piece -> acc ^ "\n " ^ Piece.show piece) group_text pieces end module Tag = @@ -109,10 +104,6 @@ struct let hash {tags; severity; multipiece} = 3 * Tags.hash tags + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity - - let show {tags; severity; multipiece} = - let msg = "[" ^ Severity.show severity ^ "]" ^ (Tags.show tags)^" "^ MultiPiece.show multipiece in - msg end module MH = Hashtbl.Make (Message) From 48bd28a2ed6e7e8f3ffd7936511523f21133399b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 17:37:06 +0300 Subject: [PATCH 68/95] Derive to_yojson for messages --- src/util/messageCategory.ml | 14 +++++++------- src/util/messages.ml | 14 +++++++------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index 594e5e3b39..a017b79e6d 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -4,23 +4,23 @@ type array_oob = | PastEnd | BeforeStart | Unknown - [@@deriving eq] + [@@deriving eq, to_yojson] type undefined_behavior = | ArrayOutOfBounds of array_oob | NullPointerDereference | UseAfterFree - [@@deriving eq] + [@@deriving eq, to_yojson] type behavior = | Undefined of undefined_behavior | Implementation | Machine - [@@deriving eq] + [@@deriving eq, to_yojson] -type integer = Overflow | DivByZero [@@deriving eq] +type integer = Overflow | DivByZero [@@deriving eq, to_yojson] -type cast = TypeMismatch [@@deriving eq] +type cast = TypeMismatch [@@deriving eq, to_yojson] type category = | Assert @@ -30,9 +30,9 @@ type category = | Cast of cast | Unknown | Analyzer - [@@deriving eq] + [@@deriving eq, to_yojson] -type t = category [@@deriving eq] +type t = category [@@deriving eq, to_yojson] let hash x = Hashtbl.hash x (* nested variants, so this is fine *) diff --git a/src/util/messages.ml b/src/util/messages.ml index bb0b97afa4..5be1073cb8 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -12,7 +12,7 @@ struct | Info | Debug | Success - [@@deriving eq, show { with_path = false }] + [@@deriving eq, show { with_path = false }, to_yojson] let hash x = Hashtbl.hash x (* variants, so this is fine *) @@ -32,9 +32,9 @@ struct type t = { loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; - context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)]) option; (* TODO: this equality is terrible... *) + context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)] [@to_yojson fun x -> `Int (Hashtbl.hash (Obj.obj x))]) option; (* TODO: this equality is terrible... *) print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) - } [@@deriving eq] + } [@@deriving eq, to_yojson] let hash {loc; text; context; print_loc} = 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context @@ -52,7 +52,7 @@ struct type t = | Single of Piece.t | Group of {group_text: string; pieces: Piece.t list} - [@@ deriving eq] + [@@deriving eq, to_yojson] let hash = function | Single piece -> Piece.hash piece @@ -65,7 +65,7 @@ struct type t = | Category of Category.t | CWE of int - [@@deriving eq] + [@@deriving eq, to_yojson] let hash = function | Category category -> Category.hash category @@ -82,7 +82,7 @@ end module Tags = struct - type t = Tag.t list [@@deriving eq] + type t = Tag.t list [@@deriving eq, to_yojson] let hash tags = List.fold_left (fun xs x -> xs + Tag.hash x) 996699 tags (* copied from Printable.Liszt *) @@ -97,7 +97,7 @@ struct tags: Tags.t; severity: Severity.t; multipiece: MultiPiece.t; - } [@@deriving eq] + } [@@deriving eq, to_yojson] let should_warn {tags; severity; _} = Tags.should_warn tags && Severity.should_warn severity From a5e149cedbdf0abd35490391a948780d171c4931 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 17:45:07 +0300 Subject: [PATCH 69/95] Add result output json-messages --- src/framework/analyses.ml | 2 ++ src/util/defaults.ml | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index e865480a24..f3f739511d 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -253,6 +253,8 @@ struct iter insert (Lazy.force table); let t1 = Unix.gettimeofday () -. t in Printf.printf "Done in %fs!\n" t1 *) + | "json-messages" -> + Yojson.Safe.to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.messages_list) | "none" -> () | s -> failwith @@ "Unsupported value for option `result`: "^s end diff --git a/src/util/defaults.ml b/src/util/defaults.ml index d9760bd9bd..2ee80c06b2 100644 --- a/src/util/defaults.ml +++ b/src/util/defaults.ml @@ -75,7 +75,7 @@ let _ = () ; reg Std "cppflags" "''" "Pre-processing parameters." ; reg Std "kernel" "false" "For analyzing Linux Device Drivers." ; reg Std "dump_globs" "false" "Print out the global invariant." - ; reg Std "result" "'none'" "Result style: none, fast_xml, json, mongo, or pretty." + ; reg Std "result" "'none'" "Result style: none, fast_xml, json, mongo, pretty, json-messages." ; reg Std "warnstyle" "'pretty'" "Result style: legacy, pretty, or xml." ; reg Std "solver" "'td3'" "Picks the solver." ; reg Std "comparesolver" "''" "Picks another solver for comparison." From 9649d818ceea9775419e75a962b6a6b51f649245 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:04:03 +0300 Subject: [PATCH 70/95] Override message to_yojson for better structure --- src/util/cilType.ml | 6 +++++- src/util/messageCategory.ml | 16 +++++++++------- src/util/messages.ml | 17 ++++++++++++++--- 3 files changed, 28 insertions(+), 11 deletions(-) diff --git a/src/util/cilType.ml b/src/util/cilType.ml index a8f0588f11..a78e2a03af 100644 --- a/src/util/cilType.ml +++ b/src/util/cilType.ml @@ -36,7 +36,11 @@ struct let pretty () x = Pretty.text (show x) let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) - let to_yojson x = `String (show x) + let to_yojson x = `Assoc [ + ("file", `String x.file); + ("line", `Int x.line); + ("column", `Int x.column); + ] let pp fmt x = Format.fprintf fmt "%s" (show x) (* for Messages *) end diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index a017b79e6d..a8e1394eee 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -4,23 +4,23 @@ type array_oob = | PastEnd | BeforeStart | Unknown - [@@deriving eq, to_yojson] + [@@deriving eq] type undefined_behavior = | ArrayOutOfBounds of array_oob | NullPointerDereference | UseAfterFree - [@@deriving eq, to_yojson] + [@@deriving eq] type behavior = | Undefined of undefined_behavior | Implementation | Machine - [@@deriving eq, to_yojson] + [@@deriving eq] -type integer = Overflow | DivByZero [@@deriving eq, to_yojson] +type integer = Overflow | DivByZero [@@deriving eq] -type cast = TypeMismatch [@@deriving eq, to_yojson] +type cast = TypeMismatch [@@deriving eq] type category = | Assert @@ -30,9 +30,9 @@ type category = | Cast of cast | Unknown | Analyzer - [@@deriving eq, to_yojson] + [@@deriving eq] -type t = category [@@deriving eq, to_yojson] +type t = category [@@deriving eq] let hash x = Hashtbl.hash x (* nested variants, so this is fine *) @@ -185,3 +185,5 @@ let from_string_list (s: string list) = | "cast" -> Cast.from_string_list t | "analyzer" -> Analyzer | _ -> Unknown + +let to_yojson x = `String (show x) (* TODO: no brackets *) diff --git a/src/util/messages.ml b/src/util/messages.ml index 5be1073cb8..b50b111175 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -12,7 +12,7 @@ struct | Info | Debug | Success - [@@deriving eq, show { with_path = false }, to_yojson] + [@@deriving eq, show { with_path = false }] let hash x = Hashtbl.hash x (* variants, so this is fine *) @@ -25,6 +25,8 @@ struct | Success -> "success" in get_bool ("warn." ^ (to_string e)) + + let to_yojson x = `String (show x) end module Piece = @@ -49,15 +51,20 @@ end module MultiPiece = struct + type group = {group_text: string; pieces: Piece.t list} [@@deriving eq, to_yojson] type t = | Single of Piece.t - | Group of {group_text: string; pieces: Piece.t list} + | Group of group [@@deriving eq, to_yojson] let hash = function | Single piece -> Piece.hash piece | Group {group_text; pieces} -> Hashtbl.hash group_text + 3 * (List.fold_left (fun xs x -> xs + Piece.hash x) 996699 pieces) (* copied from Printable.Liszt *) + + let to_yojson = function + | Single piece -> Piece.to_yojson piece + | Group group -> group_to_yojson group end module Tag = @@ -65,7 +72,7 @@ struct type t = | Category of Category.t | CWE of int - [@@deriving eq, to_yojson] + [@@deriving eq] let hash = function | Category category -> Category.hash category @@ -78,6 +85,10 @@ struct let should_warn = function | Category category -> Category.should_warn category | CWE _ -> false (* TODO: options for CWEs? *) + + let to_yojson = function + | Category category -> `Assoc [("Category", Category.to_yojson category)] + | CWE n -> `Assoc [("CWE", `Int n)] end module Tags = From befc351f33b3c34de21813169a8e8737ba9aa5cb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:17:52 +0300 Subject: [PATCH 71/95] Remove square brackets from message category JSON --- src/util/messageCategory.ml | 54 +++++++++++++++++++------------------ src/util/messages.ml | 4 +-- 2 files changed, 30 insertions(+), 28 deletions(-) diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index a8e1394eee..6a1b7d377a 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -72,11 +72,11 @@ struct | "unknown" -> unknown () | _ -> Unknown - let show (e: t): string = + let path_show (e: t) = match e with - | PastEnd -> "PastEnd]" ^ " Index is past the end of the array." - | BeforeStart -> "BeforeStart]" ^ " Index is before start of the array." - | Unknown -> "Unknown]" ^ " Not enough information about index." + | PastEnd -> ["PastEnd"] + | BeforeStart -> ["BeforeStart"] + | Unknown -> ["Unknown"] end let from_string_list (s: string list): category = @@ -88,11 +88,11 @@ struct | "use_after_free" -> use_after_free () | _ -> Unknown - let show (e: t): string = + let path_show (e: t) = match e with - | ArrayOutOfBounds e -> "ArrayOutOfBounds > "^(ArrayOutOfBounds.show e) - | NullPointerDereference -> "NullPointerDereference]" - | UseAfterFree -> "UseAfterFree]" + | ArrayOutOfBounds e -> "ArrayOutOfBounds" :: ArrayOutOfBounds.path_show e + | NullPointerDereference -> ["NullPointerDereference"] + | UseAfterFree -> ["UseAfterFree"] end let from_string_list (s: string list): category = @@ -104,11 +104,11 @@ struct | "machine" -> machine () | _ -> Unknown - let show (e: t): string = + let path_show (e: t) = match e with - | Undefined u -> "Undefined > "^(Undefined.show u) - | Implementation -> "Implementation > " - | Machine -> "Machine > " + | Undefined u -> "Undefined" :: Undefined.path_show u + | Implementation -> ["Implementation"] + | Machine -> ["Machine"] end module Integer = @@ -127,10 +127,10 @@ struct | "div_by_zero" -> div_by_zero () | _ -> Unknown - let show (e: t): string = + let path_show (e: t) = match e with - | Overflow -> "Overflow]" - | DivByZero -> "DivByZero]" + | Overflow -> ["Overflow"] + | DivByZero -> ["DivByZero"] end module Cast = @@ -147,9 +147,9 @@ struct | "type_mismatch" -> type_mismatch () | _ -> Unknown - let show (e: t): string = + let path_show (e: t) = match e with - | TypeMismatch -> "TypeMismatch]" + | TypeMismatch -> ["TypeMismatch"] end let should_warn e = @@ -164,15 +164,17 @@ let should_warn e = | Analyzer -> "analyzer" in get_bool ("warn." ^ (to_string e)) -let show e = +let path_show e = match e with - | Assert -> "[Assert]" - | Behavior x -> "[Behavior > " ^ (Behavior.show x) - | Integer x -> "[Integer > " ^ (Integer.show x) - | Race -> "[Race]" - | Cast x -> "[Cast > " ^ (Cast.show x) - | Unknown -> "[Unknown]" - | Analyzer -> "[Analyzer]" + | Assert -> ["Assert"] + | Behavior x -> "Behavior" :: Behavior.path_show x + | Integer x -> "Integer" :: Integer.path_show x + | Race -> ["Race"] + | Cast x -> "Cast" :: Cast.path_show x + | Unknown -> ["Unknown"] + | Analyzer -> ["Analyzer"] + +let show x = String.concat " > " (path_show x) let from_string_list (s: string list) = match s with @@ -186,4 +188,4 @@ let from_string_list (s: string list) = | "analyzer" -> Analyzer | _ -> Unknown -let to_yojson x = `String (show x) (* TODO: no brackets *) +let to_yojson x = `List (List.map (fun x -> `String x) (path_show x)) diff --git a/src/util/messages.ml b/src/util/messages.ml index b50b111175..5916e5cb48 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -80,7 +80,7 @@ struct let show = function | Category category -> Category.show category - | CWE n -> "[CWE-" ^ string_of_int n ^ "]" + | CWE n -> "CWE-" ^ string_of_int n let should_warn = function | Category category -> Category.should_warn category @@ -97,7 +97,7 @@ struct let hash tags = List.fold_left (fun xs x -> xs + Tag.hash x) 996699 tags (* copied from Printable.Liszt *) - let show tags = List.fold_left (fun acc tag -> acc ^ Tag.show tag) "" tags + let show tags = List.fold_left (fun acc tag -> acc ^ "[" ^ Tag.show tag ^ "]") "" tags let should_warn tags = List.exists Tag.should_warn tags end From 91723d1e596cd22c087e18b04d9f2aa2e1f3fb6c Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:35:41 +0300 Subject: [PATCH 72/95] Replace message show functions with Format --- src/util/gobFormat.ml | 2 ++ src/util/messages.ml | 24 ++++++++++++------------ 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src/util/gobFormat.ml b/src/util/gobFormat.ml index af10bf00bf..a489e92a88 100644 --- a/src/util/gobFormat.ml +++ b/src/util/gobFormat.ml @@ -17,3 +17,5 @@ let pp_set_ansi_color_tags ppf = let stag_functions' = {stag_functions with mark_open_stag; mark_close_stag} in Format.pp_set_formatter_stag_functions ppf stag_functions'; Format.pp_set_mark_tags ppf true + +let pp_print_nothing ppf () = () diff --git a/src/util/messages.ml b/src/util/messages.ml index 5916e5cb48..c3068ca07e 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -41,12 +41,10 @@ struct let hash {loc; text; context; print_loc} = 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context - let with_context msg = function - | Some ctx when GobConfig.get_bool "dbg.warn_with_context" -> msg ^ " in context " ^ string_of_int (Hashtbl.hash ctx) (* TODO: this is kind of useless *) - | _ -> msg - - let show {loc; text; context; print_loc} = - with_context text context + let text_with_context {text; context; _} = + match context with + | Some context when GobConfig.get_bool "dbg.warn_with_context" -> text ^ " in context " ^ string_of_int (Hashtbl.hash context) (* TODO: this is kind of useless *) + | _ -> text end module MultiPiece = @@ -78,9 +76,9 @@ struct | Category category -> Category.hash category | CWE n -> n - let show = function - | Category category -> Category.show category - | CWE n -> "CWE-" ^ string_of_int n + let pp ppf = function + | Category category -> Format.pp_print_string ppf (Category.show category) + | CWE n -> Format.fprintf ppf "CWE-%d" n let should_warn = function | Category category -> Category.should_warn category @@ -97,7 +95,9 @@ struct let hash tags = List.fold_left (fun xs x -> xs + Tag.hash x) 996699 tags (* copied from Printable.Liszt *) - let show tags = List.fold_left (fun acc tag -> acc ^ "[" ^ Tag.show tag ^ "]") "" tags + let pp = + let pp_tag_brackets ppf tag = Format.fprintf ppf "[%a]" Tag.pp tag in + Format.pp_print_list ~pp_sep:GobFormat.pp_print_nothing pp_tag_brackets let should_warn tags = List.exists Tag.should_warn tags end @@ -164,9 +164,9 @@ let print ?(ppf= !formatter) (m: Message.t) = | Debug -> "white" (* non-bright white is actually some gray *) | Success -> "green" in - let pp_prefix = Format.dprintf "@{<%s>[%s]%s@}" severity_stag (Severity.show m.severity) (Tags.show m.tags) in + let pp_prefix = Format.dprintf "@{<%s>[%a]%a@}" severity_stag Severity.pp m.severity Tags.pp m.tags in let pp_piece ppf piece = - Format.fprintf ppf "@{<%s>%s@} @{(%a)@}" severity_stag (Piece.show piece) CilType.Location.pp piece.print_loc + Format.fprintf ppf "@{<%s>%s@} @{(%a)@}" severity_stag (Piece.text_with_context piece) CilType.Location.pp piece.print_loc in let pp_multipiece ppf = match m.multipiece with | Single piece -> From 1d37580f4a5698cfb88d441feadd5f55cef6dc34 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:44:38 +0300 Subject: [PATCH 73/95] Wrap messages table in a module --- src/framework/analyses.ml | 4 ++-- src/framework/control.ml | 2 +- src/solvers/generic.ml | 4 ++-- src/util/messages.ml | 21 +++++++++++++++------ 4 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index f3f739511d..f7f7f29faa 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -153,7 +153,7 @@ struct BatPrintf.fprintf f "%a\n" n (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e in let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in - List.iter (one_w f) !Messages.messages_list + List.iter (one_w f) !Messages.Table.messages_list let output table gtable gtfxml (file: file) = let out = Messages.get_out result_name !GU.out in @@ -254,7 +254,7 @@ struct let t1 = Unix.gettimeofday () -. t in Printf.printf "Done in %fs!\n" t1 *) | "json-messages" -> - Yojson.Safe.to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.messages_list) + Yojson.Safe.to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.Table.messages_list) | "none" -> () | s -> failwith @@ "Unsupported value for option `result`: "^s end diff --git a/src/framework/control.ml b/src/framework/control.ml index e90d189ce1..5c9cbfbba6 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -444,7 +444,7 @@ struct ); Serialize.marshal !MCP.analyses_table analyses; Serialize.marshal (file, Cabs2cil.environment) cil; - Serialize.marshal !Messages.messages_list warnings; + Serialize.marshal !Messages.Table.messages_list warnings; Serialize.marshal (Stats.top, Gc.quick_stat ()) stats ); Goblintutil.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); (* write solver_stats after solving (otherwise no rows if faster than dbg.solver-stats-interval). TODO better way to write solver_stats without terminal output? *) diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 81066df04c..8e3d4a2510 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -155,7 +155,7 @@ struct incr warning_id; File.with_file_out ~mode:[`create;`excl;`text] full_name (one_w x) in - List.iter write_warning !Messages.messages_list + List.iter write_warning !Messages.Table.messages_list module SSH = Hashtbl.Make (struct include String let hash (x:string) = Hashtbl.hash x end) let funs = SSH.create 100 @@ -197,7 +197,7 @@ struct NH.iter (fun v () -> fprintf f "%a\n" Var.printXml v) updated_l; GH.iter (fun v () -> fprintf f "\n%a\n" GVar.printXml v) updated_g; let g n _ = fprintf f "\n" (n + !warning_id) in - List.iteri g !Messages.messages_list; + List.iteri g !Messages.Table.messages_list; (* List.iter write_warning !Messages.messages_list *) fprintf f "\n"; in diff --git a/src/util/messages.ml b/src/util/messages.ml index c3068ca07e..9aee77b1ea 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -117,9 +117,19 @@ struct 3 * Tags.hash tags + 7 * MultiPiece.hash multipiece + 13 * Severity.hash severity end -module MH = Hashtbl.Make (Message) -let messages_table = MH.create 113 (* messages without order for quick mem lookup *) -let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) +module Table = +struct + module MH = Hashtbl.Make (Message) + + let messages_table = MH.create 113 (* messages without order for quick mem lookup *) + let messages_list = ref [] (* messages with reverse order (for cons efficiency) *) + + let mem = MH.mem messages_table + + let add m = + MH.replace messages_table m (); + messages_list := m :: !messages_list +end let formatter = ref Format.std_formatter @@ -179,10 +189,9 @@ let print ?(ppf= !formatter) (m: Message.t) = let add m = if !GU.should_warn then ( - if Message.should_warn m && not (MH.mem messages_table m) then ( + if Message.should_warn m && not (Table.mem m) then ( print m; - MH.replace messages_table m (); - messages_list := m :: !messages_list + Table.add m ) ) From 477a32036d667ef3d479add7e3074e98d60f6097 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:45:26 +0300 Subject: [PATCH 74/95] Make json-messages output pretty --- src/framework/analyses.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index f7f7f29faa..ba5fdc9df0 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -254,7 +254,7 @@ struct let t1 = Unix.gettimeofday () -. t in Printf.printf "Done in %fs!\n" t1 *) | "json-messages" -> - Yojson.Safe.to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.Table.messages_list) + Yojson.Safe.pretty_to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.Table.messages_list) | "none" -> () | s -> failwith @@ "Unsupported value for option `result`: "^s end From f943b87c8740325fdf419a1e422ed818a69571f6 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:47:05 +0300 Subject: [PATCH 75/95] Extract Messages.Table.to_yojson --- src/framework/analyses.ml | 2 +- src/util/messages.ml | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index ba5fdc9df0..00ed963a3c 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -254,7 +254,7 @@ struct let t1 = Unix.gettimeofday () -. t in Printf.printf "Done in %fs!\n" t1 *) | "json-messages" -> - Yojson.Safe.pretty_to_channel ~std:true out ([%to_yojson: Messages.Message.t list] !Messages.Table.messages_list) + Yojson.Safe.pretty_to_channel ~std:true out (Messages.Table.to_yojson ()) | "none" -> () | s -> failwith @@ "Unsupported value for option `result`: "^s end diff --git a/src/util/messages.ml b/src/util/messages.ml index 9aee77b1ea..cdee41eb9b 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -129,6 +129,9 @@ struct let add m = MH.replace messages_table m (); messages_list := m :: !messages_list + + let to_yojson () = + [%to_yojson: Message.t list] !messages_list end From 1c6ae416ff50b17bbc36d843c15f36e89eaf9662 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Tue, 31 Aug 2021 18:48:49 +0300 Subject: [PATCH 76/95] Fix json-messages output being reversed --- src/util/messages.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index cdee41eb9b..5532e7e8ca 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -131,7 +131,7 @@ struct messages_list := m :: !messages_list let to_yojson () = - [%to_yojson: Message.t list] !messages_list + [%to_yojson: Message.t list] (List.rev !messages_list) (* reverse to get in addition order *) end From 3daafeede05ffcefc83bd248c836daba996b2c05 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 09:44:56 +0300 Subject: [PATCH 77/95] Use BatList.concat_map instead of List.concat_map for OCaml 4.09 --- src/util/messageUtil.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/util/messageUtil.ml b/src/util/messageUtil.ml index 31c9f46af7..35a7cfba85 100644 --- a/src/util/messageUtil.ml +++ b/src/util/messageUtil.ml @@ -4,7 +4,7 @@ let ansi_color_table = let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in let modes = [(Fun.id, "0" (* normal *)); (String.uppercase_ascii, "1" (* bold *))] in - List.concat_map (fun (color, color_code) -> + BatList.concat_map (fun (color, color_code) -> List.map (fun (mode_fn, mode_code) -> (mode_fn color, Format.sprintf "\027[%s;%sm" mode_code color_code) ) modes From 0e9fb774c0a8225a09717638e7020522addf7cbb Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 10:19:40 +0300 Subject: [PATCH 78/95] Generalize non-each message functions to Pretty format --- src/analyses/base.ml | 6 +++--- src/analyses/deadlock.ml | 2 +- src/analyses/fileUse.ml | 23 +++++++++++------------ src/analyses/mayLocks.ml | 2 +- src/analyses/spec.ml | 16 ++++++++-------- src/analyses/symbLocks.ml | 2 +- src/analyses/uninit.ml | 4 ++-- src/cdomains/containDomain.ml | 2 +- src/cdomains/lvalMapDomain.ml | 4 ++-- src/cdomains/shapeDomain.ml | 2 +- src/cdomains/valueDomain.ml | 2 +- src/framework/control.ml | 2 +- src/util/messages.ml | 14 ++++++++++---- 13 files changed, 43 insertions(+), 38 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index cdfb9815c6..7671fd7250 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -809,7 +809,7 @@ struct do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in - M.debug ("Failed evaluating "^str^" to lvalue"); do_offs AD.unknown_ptr ofs + M.debug "Failed evaluating %s to lvalue" str; do_offs AD.unknown_ptr ofs end (* run eval_rv from above and keep a result that is bottom *) @@ -832,7 +832,7 @@ struct | `Int i -> i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | `Bot -> Queries.ID.bot () (* TODO: remove? *) (* | v -> M.warn ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) - | v -> M.debug ("Query function answered " ^ (VD.show v)); Queries.ID.bot () + | v -> M.debug "Query function answered %a" VD.pretty v; Queries.ID.bot () in if M.tracing then M.traceu "evalint" "base query_evalint %a -> %a\n" d_exp e Queries.ID.pretty r; r @@ -1069,7 +1069,7 @@ struct with Cilfacade.TypeOfError _ -> (* If we cannot determine the correct type here, we go with the one of the LVal *) (* This will usually lead to a type mismatch in the ValueDomain (and hence supertop) *) - M.warn ("Cilfacade.typeOfLval failed Could not obtain the type of "^ sprint d_lval (Var x, cil_offset)); + M.warn "Cilfacade.typeOfLval failed Could not obtain the type of %a" d_lval (Var x, cil_offset); lval_type in let update_offset old_value = diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index d1768aa7ea..f8e834c7b7 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -97,7 +97,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn ("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'."); [] + | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* Called when calling a special/unknown function *) let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml index 7351a582e2..d204ab8470 100644 --- a/src/analyses/fileUse.ml +++ b/src/analyses/fileUse.ml @@ -32,8 +32,8 @@ struct | _ -> [] let print_query_lv ?msg:(msg="") ask exp = let xs = query_lv ask exp in (* MayPointTo -> LValSet *) - M.debug @@ msg^" MayPointTo "^sprint d_exp exp^" = [" - ^String.concat ", " (List.map D.string_of_key xs)^"]" + let pretty_key k = Pretty.text (D.string_of_key k) in + Messages.debug "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs let eval_fv ask exp: varinfo option = match query_lv ask exp with @@ -47,8 +47,7 @@ struct | _ -> [] let print_query_eq ?msg:(msg="") ask exp = let xs = query_eq ask exp in (* EqualSet -> ExpSet *) - M.debug @@ msg^" EqualSet "^sprint d_exp exp^" = [" - ^String.concat ", " (List.map (sprint d_exp) xs)^"]" + Messages.debug "%s EqualSet %a = [%a]" msg d_exp exp (Pretty.d_list ", " d_exp) xs (* transfer functions *) let assign ctx (lval:lval) (rval:exp) : D.t = @@ -68,20 +67,20 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* we just care about Lval assignments *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug @@ "assign (both in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug @@ "assign (only k1 in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug @@ "assign (only k2 in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); D.alias k1 k2 m | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug @@ "assign (only k1 in D): " ^ D.string_of_key k1 ^ " = " ^ sprint d_exp rval; + M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; saveOpened ~unknown:true k1 m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug @@ "assign (none in D): " ^ sprint d_lval lval ^ " = " ^ sprint d_exp rval ^ " [" ^ sprint d_plainexp rval ^ "]"; + M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m let branch ctx (exp:exp) (tv:bool) : D.t = @@ -99,7 +98,7 @@ struct D.error k m )else D.success k m - | _ -> M.debug @@ "nothing matched the given BinOp: "^sprint d_plainexp a^" = "^sprint d_plainexp b; m + | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -109,7 +108,7 @@ struct ignore(printf "%s %i\n" v.vname (Int64.to_int i)); m *) | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | e -> M.debug @@ "branch: nothing matched the given exp: "^sprint d_plainexp e; m + | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = (* M.debug_each @@ "body of function "^f.svar.vname; *) @@ -260,7 +259,7 @@ struct ) | xs -> let args = (String.concat ", " (List.map (sprint d_exp) xs)) in - M.debug @@ "fopen args: "^args; + M.debug "fopen args: %s" args; (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) xs; *) D.warn @@ "fopen needs two strings as arguments, given: "^args; m ) diff --git a/src/analyses/mayLocks.ml b/src/analyses/mayLocks.ml index 32921f4b8c..cf33e696be 100644 --- a/src/analyses/mayLocks.ml +++ b/src/analyses/mayLocks.ml @@ -34,7 +34,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn ("Could not evaluate '"^sprint d_exp exp^"' to an points-to set, instead got '"^Queries.LS.show b^"'."); [] + | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* locking logic -- add all locks we can add *) let lock ctx rw may_fail return_value_on_success a lv arglist ls : D.ReverseAddrSet.t = diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml index 2b60f3d936..c3100c851d 100644 --- a/src/analyses/spec.ml +++ b/src/analyses/spec.ml @@ -133,7 +133,7 @@ struct let may = (List.length keys > 1) in (* do not change state for reflexive edges where the key is not assigned to (e.g. *$p = _) *) let change_state = not (old_a=b && SC.get_lval c <> Some `Var) in - M.debug @@ "GOTO ~may:"^string_of_bool may^" ~change_state:"^string_of_bool change_state^". "^a^" -> "^b^": "^SC.stmt_to_string c; + M.debug "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); let new_m = goto ~may:may ~change_state:change_state var b m ws in (new_m,n+1) in @@ -242,23 +242,23 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* TODO for now we just care about Lval assignments -> should use Queries.MayPointTo *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug @@ "assign (both in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug @@ "assign (only k1 in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug @@ "assign (only k2 in D): " ^ D.string_of_key k1 ^ " = " ^ D.string_of_key k2; + M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); let m = D.alias k1 k2 m in (* point k1 to k2 *) if Lval.CilLval.class_tag k2 = `Temp (* check if k2 is a temporary Lval introduced by CIL *) then D.remove' k2 m (* if yes we need to remove it from our map *) else m (* otherwise no change *) | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug @@ "assign (only k1 in D): " ^ D.string_of_key k1 ^ " = " ^ sprint d_exp rval; + M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; (* saveOpened ~unknown:true k1 *) m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug @@ "assign (none in D): " ^ sprint d_lval lval ^ " = " ^ sprint d_exp rval ^ " [" ^ sprint d_plainexp rval ^ "]"; + M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m (* @@ -359,7 +359,7 @@ struct let v2 = D.V.set_state b value in (* M.debug_each @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) D.add key v2 m - | _ -> M.debug @@ "nothing matched the given BinOp: "^sprint d_plainexp a^" = "^sprint d_plainexp b; m + | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -369,7 +369,7 @@ struct | UnOp (LNot, a, _) -> check (stripCasts a) (integer 0) tv (* TODO makes 2 tests fail. probably check changes something it shouldn't *) (* | Lval _ as a -> check (stripCasts a) (integer 0) (not tv) *) - | e -> M.debug @@ "branch: nothing matched the given exp: "^sprint d_plainexp e; m + | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = ctx.local diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index 7f578fb273..03000d24c3 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -82,7 +82,7 @@ struct | `Unlock -> D.remove (Analyses.ask_of_ctx ctx) (List.hd arglist) ctx.local | `Unknown fn when VarEq.safe_fn fn -> - Messages.warn ("Assume that "^fn^" does not change lockset."); + Messages.warn "Assume that %s does not change lockset." fn; ctx.local | `Unknown x -> begin let st = diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index cf6e6b3f57..56feff27d9 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -162,7 +162,7 @@ struct | x::xs, y::ys -> [] (* found a mismatch *) | _ -> - M.warn ("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx))) ^ " -- did not find " ^ tf.fname); + M.warn "Failed to analyze union at point %a -- did not find %s" Addr.pretty (Addr.from_var_offset (v,rev cx)) tf.fname; [] in let utar, uoth = unrollType target, unrollType other in @@ -190,7 +190,7 @@ struct (* step into all other fields *) List.concat (List.rev_map (fun oth_f -> get_pfx v (`Field (oth_f, cx)) ofs utar oth_f.ftype) c2.cfields) | _ -> - M.warn ("Failed to analyze union at point " ^ (Addr.show (Addr.from_var_offset (v,rev cx)))); + M.warn "Failed to analyze union at point %a" Addr.pretty (Addr.from_var_offset (v,rev cx)); [] diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index edb1020a6b..17e8519cdf 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -1332,7 +1332,7 @@ struct let assign_argmap fs lval exp (fd, st, df) must_assign glob = (*keep track of used fun args*) match used_args st exp with | s when ArgSet.is_top s -> - Messages.warn ("Expression "^(sprint 160 (d_exp () exp))^" too complicated."); + Messages.warn "Expression %a too complicated." d_exp exp; fd, st, df | s when ArgSet.is_bot s -> let vars= get_vars exp in let s = List.fold_left (fun y x->if not (is_safe_name x.vname) then begin ArgSet.add (FieldVars.gen x) y end else y) (ArgSet.empty()) vars in diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index 5e7da3646c..9a6243e651 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -274,7 +274,7 @@ struct in let exp = AddrOf lval in let xs = query_lv ask exp in (* MayPointTo -> LValSet *) - Messages.debug @@ "MayPointTo "^sprint d_exp exp^" = [" - ^String.concat ", " (List.map string_of_key xs)^"]"; + let pretty_key k = Pretty.text (string_of_key k) in + Messages.debug "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs; xs end diff --git a/src/cdomains/shapeDomain.ml b/src/cdomains/shapeDomain.ml index 1c149908c8..a845b7ad8e 100644 --- a/src/cdomains/shapeDomain.ml +++ b/src/cdomains/shapeDomain.ml @@ -180,7 +180,7 @@ let eval_lp ask (e:exp) : lexp option = | _ -> None -let warn_todo s = Messages.warn ("NotImplemented exception! "^s) +let warn_todo s = Messages.warn "NotImplemented exception! %s" s let alias_top lp = SHMap.remove lp diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index c51e7a982e..5d3bf9ebf1 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -795,7 +795,7 @@ struct end | x when Goblintutil.opt_predicate (BI.equal (BI.zero)) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t | `Top -> M.debug "Trying to read an index, but the array is unknown"; top () - | _ -> M.warn ("Trying to read an index, but was not given an array ("^show x^")"); top () + | _ -> M.warn "Trying to read an index, but was not given an array (%a)" pretty x; top () end in let l, o = match exp with diff --git a/src/framework/control.ml b/src/framework/control.ml index 679fc5fbd4..f0d2b2cbb4 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -166,7 +166,7 @@ struct (* If the function is not defined, and yet has been included to the * analysis result, we generate a warning. *) with Not_found -> - Messages.warn ("Calculated state for undefined function: unexpected node "^Ana.sprint Node.pretty_plain n) + Messages.warn "Calculated state for undefined function: unexpected node %a" Node.pretty_plain n in LHT.iter add_local_var h; res diff --git a/src/util/messages.ml b/src/util/messages.ml index 5532e7e8ca..d5a638be59 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -218,18 +218,24 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg severity ?(tags=[]) ?(category=Category.Unknown) text = - add {tags = Category category :: tags; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} +let msg severity ?(tags=[]) ?(category=Category.Unknown) fmt = + let finish doc = + let text = Pretty.sprint ~width:max_int doc in + add {tags = Category category :: tags; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} + in + Pretty.gprintf finish fmt let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) text = + (* TODO: generalize to Pretty format *) add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} -let warn = msg Warning +(* must eta-expand ?tags to get proper (non-weak) polymorphism for format *) +let warn ?tags = msg Warning ?tags let warn_each = msg_each Warning (* TODO: error? *) let error_each = msg_each Error (* TODO: info *) -let debug = msg Debug +let debug ?tags = msg Debug ?tags let debug_each = msg_each Debug (* TODO: success? *) let success_each = msg_each Success From c04c7ae47dca1ba1898b0aec53038c27e484099f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 10:53:02 +0300 Subject: [PATCH 79/95] Generalize each message functions to Pretty format --- src/analyses/arinc.ml | 23 +++++++++++----------- src/analyses/base.ml | 33 ++++++++++++++++---------------- src/analyses/commonPriv.ml | 2 +- src/analyses/condVars.ml | 4 ++-- src/analyses/contain.ml | 2 +- src/analyses/deadlock.ml | 8 +++----- src/analyses/extract_arinc.ml | 4 ++-- src/analyses/extract_osek.ml | 2 +- src/analyses/fileUse.ml | 2 +- src/analyses/libraryFunctions.ml | 16 ++++++++++------ src/analyses/malloc_null.ml | 2 +- src/analyses/spec.ml | 22 ++++++++++----------- src/analyses/uninit.ml | 2 +- src/cdomains/arincDomain.ml | 2 +- src/cdomains/containDomain.ml | 9 +++++---- src/cdomains/intDomain.ml | 2 +- src/cdomains/lvalMapDomain.ml | 4 ++-- src/cdomains/valueDomain.ml | 12 ++++++------ src/framework/constraints.ml | 4 ++-- src/util/messages.ml | 19 ++++++++++-------- 20 files changed, 89 insertions(+), 85 deletions(-) diff --git a/src/analyses/arinc.ml b/src/analyses/arinc.ml index 7c4fa72558..431e3aef94 100644 --- a/src/analyses/arinc.ml +++ b/src/analyses/arinc.ml @@ -5,7 +5,7 @@ open Analyses module BI = IntOps.BigIntOps -let debug_doc doc = M.debug_each (Pretty.sprint 99 doc) +let debug_doc doc = M.debug_each "%a" Pretty.insert doc module Functions = struct let prefix = "LAP_Se_" @@ -146,7 +146,7 @@ struct let dummy_global_dlval = { dummyFunDec.svar with vname = "Gret" }, `NoOffset let global_dlval dlval fname = if Lval.CilLval.class_tag dlval = `Global then ( - M.debug_each @@ "WARN: " ^ fname ^ ": use of global lval: " ^ str_return_dlval dlval; + M.debug_each "WARN: %s: use of global lval: %s" fname (str_return_dlval dlval); if GobConfig.get_bool "ana.arinc.merge_globals" then dummy_global_dlval else dlval ) else dlval let mayPointTo ctx exp = @@ -154,18 +154,18 @@ struct | a when not (Queries.LS.is_top a) && Queries.LS.cardinal a > 0 -> let top_elt = (dummyFunDec.svar, `NoOffset) in let a' = if Queries.LS.mem top_elt a then ( - M.debug_each @@ "mayPointTo: query result for " ^ sprint d_exp exp ^ " contains TOP!"; (* UNSOUND *) + M.debug_each "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) Queries.LS.remove top_elt a ) else a in Queries.LS.elements a' | v -> - M.debug_each @@ "mayPointTo: query result for " ^ sprint d_exp exp ^ " is " ^ sprint Queries.LS.pretty v; + M.debug_each "mayPointTo: query result for %a is %a" d_exp exp Queries.LS.pretty v; (*failwith "mayPointTo"*) [] let mustPointTo ctx exp = let xs = mayPointTo ctx exp in if List.length xs = 1 then Some (List.hd xs) else None let iterMayPointTo ctx exp f = mayPointTo ctx exp |> List.iter f - let debugMayPointTo ctx exp = M.debug_each @@ sprint d_exp exp ^ " mayPointTo " ^ (String.concat ", " (List.map (sprint Lval.CilLval.pretty) (mayPointTo ctx exp))) + let debugMayPointTo ctx exp = M.debug_each "%a mayPointTo %a" d_exp exp (Pretty.d_list ", " Lval.CilLval.pretty) (mayPointTo ctx exp) (* transfer functions *) @@ -187,7 +187,7 @@ struct let edges_added = ref false in let f dlval = (* M.debug_each @@ "assign: MayPointTo " ^ sprint d_plainlval lval ^ ": " ^ sprint d_plainexp (Lval.CilLval.to_exp dlval); *) - let is_ret_type = try is_return_code_type @@ Lval.CilLval.to_exp dlval with Cilfacade.TypeOfError Index_NonArray -> M.debug_each @@ "assign: Cilfacade.typeOf "^ sprint d_exp (Lval.CilLval.to_exp dlval) ^" threw exception Errormsg.Error \"Bug: typeOffset: Index on a non-array\". Will assume this is a return type to remain sound."; true in + let is_ret_type = try is_return_code_type @@ Lval.CilLval.to_exp dlval with Cilfacade.TypeOfError Index_NonArray -> M.debug_each "assign: Cilfacade.typeOf %a threw exception Errormsg.Error \"Bug: typeOffset: Index on a non-array\". Will assume this is a return type to remain sound." d_exp (Lval.CilLval.to_exp dlval); true in if (not is_ret_type) || Lval.CilLval.has_index dlval then () else let dlval = global_dlval dlval "assign" in edges_added := true; @@ -225,7 +225,7 @@ struct let else_node = NodeTbl.get @@ Branch (List.hd else_stmts) in let dst_node = if tv then then_node else else_node in let d_if = if List.length stmt.preds > 1 then ( (* seems like this never happens *) - M.debug_each @@ "WARN: branch: If has more than 1 predecessor, will insert Nop edges!"; + M.debug_each "WARN: branch: If has more than 1 predecessor, will insert Nop edges!"; add_edges env ArincUtil.Nop; { ctx.local with pred = Pred.of_node env.node } ) else ctx.local @@ -253,7 +253,7 @@ struct | _ -> ctx.local let checkPredBot d tf f xs = - if d.pred = Pred.bot () then M.debug_each @@ tf^": mapping is BOT!!! function: "^f.vname^". "^(String.concat "\n" @@ List.map (fun (n,d) -> n ^ " = " ^ Pretty.sprint 200 (Pred.pretty () d.pred)) xs); + if d.pred = Pred.bot () then M.debug_each "%s: mapping is BOT!!! function: %s. %a" tf f.vname (Pretty.d_list "\n" (fun () (n, d) -> Pretty.dprintf "%s = %a" n Pred.pretty d.pred)) xs; d let body ctx (f:fundec) : D.t = (* enter is not called for spawned processes -> initialize them here *) @@ -327,9 +327,8 @@ struct let is_arinc_fun = startsWith Functions.prefix f.vname in let is_creating_fun = startsWith (Functions.prefix^"Create") f.vname in if M.tracing && is_arinc_fun then ( - let args_str = String.concat ", " (List.map (sprint d_exp) arglist) in (* M.tracel "arinc" "found %s(%s)\n" f.vname args_str *) - M.debug_each @@ "found "^f.vname^"("^args_str^") in "^env.fundec.svar.vname + M.debug_each "found %s(%a) in %s" f.vname (Pretty.d_list ", " d_exp) arglist env.fundec.svar.vname ); let is_error_handler = env.pname = pname_ErrorHandler in let eval_int exp = @@ -367,7 +366,7 @@ struct let f dlval = let dlval = global_dlval dlval "special" in if not @@ is_return_code_type @@ Lval.CilLval.to_exp dlval - then (M.debug_each @@ "WARN: last argument in arinc function may point to something other than a return code: " ^ str_return_dlval dlval; None) + then (M.debug_each "WARN: last argument in arinc function may point to something other than a return code: %s" (str_return_dlval dlval); None) else (add_return_dlval env `Write dlval; Some (str_return_dlval dlval)) in (* add actions for all lvals r may point to *) @@ -513,7 +512,7 @@ struct let pid' = Process, name in assign_id pid (get_id pid'); add_actions (List.map (fun f -> CreateProcess Action.({ pid = pid'; f; pri; per; cap })) funs) - | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail M.debug_each (`Result (f name, f entry_point, f pri, f per, f cap)); d (* TODO: f*) + | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug_each "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); d (* TODO: f*) end | "LAP_Se_GetProcessId", [name; pid; r] -> assign_id_by_name Process name pid; d diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 7671fd7250..de0438e75d 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -358,12 +358,10 @@ struct if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with | `Top -> - let warning = "Unknown value in " ^ description ^ " could be an escaped pointer address!" in - if VD.is_immediate_type t then () else M.warn_each warning; empty + if VD.is_immediate_type t then () else M.warn_each "Unknown value in %s could be an escaped pointer address!" description; empty | `Bot -> (*M.debug "A bottom value when computing reachable addresses!";*) empty | `Address adrs when AD.is_top adrs -> - let warning = "Unknown address in " ^ description ^ " has escaped." in - M.warn_each warning; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) + M.warn_each "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) (* The main thing is to track where pointers go: *) | `Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) @@ -856,12 +854,12 @@ struct try let fp = eval_fv (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in if AD.mem Addr.UnknownPtr fp then begin - M.warn_each ("Function pointer " ^ sprint d_exp fval ^ " may contain unknown functions."); + M.warn_each "Function pointer %a may contain unknown functions." d_exp fval; dummyFunDec.svar :: AD.to_var_may fp end else AD.to_var_may fp with SetDomain.Unsupported _ -> - M.warn_each ("Unknown call to function " ^ sprint d_exp fval ^ "."); + M.warn_each "Unknown call to function %a." d_exp fval; [dummyFunDec.svar] (* interpreter end *) @@ -943,7 +941,7 @@ struct (* check if we have an array of chars that form a string *) (* TODO return may-points-to-set of strings *) | `Address a when List.length (AD.to_string a) > 1 -> (* oh oh *) - M.debug_each @@ "EvalStr (" ^ sprint d_exp e ^ ") returned " ^ AD.show a; + M.debug_each "EvalStr (%a) returned %a" d_exp e AD.pretty a; Queries.Result.top q | `Address a when List.length (AD.to_var_may a) = 1 -> (* some other address *) (* Cil.varinfo * (AD.Addr.field, AD.Addr.idx) Lval.offs *) @@ -1382,7 +1380,7 @@ struct else set a gs st addr t_lval new_val ~invariant:true ~ctx:(Some ctx) (* no *_raw because this is not a real assignment *) | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; - M.warn_each ("Invariant failed: expression \"" ^ sprint d_plainexp exp ^ "\" not understood."); + M.warn_each "Invariant failed: expression \"%a\" not understood." d_plainexp exp; st let invariant ctx a gs st exp tv: store = @@ -1714,7 +1712,7 @@ struct match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - M.debug_each @@ "CondVars result for expression " ^ sprint d_exp exp ^ " is " ^ sprint d_exp e; + M.debug_each "CondVars result for expression %a is %a" d_exp exp d_exp e; invariant ctx (Analyses.ask_of_ctx ctx) ctx.global res e tv | _ -> res in @@ -1814,7 +1812,7 @@ struct let invalidate ?ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; - if exps <> [] then M.warn_each ("Invalidating expressions: " ^ sprint (d_list ", " d_plainexp) exps); + if exps <> [] then M.warn_each "Invalidating expressions: %a" (d_list ", " d_plainexp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let invalidate_address st a = @@ -1899,7 +1897,7 @@ struct in Some (lval, v, args) else ( - M.warn_each ("Not creating a thread from " ^ v.vname ^ " because its type is " ^ sprint d_type v.vtype); + M.warn_each "Not creating a thread from %s because its type is %a" v.vname d_type v.vtype; None ) in @@ -1928,7 +1926,7 @@ struct in let flist = collect_funargs (Analyses.ask_of_ctx ctx) ctx.global ctx.local args in let addrs = List.concat (List.map AD.to_var_may flist) in - if addrs <> [] then M.warn_each ("Spawning functions from unknown function: " ^ sprint (d_list ", " d_varinfo) addrs); + if addrs <> [] then M.warn_each "Spawning functions from unknown function: %a" (d_list ", " d_varinfo) addrs; List.filter_map (create_thread None None) addrs end | _ -> [] @@ -1963,18 +1961,19 @@ struct ) else warn_fn msg in + (* TODO: use format instead of %s for the following messages *) match check_assert e ctx.local with | `Lifted false -> - warn (M.error_each ~category:M.Category.Assert) ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); + warn (M.error_each ~category:M.Category.Assert "%s") ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn (M.success_each ~category:M.Category.Assert) ("Assertion \"" ^ expr ^ "\" will succeed"); + warn (M.success_each ~category:M.Category.Assert "%s") ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.error_each ~category:M.Category.Assert ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error_each ~category:M.Category.Assert "%s" ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn (M.warn_each ~category:M.Category.Assert) ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); + warn (M.warn_each ~category:M.Category.Assert "%s") ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in @@ -1984,7 +1983,7 @@ struct end let special_unknown_invalidate ctx ask gs st f args = - (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn_each ("Function definition missing for " ^ f.vname)); + (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn_each "Function definition missing for %s" f.vname); (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn_each "Unknown function ptr called"); let addrs = if get_bool "sem.unknown_function.invalidate.globals" then ( diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 82ec6d34fa..0ac5d0b006 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -34,7 +34,7 @@ struct let mutex_addr_to_varinfo = function | LockDomain.Addr.Addr (v, `NoOffset) -> v | LockDomain.Addr.Addr (v, offs) -> - M.warn_each (Pretty.sprint ~width:800 @@ Pretty.dprintf "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs); + M.warn_each "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs; v | _ -> failwith "MutexGlobalsBase.mutex_addr_to_varinfo" end diff --git a/src/analyses/condVars.ml b/src/analyses/condVars.ml index bf4fdbe4df..8f71ea5007 100644 --- a/src/analyses/condVars.ml +++ b/src/analyses/condVars.ml @@ -64,7 +64,7 @@ struct | a when not (Queries.LS.is_top a) && Queries.LS.cardinal a > 0 -> let top_elt = (dummyFunDec.svar, `NoOffset) in let a' = if Queries.LS.mem top_elt a then ( - M.debug_each @@ "mayPointTo: query result for " ^ sprint d_exp exp ^ " contains TOP!"; (* UNSOUND *) + M.debug_each "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) Queries.LS.remove top_elt a ) else a in @@ -104,7 +104,7 @@ struct let save_expr lval expr = match mustPointTo ctx (AddrOf lval) with | Some clval -> - M.debug_each @@ "CondVars: saving " ^ sprint Lval.CilLval.pretty clval ^ " = " ^ sprint d_exp expr; + M.debug_each "CondVars: saving %a = %a" Lval.CilLval.pretty clval d_exp expr; D.add clval (D.V.singleton expr) d (* if lval must point to clval, add expr *) | None -> d in diff --git a/src/analyses/contain.ml b/src/analyses/contain.ml index b24c9fd100..6c61b54725 100644 --- a/src/analyses/contain.ml +++ b/src/analyses/contain.ml @@ -521,7 +521,7 @@ struct let fns = D.get_fptr_items ctx.global in let add_svar x y = match ContainDomain.FuncName.from_fun_name x with - | Some x -> Messages.warn_each ("fptr check: "^x.vname );(x)::y + | Some x -> Messages.warn_each "fptr check: %s" x.vname;(x)::y | _ -> y in ContainDomain.VarNameSet.fold (fun x y -> add_svar x y) fns [] diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index f8e834c7b7..6defb426c4 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -3,7 +3,6 @@ open Prelude.Ana open Analyses open DeadlockDomain -open Printf let forbiddenList : ( (myowntypeEntry*myowntypeEntry) list ref) = ref [] @@ -28,10 +27,9 @@ struct if !Goblintutil.in_verifying_stage then begin D.iter (fun e -> List.iter (fun (a,b) -> if ((MyLock.equal a e) && (MyLock.equal b newLock)) then ( - let msg = (sprintf "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show e.addr) (ValueDomain.Addr.show newLock.addr) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc) (CilType.Location.show b.loc) (CilType.Location.show a.loc)) in - Messages.warn_each msg; - let msg = (sprintf "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show newLock.addr) (ValueDomain.Addr.show e.addr) (CilType.Location.show b.loc) (CilType.Location.show a.loc) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc)) in - Messages.warn_each ~loc:a.loc msg; + (* TODO: use pretty instead of show *) + Messages.warn_each "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show e.addr) (ValueDomain.Addr.show newLock.addr) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc) (CilType.Location.show b.loc) (CilType.Location.show a.loc); + Messages.warn_each ~loc:a.loc "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show newLock.addr) (ValueDomain.Addr.show e.addr) (CilType.Location.show b.loc) (CilType.Location.show a.loc) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc); ) else () ) !forbiddenList ) lockList; diff --git a/src/analyses/extract_arinc.ml b/src/analyses/extract_arinc.ml index 84d70561a4..95849da341 100644 --- a/src/analyses/extract_arinc.ml +++ b/src/analyses/extract_arinc.ml @@ -338,10 +338,10 @@ struct let v,i = Res.get ("process", name) in assign_id pid' v; List.fold_left (fun d f -> extract_fun ~info_args:[f.vname] [string_of_int i]) ctx.local funs - | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail M.debug_each (`Result (f name, f entry_point, f pri, f per, f cap)); ctx.local (* TODO: f *) + | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug_each "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); ctx.local (* TODO: f *) end | _ -> match Pml.special_fun fname with - | None -> M.debug_each ("extract_arinc: unhandled function "^fname); ctx.local + | None -> M.debug_each "extract_arinc: unhandled function %s" fname; ctx.local | Some eval_args -> if M.tracing then M.trace "extract_arinc" "extract %s, args: %i code, %i pml\n" f.vname (List.length arglist) (List.length eval_args); let rec combine_opt f a b = match a, b with diff --git a/src/analyses/extract_osek.ml b/src/analyses/extract_osek.ml index 88fa7112c1..61eaa1f0ce 100644 --- a/src/analyses/extract_osek.ml +++ b/src/analyses/extract_osek.ml @@ -294,7 +294,7 @@ struct pid, ctx_hash, Pred.of_node node in match Pml.special_fun fname with - | None -> M.debug_each ("extract_osek: unhandled function "^fname); ctx.local + | None -> M.debug_each "extract_osek: unhandled function %s" fname; ctx.local | Some eval_args -> if M.tracing then M.trace "extract_osek" "extract %s, args: %i code, %i pml\n" f.vname (List.length arglist) (List.length eval_args); let rec combine_opt f a b = match a, b with diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml index d204ab8470..3c6c3317df 100644 --- a/src/analyses/fileUse.ml +++ b/src/analyses/fileUse.ml @@ -22,7 +22,7 @@ struct (* queries *) let query ctx (type a) (q: a Queries.t) = match q with - | Queries.MayPointTo exp -> M.debug_each @@ "query MayPointTo: "^sprint d_plainexp exp; Queries.Result.top q + | Queries.MayPointTo exp -> M.debug_each "query MayPointTo: %a" d_plainexp exp; Queries.Result.top q | _ -> Queries.Result.top q let query_lv (ask: Queries.ask) exp = diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 88c6b50c0f..68ba050cad 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -19,36 +19,40 @@ type categories = [ let osek_renames = ref false let classify' fn exps = + let strange_arguments () = + M.warn_each "%s arguments are strange!" fn; + `Unknown fn + in match fn with | "pthread_create" -> begin match exps with | [id;_;fn;x] -> `ThreadCreate (id, fn, x) - | _ -> M.warn_each "pthread_create arguments are strange."; `Unknown fn + | _ -> strange_arguments () end | "pthread_join" -> begin match exps with | [id; ret_var] -> `ThreadJoin (id, ret_var) - | _ -> M.warn_each "pthread_join arguments are strange!"; `Unknown fn + | _ -> strange_arguments () end | "malloc" | "kmalloc" | "__kmalloc" | "usb_alloc_urb" | "__builtin_alloca" -> begin match exps with | size::_ -> `Malloc size - | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn + | _ -> strange_arguments () end | "kzalloc" -> begin match exps with | size::_ -> `Calloc (Cil.one, size) - | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn + | _ -> strange_arguments () end | "calloc" -> begin match exps with | n::size::_ -> `Calloc (n, size) - | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn + | _ -> strange_arguments () end | "realloc" -> begin match exps with | p::size::_ -> `Realloc (p, size) - | _ -> M.warn_each (fn^" arguments are strange!"); `Unknown fn + | _ -> strange_arguments () end | "assert" -> begin match exps with diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index da7ffe7b3b..fa54f4da04 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -47,7 +47,7 @@ struct if D.exists (fun x -> List.exists (fun x -> is_prefix_of x v) (Addr.to_var_offset x)) st then let var = Addr.from_var_offset v in - Messages.warn_each ~category:(Messages.Category.Behavior.Undefined.nullpointer_dereference ()) ("Possible dereferencing of null on variable '" ^ (Addr.show var) ^ "'.") + Messages.warn_each ~category:(Messages.Category.Behavior.Undefined.nullpointer_dereference ()) "Possible dereferencing of null on variable '%a'." Addr.pretty var with SetDomain.Unsupported _ -> () (* Warn null-lval dereferences, but not normal (null-) lvals*) diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml index c3100c851d..776055da03 100644 --- a/src/analyses/spec.ml +++ b/src/analyses/spec.ml @@ -57,22 +57,22 @@ struct warn key m msg; m (* no goto == implicit back edge *) | None -> - M.debug_each @@ "GOTO "^D.string_of_key key^": "^D.string_of_state key m^" -> "^state; + M.debug_each "GOTO %s: %s -> %s" (D.string_of_key key) (D.string_of_state key m) state; if not change_state then m else if may then D.may_goto key loc state m else D.goto key loc state m (* match spec_exp, cil_exp *) let equal_exp ctx = function (* TODO match constants right away to avoid queries? *) - | `String a, Const(CStr b) -> M.debug_each @@ "EQUAL String Const: "^a^" = "^b; a=b + | `String a, Const(CStr b) -> M.debug_each "EQUAL String Const: %s = %s" a b; a=b (* | `String a, Const(CWStr xs as c) -> failwith "not implemented" *) (* CWStr is done in base.ml, query only returns `Str if it's safe *) | `String a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> M.debug_each @@ "EQUAL String Query: "^a^" = "^b; a=b + | `Lifted b -> M.debug_each "EQUAL String Query: %s = %s" a b; a=b | _ -> M.debug_each "EQUAL String Query: no result!"; false ) | `Regex a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> M.debug_each @@ "EQUAL Regex String Query: "^a^" = "^b; Str.string_match (Str.regexp a) b 0 + | `Lifted b -> M.debug_each "EQUAL Regex String Query: %s = %s" a b; Str.string_match (Str.regexp a) b 0 | _ -> M.debug_each "EQUAL Regex String Query: no result!"; false ) | `Bool a, e -> (match ctx.ask (Queries.EvalInt e) with @@ -153,7 +153,7 @@ struct let rec check_fwd_loop m new_a old_key = (* TODO cycle detection? *) let new_m,fwd,new_a,key = List.find_map (check_constraint ctx get_key matches m new_a old_key) !edges in (* List.iter (fun x -> M.debug_each (x^"\n")) (D.string_of_map new_m); *) - if fwd then M.debug_each @@ "FWD: "^string_of_bool fwd^", new_a: "^dump new_a^", old_key: "^dump old_key; + if fwd then M.debug_each "FWD: %B, new_a: %s, old_key: %s" fwd (dump new_a) (dump old_key); if fwd then check_fwd_loop new_m new_a key else new_m,key in (* now we get the new domain and the latest key that was used *) @@ -217,7 +217,7 @@ struct (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) let get_key c = match SC.get_key_variant c with | `Lval s -> - M.debug_each @@ "Key variant assign `Lval "^s^"; "^SC.stmt_to_string c; + M.debug_each "Key variant assign `Lval %s; %s" s (SC.stmt_to_string c); (match SC.get_lval c, lval with | Some `Var, _ -> Some lval | Some `Ptr, (Mem Lval x, o) -> Some x (* TODO offset? *) @@ -334,11 +334,11 @@ struct (* there should be only one such edge or none *) if List.length branch_edges <> 1 then ( (* call of branch for an actual branch *) M.debug_each "branch: branch_edges length is not 1! -> actual branch"; - M.debug_each ((D.string_of_entry key m)^" -> branch_edges1: "^(String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges)); + M.debug_each "%s -> branch_edges1: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; (* filter those edges that are branches, end with a state from states have the same branch expression and the same tv *) (* TODO they should end with any predecessor of the current state, not only the direct predecessor *) let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem b states && branch_exp_eq c exp tv) !edges in - M.debug_each ((D.string_of_entry key m)^" -> branch_edges2: "^(String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges)); + M.debug_each "%s -> branch_edges2: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; if List.length branch_edges <> 1 then m else (* meet current value with the target state. this is tricky: we can not simply take the target state, since there might have been more than one element already before the branching. -> find out what the alternative branch target was and remove it *) @@ -453,10 +453,10 @@ struct let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) let get_key c = match SC.get_key_variant c with | `Lval s -> - M.debug_each @@ "Key variant special `Lval "^s^"; "^SC.stmt_to_string c; + M.debug_each "Key variant special `Lval %s; %s" s (SC.stmt_to_string c); lval | `Arg(s, i) -> - M.debug_each @@ "Key variant special `Arg("^s^", "^string_of_int i^")"^". "^SC.stmt_to_string c; + M.debug_each "Key variant special `Arg(%s, %d). %s" s i (SC.stmt_to_string c); (try let arg = List.at arglist i in match arg with @@ -464,7 +464,7 @@ struct | AddrOf x -> Some x | _ -> None with Invalid_argument s -> - M.debug_each @@ "Key out of bounds! Msg: "^s; (* TODO what to do if spec says that there should be more args... *) + M.debug_each "Key out of bounds! Msg: %s" s; (* TODO what to do if spec says that there should be more args... *) None ) | _ -> None (* `Rval or `None *) diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index 56feff27d9..a6ae369da1 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -123,7 +123,7 @@ struct List.exists (is_prefix_of a) (Addr.to_var_offset addr) in if D.exists f st then begin - Messages.warn_each ("Uninitialized variable " ^ (Addr.show (Addr.from_var_offset a)) ^ " accessed."); + Messages.warn_each "Uninitialized variable %a accessed." Addr.pretty (Addr.from_var_offset a); false end else t in diff --git a/src/cdomains/arincDomain.ml b/src/cdomains/arincDomain.ml index c66cdd3640..6015593089 100644 --- a/src/cdomains/arincDomain.ml +++ b/src/cdomains/arincDomain.ml @@ -65,7 +65,7 @@ struct let op_scheme op1 op2 op3 op4 op5 op6 op7 op8 x y: t = { pid = op1 x.pid y.pid; pri = op2 x.pri y.pri; per = op3 x.per y.per; cap = op4 x.cap y.cap; pmo = op5 x.pmo y.pmo; pre = op6 x.pre y.pre; pred = op7 x.pred y.pred; ctx = op8 x.ctx y.ctx } let join x y = let r = op_scheme Pid.join Pri.join Per.join Cap.join Pmo.join PrE.join Pred.join Ctx.join x y in (* let s x = if is_top x then "TOP" else if is_bot x then "BOT" else short 0 x in M.debug_each @@ "JOIN\t" ^ if equal x y then "EQUAL" else s x ^ "\n\t" ^ s y ^ "\n->\t" ^ s r; *) - if Pred.cardinal r.pred > 5 then (Messages.debug_each @@ "Pred.cardinal r.pred = " ^ string_of_int (Pred.cardinal r.pred) ^ " with value " ^ show r(* ; failwith "STOP" *)); + if Pred.cardinal r.pred > 5 then (Messages.debug_each "Pred.cardinal r.pred = %d with value %a" (Pred.cardinal r.pred) pretty r(* ; failwith "STOP" *)); r let widen = join let meet = op_scheme Pid.meet Pri.meet Per.meet Cap.meet Pmo.meet PrE.meet Pred.meet Ctx.meet diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 17e8519cdf..0582d85f43 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -41,7 +41,7 @@ let report x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ("CW: "^x) + Messages.warn_each "CW: %s" x module FieldVars = struct @@ -173,7 +173,7 @@ struct let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && (!Goblintutil.in_verifying_stage|| !final) then (*filter noise*) - Messages.warn_each ("CW: "^x) + Messages.warn_each "CW: %s" x module Danger = struct @@ -256,13 +256,14 @@ struct if enable_dbg && loc.line>=dbg_line_start && loc.line<=dbg_line_end then (*counter := !counter + 1;*) if not (loc.file ="LLVM INTERNAL") || not (loc.line=1) then (*filter noise*) - Messages.warn_each ((*(string_of_int !counter)^*)"CW: "^x) + Messages.warn_each "CW: %s" x + (* Messages.warn_each "%dCW: %s" !counter x *) let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~category:Messages.Category.Analyzer ("CW: "^x) (* TODO: used to call report_error, add error severity *) + Messages.warn_each ~category:Messages.Category.Analyzer "CW: %s" x (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 4b6b87ec1d..1c55d5406d 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -2723,7 +2723,7 @@ module IntDomTupleImpl = struct let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in if n = 1 then Some (List.hd xs) else ( - if n>1 then Messages.warn_each ("Inconsistent state! "^String.concat "," @@ List.map show us); (* do not want to abort, but we need some unsound category *) + if n>1 then Messages.warn_each "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort, but we need some unsound category *) None ) let to_int = same BI.to_string % mapp2 { fp2 = fun (type a) (module I:S with type t = a and type int_t = int_t) -> I.to_int } diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index 9a6243e651..aef4b2bd38 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -252,10 +252,10 @@ struct let warn ?may:(may=false) ?loc:(loc=[!Tracing.current_loc]) msg = match msg |> Str.split (Str.regexp "[ \n\r\x0c\t]+") with - | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) msg + | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) "%s" msg | h :: t -> let warn_type = Messages.Category.from_string_list (h |> Str.split (Str.regexp "[.]")) - in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~category:warn_type (String.concat " " t) + in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~category:warn_type "%a" (Pretty.docList ~sep:(Pretty.text " ") Pretty.text) t (* getting keys from Cil Lvals *) let sprint f x = Pretty.sprint 80 (f () x) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 5d3bf9ebf1..12a2430846 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -324,7 +324,7 @@ struct a (* probably garbage, but this is deref's problem *) (*raise (CastError s)*) | SizeOfError (s,t) -> - M.warn_each ("size of error: " ^ s); + M.warn_each "size of error: %s" s; a end | x -> x (* TODO we should also keep track of the type here *) @@ -442,7 +442,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.join AD.null_ptr y @@ -469,7 +469,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.join AD.null_ptr y @@ -497,7 +497,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.widen AD.null_ptr y @@ -562,7 +562,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.widen AD.null_ptr y @@ -916,7 +916,7 @@ struct `Array new_array_value | `Top -> M.warn "Trying to update an index, but the array is unknown"; top () | x when Goblintutil.opt_predicate (BI.equal BI.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t - | _ -> M.warn_each ("Trying to update an index, but was not given an array("^show x^")"); top () + | _ -> M.warn_each "Trying to update an index, but was not given an array(%a)" pretty x; top () end in mu result in diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index 066d402166..f25570c31f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -500,7 +500,7 @@ struct ignore (getl (Function fd, c)) | exception Not_found -> (* unknown function *) - M.warn_each ("Created a thread from unknown function " ^ f.vname) + M.warn_each "Created a thread from unknown function %s" f.vname (* actual implementation (e.g. invalidation) is done by threadenter *) ) ds in @@ -633,7 +633,7 @@ struct let one_function f = match Cilfacade.find_varinfo_fundec f with | fd when LibraryFunctions.use_special f.vname -> - M.warn_each ("Using special for defined function " ^ f.vname); + M.warn_each "Using special for defined function %s" f.vname; tf_special_call ctx lv f args | fd -> tf_normal_call ctx lv e fd args getl sidel getg sideg diff --git a/src/util/messages.ml b/src/util/messages.ml index d5a638be59..f7225cd241 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -225,19 +225,22 @@ let msg severity ?(tags=[]) ?(category=Category.Unknown) fmt = in Pretty.gprintf finish fmt -let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) text = - (* TODO: generalize to Pretty format *) - add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} +let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) fmt = + let finish doc = + let text = Pretty.sprint ~width:max_int doc in + add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} + in + Pretty.gprintf finish fmt -(* must eta-expand ?tags to get proper (non-weak) polymorphism for format *) +(* must eta-expand to get proper (non-weak) polymorphism for format *) let warn ?tags = msg Warning ?tags -let warn_each = msg_each Warning +let warn_each ?loc = msg_each Warning ?loc (* TODO: error? *) -let error_each = msg_each Error +let error_each ?loc = msg_each Error ?loc (* TODO: info *) let debug ?tags = msg Debug ?tags -let debug_each = msg_each Debug +let debug_each ?loc = msg_each Debug ?loc (* TODO: success? *) -let success_each = msg_each Success +let success_each ?loc = msg_each Success ?loc include Tracing From 888ce397fc48cdf24c4ed2db991de324bcaaaac4 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 10:58:52 +0300 Subject: [PATCH 80/95] Fix nested lists in warning documentation --- docs/developer-guide/warning.md | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/docs/developer-guide/warning.md b/docs/developer-guide/warning.md index ef05b1ba67..4d48513f87 100644 --- a/docs/developer-guide/warning.md +++ b/docs/developer-guide/warning.md @@ -5,20 +5,20 @@ Types of warnings form the following tree structure: - Behavior (`behavior`) - - Undefined (`undefined`) - - ArrayOutOfBounds (`array_out_of_bounds`) - - BeforeStart (`before_start`) - - PastEnd (`past_end`) - - Unknown (`unknown`) - - NullPointerDereference (`nullpointer_dereference`) - - UseAfterFree (`use_after_free`) - - Machine (`machine`) - - Implementation (`implementation`) + - Undefined (`undefined`) + - ArrayOutOfBounds (`array_out_of_bounds`) + - BeforeStart (`before_start`) + - PastEnd (`past_end`) + - Unknown (`unknown`) + - NullPointerDereference (`nullpointer_dereference`) + - UseAfterFree (`use_after_free`) + - Machine (`machine`) + - Implementation (`implementation`) - Integer (`integer`) - - Overflow (`overflow`) - - DivByZero (`div_by_zero`) + - Overflow (`overflow`) + - DivByZero (`div_by_zero`) - Cast (`cast`) - - TypeMismatch (`type_mismatch`) + - TypeMismatch (`type_mismatch`) - Race (`race`) - Analyzer (`analyzer`) - Unknown (`unknown`) From 36a94af4bfc7911fc6d8c6cb0093c80161a2e462 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 10:59:40 +0300 Subject: [PATCH 81/95] Update warning categories in documentation --- docs/developer-guide/warning.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/developer-guide/warning.md b/docs/developer-guide/warning.md index 4d48513f87..fbc7fa4457 100644 --- a/docs/developer-guide/warning.md +++ b/docs/developer-guide/warning.md @@ -4,6 +4,7 @@ Types of warnings form the following tree structure: +- Assert - Behavior (`behavior`) - Undefined (`undefined`) - ArrayOutOfBounds (`array_out_of_bounds`) @@ -22,7 +23,6 @@ Types of warnings form the following tree structure: - Race (`race`) - Analyzer (`analyzer`) - Unknown (`unknown`) -- Debug (`debug`) ## Output From b41b33dc03795a300b81dc5468aa54f068181bb2 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:04:24 +0300 Subject: [PATCH 82/95] Remove useless () arguments from message category convenience functions --- src/analyses/base.ml | 4 ++-- src/analyses/malloc_null.ml | 2 +- src/cdomains/arrayDomain.ml | 10 +++++----- src/cdomains/intDomain.ml | 4 ++-- src/util/messageCategory.ml | 40 ++++++++++++++++++------------------- 5 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index de0438e75d..810a0dd1c3 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -801,9 +801,9 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) ~tags:[M.Tag.CWE 476] "Must dereference NULL pointer" + then M.error_each ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "Must dereference NULL pointer" else if AD.may_be_null adr - then M.warn_each ~category:(M.Category.Behavior.Undefined.nullpointer_dereference ()) ~tags:[M.Tag.CWE 476] "May dereference NULL pointer"); + then M.warn_each ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "May dereference NULL pointer"); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index fa54f4da04..64e586cd87 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -47,7 +47,7 @@ struct if D.exists (fun x -> List.exists (fun x -> is_prefix_of x v) (Addr.to_var_offset x)) st then let var = Addr.from_var_offset v in - Messages.warn_each ~category:(Messages.Category.Behavior.Undefined.nullpointer_dereference ()) "Possible dereferencing of null on variable '%a'." Addr.pretty var + Messages.warn_each ~category:Messages.Category.Behavior.Undefined.nullpointer_dereference "Possible dereferencing of null on variable '%a'." Addr.pretty var with SetDomain.Unsupported _ -> () (* Warn null-lval dereferences, but not normal (null-) lvals*) diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 75bbfdbb88..8dabfee4a5 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,15 +575,15 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.error_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "Must access array past end" + M.error_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Must access array past end" | Some true, None -> - M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end ()) "May access array past end" + M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end" | Some false, Some true -> - M.error_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "Must access array before start" + M.error_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Must access array before start" | None, Some true -> - M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start ()) "May access array before start" + M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May access array before start" | _ -> - M.warn_each ~category:(M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown ()) "May access array out of bounds" + M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown "May access array out of bounds" else () diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 1c55d5406d..67ffc06b82 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -539,7 +539,7 @@ struct let set_overflow_flag ik = if Cil.isSigned ik && !GU.in_verifying_stage then ( Goblintutil.did_overflow := true; - M.warn ~category:(M.Category.Integer.overflow ()) ~tags:[M.Tag.CWE 190] "Integer overflow" + M.warn ~category:M.Category.Integer.overflow ~tags:[M.Tag.CWE 190] "Integer overflow" ) let norm ik = function None -> None | Some (x,y) -> @@ -1298,7 +1298,7 @@ struct v ) else if should_ignore_overflow ik then ( - M.warn ~category:(M.Category.Integer.overflow ()) "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; `Bot ) else ( diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index 6a1b7d377a..2c57051dfd 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -42,8 +42,8 @@ struct let create (e: t): category = Behavior e let undefined e: category = create @@ Undefined e - let implementation (): category = create @@ Implementation - let machine (): category = create @@ Machine + let implementation: category = create @@ Implementation + let machine: category = create @@ Machine module Undefined = struct @@ -51,25 +51,25 @@ struct let create (e: t): category = undefined e let array_out_of_bounds e: category = create @@ ArrayOutOfBounds e - let nullpointer_dereference (): category = create @@ NullPointerDereference - let use_after_free (): category = create @@ UseAfterFree + let nullpointer_dereference: category = create @@ NullPointerDereference + let use_after_free: category = create @@ UseAfterFree module ArrayOutOfBounds = struct type t = array_oob let create (e: t): category = array_out_of_bounds e - let past_end (): category = create PastEnd - let before_start (): category = create BeforeStart - let unknown (): category = create Unknown + let past_end: category = create PastEnd + let before_start: category = create BeforeStart + let unknown: category = create Unknown let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> match h with - | "past_end" -> past_end () - | "before_start" -> before_start () - | "unknown" -> unknown () + | "past_end" -> past_end + | "before_start" -> before_start + | "unknown" -> unknown | _ -> Unknown let path_show (e: t) = @@ -84,8 +84,8 @@ struct | [] -> Unknown | h :: t -> match h with | "array_out_of_bounds" -> ArrayOutOfBounds.from_string_list t - | "nullpointer_dereference" -> nullpointer_dereference () - | "use_after_free" -> use_after_free () + | "nullpointer_dereference" -> nullpointer_dereference + | "use_after_free" -> use_after_free | _ -> Unknown let path_show (e: t) = @@ -100,8 +100,8 @@ struct | [] -> Unknown | h :: t -> ();match h with | "undefined" -> Undefined.from_string_list t - | "implementation" -> implementation () - | "machine" -> machine () + | "implementation" -> implementation + | "machine" -> machine | _ -> Unknown let path_show (e: t) = @@ -116,15 +116,15 @@ struct type t = integer let create (e: t): category = Integer e - let overflow (): category = create Overflow - let div_by_zero (): category = create DivByZero + let overflow: category = create Overflow + let div_by_zero: category = create DivByZero let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> ();match h with - | "overflow" -> overflow () - | "div_by_zero" -> div_by_zero () + | "overflow" -> overflow + | "div_by_zero" -> div_by_zero | _ -> Unknown let path_show (e: t) = @@ -138,13 +138,13 @@ struct type t = cast let create (e: t): category = Cast e - let type_mismatch (): category = create TypeMismatch + let type_mismatch: category = create TypeMismatch let from_string_list (s: string list): category = match s with | [] -> Unknown | h :: t -> ();match h with - | "type_mismatch" -> type_mismatch () + | "type_mismatch" -> type_mismatch | _ -> Unknown let path_show (e: t) = From 0372f53922da0867a8e1eedd5cc4111d3421df54 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:36:50 +0300 Subject: [PATCH 83/95] Add documentation for refactored message system --- docs/developer-guide/messaging.md | 54 +++++++++++++++++++++++++++++++ mkdocs.yml | 1 + 2 files changed, 55 insertions(+) create mode 100644 docs/developer-guide/messaging.md diff --git a/docs/developer-guide/messaging.md b/docs/developer-guide/messaging.md new file mode 100644 index 0000000000..9eeab78889 --- /dev/null +++ b/docs/developer-guide/messaging.md @@ -0,0 +1,54 @@ +# Messaging + +The message system in `Messages` module should be used for outputting all (non-[tracing](./debugging.md#tracing)) information instead of printing them directly to `stdout`. +This allows for consistent pretty terminal output, as well as export to Goblint result viewers and IDEs. + +## Message structure + +A message consists of the following: + +1. **Severity.** One of: error, warning, info, debug, success. +2. **Tags.** A list of tags (including multiple of the same kind): + * **Category.** One of possibly-nested variants defined in `MessageCategory` module. + * **CWE.** With a Common Weakness Enumeration number. +3. **Content.** One of the following: + * **Single.** Contains the following: + 1. **Text.** + 2. **Location.** + 3. **Context.** Currently completely abstract, so not very useful. + * **Group.** For messages related to numerous locations with different texts. Contains the following: + 1. **Group text.** An overall description of the group message. + 2. **Pieces.** A list of single messages as described above. + +## Creating + +### OCaml + +In OCaml code, messages can be created using convenience functions in `Messages`. +For example: +```ocaml +Messages.warn "Text"; +Messages.debug "Text"; (* severity functions *) +Messages.warn "Text %s %d %a" "foo" 42 Cil.d_exp exp; (* Pretty format *) +Messages.warn ~category:Messages.Category.Integer.overflow "Text"; (* category *) +Messages.warn ~category:Messages.Category.Integer.overflow ~tags:[Messages.Tag.CWE 190] "Text"; (* extra tags *) +``` + +The `~category` argument is optional and defaults to `Unknown`, but all newly added messages should have non-unknown category. New categories should be defined if necessary. + +The `~tags` argument is optional and allows an arbitrary list of tags (including multiple different categories). The `~category` argument is simply for convenience to add one category tag. + +By convention, may-warnings (the usual case) should use warning severity and must-warnings should use error severity. + +### Spec analysis + +Warnings inside `.spec` files are converted to warnings. +They parsed from string warnings: the first space-delimited substring determines the category and the rest determines the text. + +For example: +``` +w1 "behavior.undefined.use_after_free" +w2 "integer.overflow" +w3 "unknown my message" +w4 "integer.overflow some text describing the warning" +``` diff --git a/mkdocs.yml b/mkdocs.yml index d34fd8cac1..9beeb11b76 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -24,6 +24,7 @@ nav: - developer-guide/testing.md - developer-guide/debugging.md - developer-guide/warning.md + - developer-guide/messaging.md - developer-guide/profiling.md - developer-guide/documenting.md - 'Artifact descriptions': From f9bec05e9bf6535d3591f61fc3c2294f08739f8f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:37:16 +0300 Subject: [PATCH 84/95] Remove outdated warning documentation --- docs/developer-guide/warning.md | 93 --------------------------------- mkdocs.yml | 1 - 2 files changed, 94 deletions(-) delete mode 100644 docs/developer-guide/warning.md diff --git a/docs/developer-guide/warning.md b/docs/developer-guide/warning.md deleted file mode 100644 index fbc7fa4457..0000000000 --- a/docs/developer-guide/warning.md +++ /dev/null @@ -1,93 +0,0 @@ -# Warning - -## Types of warnings - -Types of warnings form the following tree structure: - -- Assert -- Behavior (`behavior`) - - Undefined (`undefined`) - - ArrayOutOfBounds (`array_out_of_bounds`) - - BeforeStart (`before_start`) - - PastEnd (`past_end`) - - Unknown (`unknown`) - - NullPointerDereference (`nullpointer_dereference`) - - UseAfterFree (`use_after_free`) - - Machine (`machine`) - - Implementation (`implementation`) -- Integer (`integer`) - - Overflow (`overflow`) - - DivByZero (`div_by_zero`) -- Cast (`cast`) - - TypeMismatch (`type_mismatch`) -- Race (`race`) -- Analyzer (`analyzer`) -- Unknown (`unknown`) - -## Output - -All warnings (except for `Debug`) are prepended with a tag `[Warning]`. This -enables easier detection in the test suite. - -Next follows the tag determining certainty of the warning - either `[May]` or -`[Must]`. After that, the category is printed - for example `[Behavior > Undefined > NullPointerDereference]`. For some types there can be a custom -message after the category too (for example formatting some values passed to the -leaf variant or just printing out the warning more verbosely - see -ArrayOutOfBounds). - -The optional message parameter of the functions is printed at the very end. - -## OCaml - -`Messages.warn` and `Messages.warn_each` can be used to print warnings from Goblint. - -To construct a nested variant, use one of the provided functions. Example for -`NullPointerDereference`: -`Messages.Warning.Behavior.Undefined.nullpointer_dereference ()`. The paths and -names correspond to the tree at the top of the page. - -Other examples: - -```ocaml -Messages.Unknown -Messages.Cast.type_mismatch () -Messages.Integer.overlow () -Messages.Behavior.Undefined.ArrayOutOfBounds.past_end () -``` - -The warning type is given by an optional parameter `warning` (By default -`Unknown`). Both functions also have an optional parameter `must` (by default -`false` -> `May`) to determine certainty, a parameter `ctx` to give context and -`msg` to pass an optional string message to print at the end of the warning. -Moreover, the `warn_each` function also has a parameter `loc` to supply location. - -Examples of calls to `warn` and `warn_each`: - -```ocaml -Messages.warn ~warning:(Messages.Warning.Integer.overflow ()) () -Messages.warn_each ~must:true ~warning:(Messages.Warning.Behavior.Undefined.nullpointer_dereference ()) () -Messages.warn ~msg:"I don't know what type of warning this is" () -Messages.warn ~must:true ~msg:"I don't know what type of warning this is" () -Messages.warn ~msg:"my message" ~warning:(Messages.Warning.Behavior.Undefined.nullpointer_dereference ()) () -Messages.warn_each ~loc:location ~msg:"my message" ~warning:Messages.Race () -``` - -## Spec files - -Warnings inside spec files are also converted to the warning types. Currently -the warnings are parsed from the string warnings. The first space delimited -group of characters is consumed and converted to a warning. The rest is passed -as an optional message. - -Examples: - -``` -w1 "behavior.undefined.use_after_free" -w2 "integer.overflow" -w3 "unknown my message" -w4 "integer.overflow some text describing the warning" -``` - -The categories are given as dot delimited strings. For the possible values, see -the tree of categories at the top of the page - the strings in parentheses are -used in spec files. diff --git a/mkdocs.yml b/mkdocs.yml index 9beeb11b76..12279f6e18 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -23,7 +23,6 @@ nav: - developer-guide/developing.md - developer-guide/testing.md - developer-guide/debugging.md - - developer-guide/warning.md - developer-guide/messaging.md - developer-guide/profiling.md - developer-guide/documenting.md From effdb8b85389598ca990291623889782f23038e3 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:37:55 +0300 Subject: [PATCH 85/95] Move messaging up in documentation navigation --- mkdocs.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mkdocs.yml b/mkdocs.yml index 12279f6e18..8d7861c8a7 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -21,9 +21,9 @@ nav: - user-guide/inspecting.md - 'Developer guide': - developer-guide/developing.md + - developer-guide/messaging.md - developer-guide/testing.md - developer-guide/debugging.md - - developer-guide/messaging.md - developer-guide/profiling.md - developer-guide/documenting.md - 'Artifact descriptions': From f1b40ab8f2c4221858f623be4d46dce18bb3d74f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:41:31 +0300 Subject: [PATCH 86/95] Use List.concat instead of BatList.concat_map for OCaml 4.09 --- src/util/messageUtil.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/util/messageUtil.ml b/src/util/messageUtil.ml index 35a7cfba85..d05e0c93dc 100644 --- a/src/util/messageUtil.ml +++ b/src/util/messageUtil.ml @@ -4,11 +4,13 @@ let ansi_color_table = let colors = [("gray", "30"); ("red", "31"); ("green", "32"); ("yellow", "33"); ("blue", "34"); ("violet", "35"); ("turquoise", "36"); ("white", "37"); ("reset", "0;00")] in let modes = [(Fun.id, "0" (* normal *)); (String.uppercase_ascii, "1" (* bold *))] in - BatList.concat_map (fun (color, color_code) -> + colors + |> List.map (fun (color, color_code) -> List.map (fun (mode_fn, mode_code) -> (mode_fn color, Format.sprintf "\027[%s;%sm" mode_code color_code) ) modes - ) colors + ) + |> List.concat let colors_on () = (* use colors? *) let c = get_string "colors" in From 9e6dd956331efedaa0dbb844b8e7611e808a9a6e Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:51:01 +0300 Subject: [PATCH 87/95] Fix MessageUtil.colors_on always checking stdout --- src/maingoblint.ml | 6 +++--- src/util/arincUtil.ml | 2 +- src/util/messageUtil.ml | 7 ++++--- src/util/messages.ml | 2 +- 4 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/maingoblint.ml b/src/maingoblint.ml index ca93c6e041..910ce6811a 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -358,7 +358,7 @@ let do_html_output () = ) let check_arguments () = - let eprint_color m = eprintf "%s\n" (MessageUtil.colorize m) in + let eprint_color m = eprintf "%s\n" (MessageUtil.colorize ~fd:Unix.stderr m) in (* let fail m = let m = "Option failure: " ^ m in eprint_color ("{red}"^m); failwith m in *) (* unused now, but might be useful for future checks here *) let warn m = eprint_color ("{yellow}Option warning: "^m) in if get_bool "allfuns" && not (get_bool "exp.earlyglobs") then (set_bool "exp.earlyglobs" true; warn "allfuns enables exp.earlyglobs.\n"); @@ -465,10 +465,10 @@ let main () = exit 1 | Sys.Break -> (* raised on Ctrl-C if `Sys.catch_break true` *) (* Printexc.print_backtrace BatInnerIO.stderr *) - eprintf "%s\n" (MessageUtil.colorize ("{RED}Analysis was aborted by SIGINT (Ctrl-C)!")); + eprintf "%s\n" (MessageUtil.colorize ~fd:Unix.stderr ("{RED}Analysis was aborted by SIGINT (Ctrl-C)!")); exit 131 (* same exit code as without `Sys.catch_break true`, otherwise 0 *) | Timeout -> - eprintf "%s\n" (MessageUtil.colorize ("{RED}Analysis was aborted because it reached the set timeout of " ^ get_string "dbg.timeout" ^ " or was signalled SIGPROF!")); + eprintf "%s\n" (MessageUtil.colorize ~fd:Unix.stderr ("{RED}Analysis was aborted because it reached the set timeout of " ^ get_string "dbg.timeout" ^ " or was signalled SIGPROF!")); exit 124 (* The actual entry point is in the auto-generated goblint.ml module, and is defined as: *) diff --git a/src/util/arincUtil.ml b/src/util/arincUtil.ml index 3fa1377103..0bd750ef95 100644 --- a/src/util/arincUtil.ml +++ b/src/util/arincUtil.ml @@ -1,7 +1,7 @@ open Prelude open Cil (* we don't want to use M.debug_each because everything here should be done after the analysis, so the location would be some old value for all invocations *) -let debug_each msg = print_endline @@ MessageUtil.colorize @@ "{blue}"^msg +let debug_each msg = print_endline @@ MessageUtil.colorize ~fd:Unix.stdout @@ "{blue}"^msg (* ARINC types and Hashtables for collecting CFG *) type resource = Process | Function | Semaphore | Event | Logbook | SamplingPort | QueuingPort | Buffer | Blackboard [@@deriving show { with_path = false }] diff --git a/src/util/messageUtil.ml b/src/util/messageUtil.ml index d05e0c93dc..3826754b5c 100644 --- a/src/util/messageUtil.ml +++ b/src/util/messageUtil.ml @@ -12,11 +12,12 @@ let ansi_color_table = ) |> List.concat -let colors_on () = (* use colors? *) +let colors_on fd = (* use colors? *) let c = get_string "colors" in - c = "always" || c = "auto" && Unix.(isatty stdout) + c = "always" || c = "auto" && Unix.(isatty fd) -let colorize ?on:(on=colors_on ()) msg = +let colorize ~fd msg = + let on = colors_on fd in let replace (color,code) = Str.global_replace (Str.regexp ("{"^color^"}")) (if on then code else "") in diff --git a/src/util/messages.ml b/src/util/messages.ml index f7225cd241..2e7648cd53 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -137,7 +137,7 @@ end let formatter = ref Format.std_formatter let () = AfterConfig.register (fun () -> - if !formatter == Format.std_formatter && MessageUtil.colors_on () then + if !formatter == Format.std_formatter && MessageUtil.colors_on Unix.stdout then GobFormat.pp_set_ansi_color_tags !formatter ) From d0497eb7ab0e62890b5ad84fdc062dad3ef64374 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 11:55:43 +0300 Subject: [PATCH 88/95] Use pretty instead of show for warnings in Deadlock --- src/analyses/deadlock.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index 6defb426c4..07096ce3bd 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -27,9 +27,8 @@ struct if !Goblintutil.in_verifying_stage then begin D.iter (fun e -> List.iter (fun (a,b) -> if ((MyLock.equal a e) && (MyLock.equal b newLock)) then ( - (* TODO: use pretty instead of show *) - Messages.warn_each "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show e.addr) (ValueDomain.Addr.show newLock.addr) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc) (CilType.Location.show b.loc) (CilType.Location.show a.loc); - Messages.warn_each ~loc:a.loc "Deadlock warning: Locking order %s, %s at %s, %s violates order at %s, %s." (ValueDomain.Addr.show newLock.addr) (ValueDomain.Addr.show e.addr) (CilType.Location.show b.loc) (CilType.Location.show a.loc) (CilType.Location.show e.loc) (CilType.Location.show newLock.loc); + Messages.warn_each "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty e.addr ValueDomain.Addr.pretty newLock.addr CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc CilType.Location.pretty b.loc CilType.Location.pretty a.loc; + Messages.warn_each ~loc:a.loc "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty newLock.addr ValueDomain.Addr.pretty e.addr CilType.Location.pretty b.loc CilType.Location.pretty a.loc CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc; ) else () ) !forbiddenList ) lockList; From 0260ea4d2fdd669239efb62b329fd9b637325698 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Wed, 1 Sep 2021 12:01:33 +0300 Subject: [PATCH 89/95] Remove useless unit statements in MessageCategory --- src/util/messageCategory.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/util/messageCategory.ml b/src/util/messageCategory.ml index 2c57051dfd..a4e562c334 100644 --- a/src/util/messageCategory.ml +++ b/src/util/messageCategory.ml @@ -98,7 +98,7 @@ struct let from_string_list (s: string list): category = match s with | [] -> Unknown - | h :: t -> ();match h with + | h :: t -> match h with | "undefined" -> Undefined.from_string_list t | "implementation" -> implementation | "machine" -> machine @@ -122,7 +122,7 @@ struct let from_string_list (s: string list): category = match s with | [] -> Unknown - | h :: t -> ();match h with + | h :: t -> match h with | "overflow" -> overflow | "div_by_zero" -> div_by_zero | _ -> Unknown @@ -143,7 +143,7 @@ struct let from_string_list (s: string list): category = match s with | [] -> Unknown - | h :: t -> ();match h with + | h :: t -> match h with | "type_mismatch" -> type_mismatch | _ -> Unknown From b3e30c88f0c7f79e13fb5e842d57f29da17de783 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:21:10 +0300 Subject: [PATCH 90/95] Remove non-each message functions --- src/analyses/base.ml | 18 +++++++++--------- src/analyses/deadlock.ml | 2 +- src/analyses/fileUse.ml | 24 ++++++++++++------------ src/analyses/mayLocks.ml | 2 +- src/analyses/mutexAnalysis.ml | 2 +- src/analyses/region.ml | 2 +- src/analyses/spec.ml | 20 ++++++++++---------- src/analyses/symbLocks.ml | 4 ++-- src/analyses/threadEscape.ml | 2 +- src/analyses/uninit.ml | 6 +++--- src/cdomains/containDomain.ml | 2 +- src/cdomains/intDomain.ml | 4 ++-- src/cdomains/lvalMapDomain.ml | 2 +- src/cdomains/regionDomain.ml | 2 +- src/cdomains/shapeDomain.ml | 2 +- src/cdomains/valueDomain.ml | 22 +++++++++++----------- src/framework/analyses.ml | 2 +- src/framework/control.ml | 2 +- src/util/messages.ml | 12 ------------ 19 files changed, 60 insertions(+), 72 deletions(-) diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 810a0dd1c3..f51b716d7a 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -359,7 +359,7 @@ struct match value with | `Top -> if VD.is_immediate_type t then () else M.warn_each "Unknown value in %s could be an escaped pointer address!" description; empty - | `Bot -> (*M.debug "A bottom value when computing reachable addresses!";*) empty + | `Bot -> (*M.debug_each "A bottom value when computing reachable addresses!";*) empty | `Address adrs when AD.is_top adrs -> M.warn_each "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) (* The main thing is to track where pointers go: *) @@ -676,7 +676,7 @@ struct if contains_vla t || contains_vla (get_type_addr a) then begin (* TODO: Is this ok? *) - M.warn "Casting involving a VLA is assumed to work"; + M.warn_each "Casting involving a VLA is assumed to work"; true end else @@ -807,7 +807,7 @@ struct do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in - M.debug "Failed evaluating %s to lvalue" str; do_offs AD.unknown_ptr ofs + M.debug_each "Failed evaluating %s to lvalue" str; do_offs AD.unknown_ptr ofs end (* run eval_rv from above and keep a result that is bottom *) @@ -829,8 +829,8 @@ struct let r = match eval_rv_no_ask_evalint ask gs st e with | `Int i -> i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | `Bot -> Queries.ID.bot () (* TODO: remove? *) - (* | v -> M.warn ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) - | v -> M.debug "Query function answered %a" VD.pretty v; Queries.ID.bot () + (* | v -> M.warn_each ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) + | v -> M.debug_each "Query function answered %a" VD.pretty v; Queries.ID.bot () in if M.tracing then M.traceu "evalint" "base query_evalint %a -> %a\n" d_exp e Queries.ID.pretty r; r @@ -1067,7 +1067,7 @@ struct with Cilfacade.TypeOfError _ -> (* If we cannot determine the correct type here, we go with the one of the LVal *) (* This will usually lead to a type mismatch in the ValueDomain (and hence supertop) *) - M.warn "Cilfacade.typeOfLval failed Could not obtain the type of %a" d_lval (Var x, cil_offset); + M.warn_each "Cilfacade.typeOfLval failed Could not obtain the type of %a" d_lval (Var x, cil_offset); lval_type in let update_offset old_value = @@ -1393,7 +1393,7 @@ struct let inv_bin_int (a, b) ikind c op = let warn_and_top_on_zero x = if GU.opt_predicate (BI.equal BI.zero) (ID.to_int x) then - (M.warn "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + (M.warn_each "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; ID.top_of ikind) else x @@ -1652,7 +1652,7 @@ struct let rval_val = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in let lval_val = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) - (* M.debug @@ sprint ~width:80 @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) + (* M.debug_each @@ sprint ~width:80 @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = let not_local x = match Addr.to_var_may x with @@ -1775,7 +1775,7 @@ struct | None -> nst | Some exp -> let t_override = match Cilfacade.fundec_return_type fundec with - | TVoid _ -> M.warn "Returning a value from a void function"; assert false + | TVoid _ -> M.warn_each "Returning a value from a void function"; assert false | ret -> ret in (* Evaluate exp and cast the resulting value to the void-pointer-type. diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index 07096ce3bd..f376d828f6 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -94,7 +94,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] + | b -> Messages.warn_each "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* Called when calling a special/unknown function *) let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml index 3c6c3317df..9874ea16e1 100644 --- a/src/analyses/fileUse.ml +++ b/src/analyses/fileUse.ml @@ -33,7 +33,7 @@ struct let print_query_lv ?msg:(msg="") ask exp = let xs = query_lv ask exp in (* MayPointTo -> LValSet *) let pretty_key k = Pretty.text (D.string_of_key k) in - Messages.debug "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs + Messages.debug_each "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs let eval_fv ask exp: varinfo option = match query_lv ask exp with @@ -47,7 +47,7 @@ struct | _ -> [] let print_query_eq ?msg:(msg="") ask exp = let xs = query_eq ask exp in (* EqualSet -> ExpSet *) - Messages.debug "%s EqualSet %a = [%a]" msg d_exp exp (Pretty.d_list ", " d_exp) xs + Messages.debug_each "%s EqualSet %a = [%a]" msg d_exp exp (Pretty.d_list ", " d_exp) xs (* transfer functions *) let assign ctx (lval:lval) (rval:exp) : D.t = @@ -67,20 +67,20 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* we just care about Lval assignments *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); D.alias k1 k2 m | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; + M.debug_each "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; saveOpened ~unknown:true k1 m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; + M.debug_each "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m let branch ctx (exp:exp) (tv:bool) : D.t = @@ -98,7 +98,7 @@ struct D.error k m )else D.success k m - | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m + | _ -> M.debug_each "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -108,7 +108,7 @@ struct ignore(printf "%s %i\n" v.vname (Int64.to_int i)); m *) | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m + | e -> M.debug_each "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = (* M.debug_each @@ "body of function "^f.svar.vname; *) @@ -195,11 +195,11 @@ struct else (* v is now a local which is not top or a global which is aliased *) let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug @@ vvar.vname^" was a global -> alias" in *) + (* let _ = M.debug_each @@ vvar.vname^" was a global -> alias" in *) D.alias k vvar m else (* returned variable was a local *) let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug @@ vvar.vname^" was a local -> rebind"; *) + (* M.debug_each @@ vvar.vname^" was a local -> rebind"; *) D.add' k v m | _ -> m @@ -259,7 +259,7 @@ struct ) | xs -> let args = (String.concat ", " (List.map (sprint d_exp) xs)) in - M.debug "fopen args: %s" args; + M.debug_each "fopen args: %s" args; (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) xs; *) D.warn @@ "fopen needs two strings as arguments, given: "^args; m ) diff --git a/src/analyses/mayLocks.ml b/src/analyses/mayLocks.ml index cf33e696be..83a611e89c 100644 --- a/src/analyses/mayLocks.ml +++ b/src/analyses/mayLocks.ml @@ -34,7 +34,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] + | b -> Messages.warn_each "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* locking logic -- add all locks we can add *) let lock ctx rw may_fail return_value_on_success a lv arglist ls : D.ReverseAddrSet.t = diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index b0113d5db6..e619ccdff5 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -148,7 +148,7 @@ struct let ls = Lockset.filter snd ctx.local in let el = P.effect_fun ~write:w ls in ctx.sideg v el - | None -> M.warn "Write to unknown address: privatization is unsound." + | None -> M.warn_each "Write to unknown address: privatization is unsound." end; (*partitions & locks*) diff --git a/src/analyses/region.ml b/src/analyses/region.ml index ebbd1ffa64..fab7878586 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -27,7 +27,7 @@ struct let ev = Reg.eval_exp exp in let to_exp (v,f) = (v,Lval.Fields.to_offs' f) in List.map to_exp (Reg.related_globals ev (part,reg)) - | `Top -> Messages.warn "Region state is broken :("; [] + | `Top -> Messages.warn_each "Region state is broken :("; [] | `Bot -> [] let is_bullet exp part st : bool = diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml index 776055da03..32be8dff70 100644 --- a/src/analyses/spec.ml +++ b/src/analyses/spec.ml @@ -133,7 +133,7 @@ struct let may = (List.length keys > 1) in (* do not change state for reflexive edges where the key is not assigned to (e.g. *$p = _) *) let change_state = not (old_a=b && SC.get_lval c <> Some `Var) in - M.debug "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); + M.debug_each "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); let new_m = goto ~may:may ~change_state:change_state var b m ws in (new_m,n+1) in @@ -242,23 +242,23 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* TODO for now we just care about Lval assignments -> should use Queries.MayPointTo *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug_each "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); let m = D.alias k1 k2 m in (* point k1 to k2 *) if Lval.CilLval.class_tag k2 = `Temp (* check if k2 is a temporary Lval introduced by CIL *) then D.remove' k2 m (* if yes we need to remove it from our map *) else m (* otherwise no change *) | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; + M.debug_each "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; (* saveOpened ~unknown:true k1 *) m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; + M.debug_each "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m (* @@ -359,7 +359,7 @@ struct let v2 = D.V.set_state b value in (* M.debug_each @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) D.add key v2 m - | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m + | _ -> M.debug_each "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -369,7 +369,7 @@ struct | UnOp (LNot, a, _) -> check (stripCasts a) (integer 0) tv (* TODO makes 2 tests fail. probably check changes something it shouldn't *) (* | Lval _ as a -> check (stripCasts a) (integer 0) (not tv) *) - | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m + | e -> M.debug_each "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = ctx.local @@ -440,11 +440,11 @@ struct else (* v is now a local which is not top or a global which is aliased *) let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug @@ vvar.vname^" was a global -> alias" in *) + (* let _ = M.debug_each @@ vvar.vname^" was a global -> alias" in *) D.alias k vvar au else (* returned variable was a local *) let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug @@ vvar.vname^" was a local -> rebind"; *) + (* M.debug_each @@ vvar.vname^" was a local -> rebind"; *) D.add' k v au | _ -> au diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index 03000d24c3..784423a463 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -82,7 +82,7 @@ struct | `Unlock -> D.remove (Analyses.ask_of_ctx ctx) (List.hd arglist) ctx.local | `Unknown fn when VarEq.safe_fn fn -> - Messages.warn "Assume that %s does not change lockset." fn; + Messages.warn_each "Assume that %s does not change lockset." fn; ctx.local | `Unknown x -> begin let st = @@ -175,7 +175,7 @@ struct let lock = ValueDomain.Addr.from_var_offset (v, conv_const_offset o) in LSSet.add ("i-lock",ValueDomain.Addr.show lock) xs | _ -> - Messages.warn "Internal error: found a strange lockstep pattern."; + Messages.warn_each "Internal error: found a strange lockstep pattern."; xs in let do_perel e xs = diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index f8dbc07099..4555f968e7 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -12,7 +12,7 @@ let has_escaped (ask: Queries.ask) (v: varinfo): bool = else ask.f (Queries.MayEscape v) (* | Top -> - M.warn @@ "Variable " ^ v.vname ^ " considered escaped since its address is taken somewhere and the thread escape analysis is not active!"; + M.warn_each @@ "Variable " ^ v.vname ^ " considered escaped since its address is taken somewhere and the thread escape analysis is not active!"; true *) diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index a6ae369da1..6aab1b3a5c 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -46,7 +46,7 @@ struct let to_extra (v,o) xs = (v, Base.Offs.from_offset (conv_offset o), write) :: xs in Queries.LS.fold to_extra a [] | _ -> - M.warn "Access to unknown address could be global"; [] + M.warn_each "Access to unknown address could be global"; [] let rec access_one_byval a rw (exp:exp) = match exp with @@ -162,7 +162,7 @@ struct | x::xs, y::ys -> [] (* found a mismatch *) | _ -> - M.warn "Failed to analyze union at point %a -- did not find %s" Addr.pretty (Addr.from_var_offset (v,rev cx)) tf.fname; + M.warn_each "Failed to analyze union at point %a -- did not find %s" Addr.pretty (Addr.from_var_offset (v,rev cx)) tf.fname; [] in let utar, uoth = unrollType target, unrollType other in @@ -190,7 +190,7 @@ struct (* step into all other fields *) List.concat (List.rev_map (fun oth_f -> get_pfx v (`Field (oth_f, cx)) ofs utar oth_f.ftype) c2.cfields) | _ -> - M.warn "Failed to analyze union at point %a" Addr.pretty (Addr.from_var_offset (v,rev cx)); + M.warn_each "Failed to analyze union at point %a" Addr.pretty (Addr.from_var_offset (v,rev cx)); [] diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index 0582d85f43..cb02b60ec5 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -1333,7 +1333,7 @@ struct let assign_argmap fs lval exp (fd, st, df) must_assign glob = (*keep track of used fun args*) match used_args st exp with | s when ArgSet.is_top s -> - Messages.warn "Expression %a too complicated." d_exp exp; + Messages.warn_each "Expression %a too complicated." d_exp exp; fd, st, df | s when ArgSet.is_bot s -> let vars= get_vars exp in let s = List.fold_left (fun y x->if not (is_safe_name x.vname) then begin ArgSet.add (FieldVars.gen x) y end else y) (ArgSet.empty()) vars in diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index 67ffc06b82..fcbc00d045 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -539,7 +539,7 @@ struct let set_overflow_flag ik = if Cil.isSigned ik && !GU.in_verifying_stage then ( Goblintutil.did_overflow := true; - M.warn ~category:M.Category.Integer.overflow ~tags:[M.Tag.CWE 190] "Integer overflow" + M.warn_each ~category:M.Category.Integer.overflow ~tags:[M.Tag.CWE 190] "Integer overflow" ) let norm ik = function None -> None | Some (x,y) -> @@ -1298,7 +1298,7 @@ struct v ) else if should_ignore_overflow ik then ( - M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + M.warn_each ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; `Bot ) else ( diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index aef4b2bd38..c7326e2b21 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -275,6 +275,6 @@ struct let exp = AddrOf lval in let xs = query_lv ask exp in (* MayPointTo -> LValSet *) let pretty_key k = Pretty.text (string_of_key k) in - Messages.debug "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs; + Messages.debug_each "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs; xs end diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index a8480ef301..352337f9df 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -256,7 +256,7 @@ struct List.map (add_o os) (RS.to_vf_list vfd_class) | Some (false, vfd, os) -> if is_global vfd then [vfd] else [] - | None -> Messages.warn "Access to unknown address could be global"; [] + | None -> Messages.warn_each "Access to unknown address could be global"; [] end (* TODO: remove Lift *) diff --git a/src/cdomains/shapeDomain.ml b/src/cdomains/shapeDomain.ml index a845b7ad8e..9ab6c692e8 100644 --- a/src/cdomains/shapeDomain.ml +++ b/src/cdomains/shapeDomain.ml @@ -180,7 +180,7 @@ let eval_lp ask (e:exp) : lexp option = | _ -> None -let warn_todo s = Messages.warn "NotImplemented exception! %s" s +let warn_todo s = Messages.warn_each "NotImplemented exception! %s" s let alias_top lp = SHMap.remove lp diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index 12a2430846..e190ed7e39 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -764,14 +764,14 @@ struct (*hack for lists*) begin match f ad with | `List l -> `Address (Lists.entry_rand l) - | _ -> M.warn "Trying to read a field, but was not given a struct"; top () + | _ -> M.warn_each "Trying to read a field, but was not given a struct"; top () end | `Struct str -> let x = Structs.get str fld in let l', o' = shift_one_over l o in do_eval_offset ask f x offs exp l' o' v t - | `Top -> M.debug "Trying to read a field, but the struct is unknown"; top () - | _ -> M.warn "Trying to read a field, but was not given a struct"; top () + | `Top -> M.debug_each "Trying to read a field, but the struct is unknown"; top () + | _ -> M.warn_each "Trying to read a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin match x with @@ -780,8 +780,8 @@ struct let l', o' = shift_one_over l o in do_eval_offset ask f x offs exp l' o' v t | `Union (_, valu) -> top () - | `Top -> M.debug "Trying to read a field, but the union is unknown"; top () - | _ -> M.warn "Trying to read a field, but was not given a union"; top () + | `Top -> M.debug_each "Trying to read a field, but the union is unknown"; top () + | _ -> M.warn_each "Trying to read a field, but was not given a union"; top () end | `Index (idx, offs) -> begin let l', o' = shift_one_over l o in @@ -794,8 +794,8 @@ struct do_eval_offset ask f x offs exp l' o' v t (* this used to be `blob `address -> we ignore the index *) end | x when Goblintutil.opt_predicate (BI.equal (BI.zero)) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t - | `Top -> M.debug "Trying to read an index, but the array is unknown"; top () - | _ -> M.warn "Trying to read an index, but was not given an array (%a)" pretty x; top () + | `Top -> M.debug_each "Trying to read an index, but the array is unknown"; top () + | _ -> M.warn_each "Trying to read an index, but was not given an array (%a)" pretty x; top () end in let l, o = match exp with @@ -856,8 +856,8 @@ struct let strc = init_comp fld.fcomp in let l', o' = shift_one_over l o in `Struct (Structs.replace strc fld (do_update_offset ask `Bot offs value exp l' o' v t)) - | `Top -> M.warn "Trying to update a field, but the struct is unknown"; top () - | _ -> M.warn "Trying to update a field, but was not given a struct"; top () + | `Top -> M.warn_each "Trying to update a field, but the struct is unknown"; top () + | _ -> M.warn_each "Trying to update a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin let t = fld.ftype in @@ -891,7 +891,7 @@ struct in `Union (`Lifted fld, do_update_offset ask tempval tempoffs value exp l' o' v t) | `Bot -> `Union (`Lifted fld, do_update_offset ask `Bot offs value exp l' o' v t) - | `Top -> M.warn "Trying to update a field, but the union is unknown"; top () + | `Top -> M.warn_each "Trying to update a field, but the union is unknown"; top () | _ -> M.warn_each "Trying to update a field, but was not given a union"; top () end | `Index (idx, offs) -> begin @@ -914,7 +914,7 @@ struct let new_value_at_index = do_update_offset ask `Bot offs value exp l' o' v t in let new_array_value = CArrays.set ask x' (e, idx) new_value_at_index in `Array new_array_value - | `Top -> M.warn "Trying to update an index, but the array is unknown"; top () + | `Top -> M.warn_each "Trying to update an index, but the array is unknown"; top () | x when Goblintutil.opt_predicate (BI.equal BI.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t | _ -> M.warn_each "Trying to update an index, but was not given an array(%a)" pretty x; top () end diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index f1881a5414..f885a123c7 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -471,7 +471,7 @@ struct let vdecl ctx _ = ctx.local let asm x = - ignore (M.warn "ASM statement ignored."); + ignore (M.warn_each "ASM statement ignored."); x.local (* Just ignore. *) let skip x = x.local (* Just ignore. *) diff --git a/src/framework/control.ml b/src/framework/control.ml index f0d2b2cbb4..d1b6d962e3 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -166,7 +166,7 @@ struct (* If the function is not defined, and yet has been included to the * analysis result, we generate a warning. *) with Not_found -> - Messages.warn "Calculated state for undefined function: unexpected node %a" Node.pretty_plain n + Messages.warn_each "Calculated state for undefined function: unexpected node %a" Node.pretty_plain n in LHT.iter add_local_var h; res diff --git a/src/util/messages.ml b/src/util/messages.ml index 2e7648cd53..6c34c3dff5 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -217,14 +217,6 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) - -let msg severity ?(tags=[]) ?(category=Category.Unknown) fmt = - let finish doc = - let text = Pretty.sprint ~width:max_int doc in - add {tags = Category category :: tags; severity; multipiece = Single {loc = None; text; context = !current_context; print_loc = !Tracing.current_loc}} - in - Pretty.gprintf finish fmt - let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) fmt = let finish doc = let text = Pretty.sprint ~width:max_int doc in @@ -233,14 +225,10 @@ let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Cat Pretty.gprintf finish fmt (* must eta-expand to get proper (non-weak) polymorphism for format *) -let warn ?tags = msg Warning ?tags let warn_each ?loc = msg_each Warning ?loc -(* TODO: error? *) let error_each ?loc = msg_each Error ?loc (* TODO: info *) -let debug ?tags = msg Debug ?tags let debug_each ?loc = msg_each Debug ?loc -(* TODO: success? *) let success_each ?loc = msg_each Success ?loc include Tracing From 23302ef400571420548d288246f465e2fd226d19 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:30:52 +0300 Subject: [PATCH 91/95] Remove print_loc from message --- src/framework/analyses.ml | 8 ++++++-- src/solvers/generic.ml | 8 ++++++-- src/util/messages.ml | 10 +++++----- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index f885a123c7..3eb8ec34a2 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -144,8 +144,12 @@ struct iter print_one xs let printXmlWarning f () = - let one_text f Messages.Piece.{print_loc = l; text = m; _} = - BatPrintf.fprintf f "\n%s" l.file l.line l.column (GU.escape m) + let one_text f Messages.Piece.{loc; text = m; _} = + match loc with + | Some l -> + BatPrintf.fprintf f "\n%s" l.file l.line l.column (GU.escape m) + | None -> + () (* TODO: not outputting warning without location *) in let one_w f (m: Messages.Message.t) = match m.multipiece with | Single piece -> one_text f piece diff --git a/src/solvers/generic.ml b/src/solvers/generic.ml index 8e3d4a2510..7f5dd8edc2 100644 --- a/src/solvers/generic.ml +++ b/src/solvers/generic.ml @@ -140,8 +140,12 @@ struct let warning_id = ref 1 let writeXmlWarnings () = - let one_text f Messages.Piece.{print_loc = l; text = m; _} = - fprintf f "\n%s" l.file l.line l.column m + let one_text f Messages.Piece.{loc; text = m; _} = + match loc with + | Some l -> + BatPrintf.fprintf f "\n%s" l.file l.line l.column (GU.escape m) + | None -> + () (* TODO: not outputting warning without location *) in let one_w f (m: Messages.Message.t) = match m.multipiece with | Single piece -> one_text f piece diff --git a/src/util/messages.ml b/src/util/messages.ml index 6c34c3dff5..8ec146ec30 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -35,10 +35,9 @@ struct loc: CilType.Location.t option; (* only *_each warnings have this, used for deduplication *) text: string; context: (Obj.t [@equal fun x y -> Hashtbl.hash (Obj.obj x) = Hashtbl.hash (Obj.obj y)] [@to_yojson fun x -> `Int (Hashtbl.hash (Obj.obj x))]) option; (* TODO: this equality is terrible... *) - print_loc: CilType.Location.t [@equal fun _ _ -> true]; (* all warnings have this, not used for deduplication *) } [@@deriving eq, to_yojson] - let hash {loc; text; context; print_loc} = + let hash {loc; text; context} = 7 * BatOption.map_default CilType.Location.hash 1 loc + 9 * Hashtbl.hash text + 11 * BatOption.map_default (fun c -> Hashtbl.hash (Obj.obj c)) 1 context let text_with_context {text; context; _} = @@ -179,7 +178,8 @@ let print ?(ppf= !formatter) (m: Message.t) = in let pp_prefix = Format.dprintf "@{<%s>[%a]%a@}" severity_stag Severity.pp m.severity Tags.pp m.tags in let pp_piece ppf piece = - Format.fprintf ppf "@{<%s>%s@} @{(%a)@}" severity_stag (Piece.text_with_context piece) CilType.Location.pp piece.print_loc + let pp_loc ppf = Format.fprintf ppf " @{(%a)@}" CilType.Location.pp in + Format.fprintf ppf "@{<%s>%s@}%a" severity_stag (Piece.text_with_context piece) (Format.pp_print_option pp_loc) piece.loc in let pp_multipiece ppf = match m.multipiece with | Single piece -> @@ -201,7 +201,7 @@ let add m = (** Adapts old [print_group] to new message structure. Don't use for new (group) warnings. *) let warn_group_old group_name errors = - let m = Message.{tags = [Category Unknown]; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None; print_loc = loc}) errors}} in + let m = Message.{tags = [Category Unknown]; severity = Warning; multipiece = Group {group_text = group_name; pieces = List.map (fun (s, loc) -> Piece.{loc = Some loc; text = s; context = None}) errors}} in add m; if (get_bool "ana.osek.warnfiles") then @@ -220,7 +220,7 @@ let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) conte let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) fmt = let finish doc = let text = Pretty.sprint ~width:max_int doc in - add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context; print_loc = loc}} + add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context}} in Pretty.gprintf finish fmt From 452a0a3739bb6d54933335a1d08f237d069dc16f Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:34:19 +0300 Subject: [PATCH 92/95] Remove _each suffix from message functions --- src/analyses/arinc.ml | 42 ++++++++-------- src/analyses/base.ml | 66 ++++++++++++------------- src/analyses/commonPriv.ml | 2 +- src/analyses/condVars.ml | 4 +- src/analyses/contain.ml | 20 ++++---- src/analyses/deadlock.ml | 6 +-- src/analyses/extract_arinc.ml | 6 +-- src/analyses/extract_osek.ml | 4 +- src/analyses/fileUse.ml | 36 +++++++------- src/analyses/libraryFunctions.ml | 4 +- src/analyses/malloc_null.ml | 2 +- src/analyses/mayLocks.ml | 2 +- src/analyses/mutexAnalysis.ml | 2 +- src/analyses/osek.ml | 8 ++-- src/analyses/region.ml | 2 +- src/analyses/spec.ml | 82 ++++++++++++++++---------------- src/analyses/symbLocks.ml | 4 +- src/analyses/termination.ml | 2 +- src/analyses/threadEscape.ml | 2 +- src/analyses/uninit.ml | 8 ++-- src/analyses/varEq.ml | 26 +++++----- src/cdomains/arincDomain.ml | 4 +- src/cdomains/arrayDomain.ml | 10 ++-- src/cdomains/containDomain.ml | 22 ++++----- src/cdomains/intDomain.ml | 6 +-- src/cdomains/lvalMapDomain.ml | 6 +-- src/cdomains/regionDomain.ml | 4 +- src/cdomains/shapeDomain.ml | 6 +-- src/cdomains/valueDomain.ml | 38 +++++++-------- src/framework/analyses.ml | 2 +- src/framework/constraints.ml | 4 +- src/framework/control.ml | 4 +- src/maingoblint.ml | 2 +- src/util/arincUtil.ml | 2 +- src/util/cilfacade.ml | 2 +- src/util/messages.ml | 10 ++-- 36 files changed, 226 insertions(+), 226 deletions(-) diff --git a/src/analyses/arinc.ml b/src/analyses/arinc.ml index 431e3aef94..a539ae0b38 100644 --- a/src/analyses/arinc.ml +++ b/src/analyses/arinc.ml @@ -5,7 +5,7 @@ open Analyses module BI = IntOps.BigIntOps -let debug_doc doc = M.debug_each "%a" Pretty.insert doc +let debug_doc doc = M.debug "%a" Pretty.insert doc module Functions = struct let prefix = "LAP_Se_" @@ -146,7 +146,7 @@ struct let dummy_global_dlval = { dummyFunDec.svar with vname = "Gret" }, `NoOffset let global_dlval dlval fname = if Lval.CilLval.class_tag dlval = `Global then ( - M.debug_each "WARN: %s: use of global lval: %s" fname (str_return_dlval dlval); + M.debug "WARN: %s: use of global lval: %s" fname (str_return_dlval dlval); if GobConfig.get_bool "ana.arinc.merge_globals" then dummy_global_dlval else dlval ) else dlval let mayPointTo ctx exp = @@ -154,18 +154,18 @@ struct | a when not (Queries.LS.is_top a) && Queries.LS.cardinal a > 0 -> let top_elt = (dummyFunDec.svar, `NoOffset) in let a' = if Queries.LS.mem top_elt a then ( - M.debug_each "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) + M.debug "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) Queries.LS.remove top_elt a ) else a in Queries.LS.elements a' | v -> - M.debug_each "mayPointTo: query result for %a is %a" d_exp exp Queries.LS.pretty v; + M.debug "mayPointTo: query result for %a is %a" d_exp exp Queries.LS.pretty v; (*failwith "mayPointTo"*) [] let mustPointTo ctx exp = let xs = mayPointTo ctx exp in if List.length xs = 1 then Some (List.hd xs) else None let iterMayPointTo ctx exp f = mayPointTo ctx exp |> List.iter f - let debugMayPointTo ctx exp = M.debug_each "%a mayPointTo %a" d_exp exp (Pretty.d_list ", " Lval.CilLval.pretty) (mayPointTo ctx exp) + let debugMayPointTo ctx exp = M.debug "%a mayPointTo %a" d_exp exp (Pretty.d_list ", " Lval.CilLval.pretty) (mayPointTo ctx exp) (* transfer functions *) @@ -181,13 +181,13 @@ struct (* OPT: this matching is just for speed up to avoid querying on every assign *) match lval with Var _, _ when not @@ is_return_code_type (Lval lval) -> ctx.local | _ -> (* TODO why is it that current_node can be None here, but not in other transfer functions? *) - if not @@ Option.is_some !MyCFG.current_node then (M.debug_each "assign: MyCFG.current_node not set :("; ctx.local) else + if not @@ Option.is_some !MyCFG.current_node then (M.debug "assign: MyCFG.current_node not set :("; ctx.local) else if D.is_bot1 ctx.local then ctx.local else let env = get_env ctx in let edges_added = ref false in let f dlval = - (* M.debug_each @@ "assign: MayPointTo " ^ sprint d_plainlval lval ^ ": " ^ sprint d_plainexp (Lval.CilLval.to_exp dlval); *) - let is_ret_type = try is_return_code_type @@ Lval.CilLval.to_exp dlval with Cilfacade.TypeOfError Index_NonArray -> M.debug_each "assign: Cilfacade.typeOf %a threw exception Errormsg.Error \"Bug: typeOffset: Index on a non-array\". Will assume this is a return type to remain sound." d_exp (Lval.CilLval.to_exp dlval); true in + (* M.debug @@ "assign: MayPointTo " ^ sprint d_plainlval lval ^ ": " ^ sprint d_plainexp (Lval.CilLval.to_exp dlval); *) + let is_ret_type = try is_return_code_type @@ Lval.CilLval.to_exp dlval with Cilfacade.TypeOfError Index_NonArray -> M.debug "assign: Cilfacade.typeOf %a threw exception Errormsg.Error \"Bug: typeOffset: Index on a non-array\". Will assume this is a return type to remain sound." d_exp (Lval.CilLval.to_exp dlval); true in if (not is_ret_type) || Lval.CilLval.has_index dlval then () else let dlval = global_dlval dlval "assign" in edges_added := true; @@ -225,7 +225,7 @@ struct let else_node = NodeTbl.get @@ Branch (List.hd else_stmts) in let dst_node = if tv then then_node else else_node in let d_if = if List.length stmt.preds > 1 then ( (* seems like this never happens *) - M.debug_each "WARN: branch: If has more than 1 predecessor, will insert Nop edges!"; + M.debug "WARN: branch: If has more than 1 predecessor, will insert Nop edges!"; add_edges env ArincUtil.Nop; { ctx.local with pred = Pred.of_node env.node } ) else ctx.local @@ -253,11 +253,11 @@ struct | _ -> ctx.local let checkPredBot d tf f xs = - if d.pred = Pred.bot () then M.debug_each "%s: mapping is BOT!!! function: %s. %a" tf f.vname (Pretty.d_list "\n" (fun () (n, d) -> Pretty.dprintf "%s = %a" n Pred.pretty d.pred)) xs; + if d.pred = Pred.bot () then M.debug "%s: mapping is BOT!!! function: %s. %a" tf f.vname (Pretty.d_list "\n" (fun () (n, d) -> Pretty.dprintf "%s = %a" n Pred.pretty d.pred)) xs; d let body ctx (f:fundec) : D.t = (* enter is not called for spawned processes -> initialize them here *) - (* M.debug_each @@ "BODY " ^ f.svar.vname ^" @ "^ string_of_int (!Tracing.current_loc).line; *) + (* M.debug @@ "BODY " ^ f.svar.vname ^" @ "^ string_of_int (!Tracing.current_loc).line; *) (* if not (is_single ctx || !Goblintutil.global_initialization || fst (ctx.global part_mode_var)) then raise Analyses.Deadcode; *) (* checkPredBot ctx.local "body" f.svar [] *) let module BaseMain = (val Base.get_main ()) in @@ -269,7 +269,7 @@ struct ctx.local let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = (* on function calls (also for main); not called for spawned processes *) - (* print_endline @@ "ENTER " ^ f.vname ^" @ "^ string_of_int (!Tracing.current_loc).line; (* somehow M.debug_each doesn't print anything here *) *) + (* print_endline @@ "ENTER " ^ f.vname ^" @ "^ string_of_int (!Tracing.current_loc).line; (* somehow M.debug doesn't print anything here *) *) let d_caller = ctx.local in let d_callee = if D.is_bot ctx.local then ctx.local else { ctx.local with pred = Pred.of_node (MyCFG.Function f); ctx = Ctx.top () } in (* set predecessor set to start node of function *) [d_caller, d_callee] @@ -328,7 +328,7 @@ struct let is_creating_fun = startsWith (Functions.prefix^"Create") f.vname in if M.tracing && is_arinc_fun then ( (* M.tracel "arinc" "found %s(%s)\n" f.vname args_str *) - M.debug_each "found %s(%a) in %s" f.vname (Pretty.d_list ", " d_exp) arglist env.fundec.svar.vname + M.debug "found %s(%a) in %s" f.vname (Pretty.d_list ", " d_exp) arglist env.fundec.svar.vname ); let is_error_handler = env.pname = pname_ErrorHandler in let eval_int exp = @@ -366,7 +366,7 @@ struct let f dlval = let dlval = global_dlval dlval "special" in if not @@ is_return_code_type @@ Lval.CilLval.to_exp dlval - then (M.debug_each "WARN: last argument in arinc function may point to something other than a return code: %s" (str_return_dlval dlval); None) + then (M.debug "WARN: last argument in arinc function may point to something other than a return code: %s" (str_return_dlval dlval); None) else (add_return_dlval env `Write dlval; Some (str_return_dlval dlval)) in (* add actions for all lvals r may point to *) @@ -420,7 +420,7 @@ struct (* | "F62", [dst; src; len] (* strncmp *) *) (* | "F63", [dst; src; len] (* memcpy *) *) -> - M.debug_each @@ "strcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^")"; + M.debug @@ "strcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^")"; (*debugMayPointTo ctx dst;*) assert_ptr dst; assert_ptr src; (* let dst_lval = mkMem ~addr:dst ~off:NoOffset in *) @@ -429,12 +429,12 @@ struct | ls -> ignore @@ Pretty.printf "strcpy %a points to %a\n" d_exp dst Queries.LS.pretty ls; Queries.LS.iter (fun (v,o) -> ctx.assign ~name:"base" (Var v, Lval.CilLval.to_ciloffs o) src) ls - | _ -> M.debug_each @@ "strcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^"): dst may point to anything!"; + | _ -> M.debug @@ "strcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^"): dst may point to anything!"; end; d | "F63" , [dst; src; len] (* memcpy *) -> - M.debug_each @@ "memcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^")"; + M.debug @@ "memcpy/"^f.vname^"("^sprint d_plainexp dst^", "^sprint d_plainexp src^")"; (match ctx.ask (Queries.EvalInt len) with | `Int i -> (* @@ -449,11 +449,11 @@ struct let dst_lval = mkMem ~addr:dst ~off:NoOffset in let src_lval = mkMem ~addr:src ~off:NoOffset in ctx.assign ~name:"base" dst_lval (Lval src_lval); (* this is only ok because we use ArrayDomain.Trivial per default, i.e., there's no difference between the first element or the whole array *) - | v -> M.debug_each @@ "F63/memcpy: don't know length: " ^ sprint Queries.Result.pretty v; + | v -> M.debug @@ "F63/memcpy: don't know length: " ^ sprint Queries.Result.pretty v; let lval = mkMem ~addr:dst ~off:NoOffset in ctx.assign ~name:"base" lval MyCFG.unknown_exp ); - M.debug_each @@ "done with memcpy/"^f.vname; + M.debug @@ "done with memcpy/"^f.vname; d | "F1" , [dst; data; len] (* memset: write char to dst len times *) -> @@ -468,7 +468,7 @@ struct *) let dst_lval = mkMem ~addr:dst ~off:NoOffset in ctx.assign ~name:"base" dst_lval data; (* this is only ok because we use ArrayDomain.Trivial per default, i.e., there's no difference between the first element or the whole array *) - | v -> M.debug_each @@ "F1/memset: don't know length: " ^ sprint Queries.Result.pretty v; + | v -> M.debug @@ "F1/memset: don't know length: " ^ sprint Queries.Result.pretty v; let lval = mkMem ~addr:dst ~off:NoOffset in ctx.assign ~name:"base" lval MyCFG.unknown_exp ); @@ -512,7 +512,7 @@ struct let pid' = Process, name in assign_id pid (get_id pid'); add_actions (List.map (fun f -> CreateProcess Action.({ pid = pid'; f; pri; per; cap })) funs) - | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug_each "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); d (* TODO: f*) + | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); d (* TODO: f*) end | "LAP_Se_GetProcessId", [name; pid; r] -> assign_id_by_name Process name pid; d diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f51b716d7a..75e6007528 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -343,12 +343,12 @@ struct let get_ptrs (vals: value list): address list = let f x acc = match x with | `Address adrs when AD.is_top adrs -> - M.warn_each "Unknown address given as function argument"; acc + M.warn "Unknown address given as function argument"; acc | `Address adrs when AD.to_var_may adrs = [] -> acc | `Address adrs -> let typ = AD.get_type adrs in if isFunctionType typ then acc else adrs :: acc - | `Top -> M.warn_each "Unknown value type given as function argument"; acc + | `Top -> M.warn "Unknown value type given as function argument"; acc | _ -> acc in List.fold_right f vals [] @@ -358,10 +358,10 @@ struct if M.tracing then M.trace "reachability" "Checking value %a\n" VD.pretty value; match value with | `Top -> - if VD.is_immediate_type t then () else M.warn_each "Unknown value in %s could be an escaped pointer address!" description; empty - | `Bot -> (*M.debug_each "A bottom value when computing reachable addresses!";*) empty + if VD.is_immediate_type t then () else M.warn "Unknown value in %s could be an escaped pointer address!" description; empty + | `Bot -> (*M.debug "A bottom value when computing reachable addresses!";*) empty | `Address adrs when AD.is_top adrs -> - M.warn_each "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) + M.warn "Unknown address in %s has escaped." description; AD.remove Addr.NullPtr adrs (* return known addresses still to be a bit more sane (but still unsound) *) (* The main thing is to track where pointers go: *) | `Address adrs -> AD.remove Addr.NullPtr adrs (* Unions are easy, I just ingore the type info. *) @@ -676,7 +676,7 @@ struct if contains_vla t || contains_vla (get_type_addr a) then begin (* TODO: Is this ok? *) - M.warn_each "Casting involving a VLA is assumed to work"; + M.warn "Casting involving a VLA is assumed to work"; true end else @@ -801,13 +801,13 @@ struct match (eval_rv a gs st n) with | `Address adr -> (if AD.is_null adr - then M.error_each ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "Must dereference NULL pointer" + then M.error ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "Must dereference NULL pointer" else if AD.may_be_null adr - then M.warn_each ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "May dereference NULL pointer"); + then M.warn ~category:M.Category.Behavior.Undefined.nullpointer_dereference ~tags:[M.Tag.CWE 476] "May dereference NULL pointer"); do_offs (AD.map (add_offset_varinfo (convert_offset a gs st ofs)) adr) ofs | `Bot -> AD.bot () | _ -> let str = Pretty.sprint ~width:80 (Pretty.dprintf "%a " d_lval lval) in - M.debug_each "Failed evaluating %s to lvalue" str; do_offs AD.unknown_ptr ofs + M.debug "Failed evaluating %s to lvalue" str; do_offs AD.unknown_ptr ofs end (* run eval_rv from above and keep a result that is bottom *) @@ -829,8 +829,8 @@ struct let r = match eval_rv_no_ask_evalint ask gs st e with | `Int i -> i (* cast should be unnecessary, eval_rv should guarantee right ikind already *) | `Bot -> Queries.ID.bot () (* TODO: remove? *) - (* | v -> M.warn_each ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) - | v -> M.debug_each "Query function answered %a" VD.pretty v; Queries.ID.bot () + (* | v -> M.warn ("Query function answered " ^ (VD.show v)); Queries.Result.top q *) + | v -> M.debug "Query function answered %a" VD.pretty v; Queries.ID.bot () in if M.tracing then M.traceu "evalint" "base query_evalint %a -> %a\n" d_exp e Queries.ID.pretty r; r @@ -854,12 +854,12 @@ struct try let fp = eval_fv (Analyses.ask_of_ctx ctx) ctx.global ctx.local fval in if AD.mem Addr.UnknownPtr fp then begin - M.warn_each "Function pointer %a may contain unknown functions." d_exp fval; + M.warn "Function pointer %a may contain unknown functions." d_exp fval; dummyFunDec.svar :: AD.to_var_may fp end else AD.to_var_may fp with SetDomain.Unsupported _ -> - M.warn_each "Unknown call to function %a." d_exp fval; + M.warn "Unknown call to function %a." d_exp fval; [dummyFunDec.svar] (* interpreter end *) @@ -869,7 +869,7 @@ struct | Q.EvalFunvar e -> begin let fs = eval_funvar ctx e in - (* Messages.warn_each ~msg:("Base: I should know it! "^string_of_int (List.length fs)) ();*) + (* Messages.warn ~msg:("Base: I should know it! "^string_of_int (List.length fs)) ();*) List.fold_left (fun xs v -> Q.LS.add (v,`NoOffset) xs) (Q.LS.empty ()) fs end | Q.EvalInt e -> @@ -941,7 +941,7 @@ struct (* check if we have an array of chars that form a string *) (* TODO return may-points-to-set of strings *) | `Address a when List.length (AD.to_string a) > 1 -> (* oh oh *) - M.debug_each "EvalStr (%a) returned %a" d_exp e AD.pretty a; + M.debug "EvalStr (%a) returned %a" d_exp e AD.pretty a; Queries.Result.top q | `Address a when List.length (AD.to_var_may a) = 1 -> (* some other address *) (* Cil.varinfo * (AD.Addr.field, AD.Addr.idx) Lval.offs *) @@ -1067,7 +1067,7 @@ struct with Cilfacade.TypeOfError _ -> (* If we cannot determine the correct type here, we go with the one of the LVal *) (* This will usually lead to a type mismatch in the ValueDomain (and hence supertop) *) - M.warn_each "Cilfacade.typeOfLval failed Could not obtain the type of %a" d_lval (Var x, cil_offset); + M.warn "Cilfacade.typeOfLval failed Could not obtain the type of %a" d_lval (Var x, cil_offset); lval_type in let update_offset old_value = @@ -1182,7 +1182,7 @@ struct (* If any of the addresses are unknown, we ignore it!?! *) | SetDomain.Unsupported x -> (* if M.tracing then M.tracel "setosek" ~var:firstvar "set got an exception '%s'\n" x; *) - M.warn_each "Assignment to unknown address"; st + M.warn "Assignment to unknown address"; st let set_many ?ctx a (gs:glob_fun) (st: store) lval_value_list: store = (* Maybe this can be done with a simple fold *) @@ -1380,7 +1380,7 @@ struct else set a gs st addr t_lval new_val ~invariant:true ~ctx:(Some ctx) (* no *_raw because this is not a real assignment *) | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; - M.warn_each "Invariant failed: expression \"%a\" not understood." d_plainexp exp; + M.warn "Invariant failed: expression \"%a\" not understood." d_plainexp exp; st let invariant ctx a gs st exp tv: store = @@ -1393,7 +1393,7 @@ struct let inv_bin_int (a, b) ikind c op = let warn_and_top_on_zero x = if GU.opt_predicate (BI.equal BI.zero) (ID.to_int x) then - (M.warn_each "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; + (M.warn "Must Undefined Behavior: Second argument of div or mod is 0, continuing with top"; ID.top_of ikind) else x @@ -1652,7 +1652,7 @@ struct let rval_val = eval_rv (Analyses.ask_of_ctx ctx) ctx.global ctx.local rval in let lval_val = eval_lv (Analyses.ask_of_ctx ctx) ctx.global ctx.local lval in (* let sofa = AD.short 80 lval_val^" = "^VD.short 80 rval_val in *) - (* M.debug_each @@ sprint ~width:80 @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) + (* M.debug @@ sprint ~width:80 @@ dprintf "%a = %a\n%s" d_plainlval lval d_plainexp rval sofa; *) let not_local xs = let not_local x = match Addr.to_var_may x with @@ -1712,7 +1712,7 @@ struct match ctx.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - M.debug_each "CondVars result for expression %a is %a" d_exp exp d_exp e; + M.debug "CondVars result for expression %a is %a" d_exp exp d_exp e; invariant ctx (Analyses.ask_of_ctx ctx) ctx.global res e tv | _ -> res in @@ -1775,7 +1775,7 @@ struct | None -> nst | Some exp -> let t_override = match Cilfacade.fundec_return_type fundec with - | TVoid _ -> M.warn_each "Returning a value from a void function"; assert false + | TVoid _ -> M.warn "Returning a value from a void function"; assert false | ret -> ret in (* Evaluate exp and cast the resulting value to the void-pointer-type. @@ -1812,7 +1812,7 @@ struct let invalidate ?ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; - if exps <> [] then M.warn_each "Invalidating expressions: %a" (d_list ", " d_plainexp) exps; + if exps <> [] then M.warn "Invalidating expressions: %a" (d_list ", " d_plainexp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let invalidate_address st a = @@ -1897,7 +1897,7 @@ struct in Some (lval, v, args) else ( - M.warn_each "Not creating a thread from %s because its type is %a" v.vname d_type v.vtype; + M.warn "Not creating a thread from %s because its type is %a" v.vname d_type v.vtype; None ) in @@ -1926,7 +1926,7 @@ struct in let flist = collect_funargs (Analyses.ask_of_ctx ctx) ctx.global ctx.local args in let addrs = List.concat (List.map AD.to_var_may flist) in - if addrs <> [] then M.warn_each "Spawning functions from unknown function: %a" (d_list ", " d_varinfo) addrs; + if addrs <> [] then M.warn "Spawning functions from unknown function: %a" (d_list ", " d_varinfo) addrs; List.filter_map (create_thread None None) addrs end | _ -> [] @@ -1964,30 +1964,30 @@ struct (* TODO: use format instead of %s for the following messages *) match check_assert e ctx.local with | `Lifted false -> - warn (M.error_each ~category:M.Category.Assert "%s") ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); + warn (M.error ~category:M.Category.Assert "%s") ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); if change then raise Analyses.Deadcode else ctx.local | `Lifted true -> - warn (M.success_each ~category:M.Category.Assert "%s") ("Assertion \"" ^ expr ^ "\" will succeed"); + warn (M.success ~category:M.Category.Assert "%s") ("Assertion \"" ^ expr ^ "\" will succeed"); ctx.local | `Bot -> - M.error_each ~category:M.Category.Assert "%s" ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); + M.error ~category:M.Category.Assert "%s" ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); ctx.local | `Top -> - warn (M.warn_each ~category:M.Category.Assert "%s") ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); + warn (M.warn ~category:M.Category.Assert "%s") ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); (* make the state meet the assertion in the rest of the code *) if not change then ctx.local else begin let newst = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global ctx.local e true in (* if check_assert e newst <> `Lifted true then - M.warn_each ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) + M.warn ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst end let special_unknown_invalidate ctx ask gs st f args = - (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn_each "Function definition missing for %s" f.vname); - (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn_each "Unknown function ptr called"); + (if not (CilType.Varinfo.equal f dummyFunDec.svar) && not (LF.use_special f.vname) then M.warn "Function definition missing for %s" f.vname); + (if CilType.Varinfo.equal f dummyFunDec.svar then M.warn "Unknown function ptr called"); let addrs = if get_bool "sem.unknown_function.invalidate.globals" then ( - M.warn_each "INVALIDATING ALL GLOBALS!"; + M.warn "INVALIDATING ALL GLOBALS!"; foldGlobals !Cilfacade.current_file (fun acc global -> match global with | GVar (vi, _, _) when not (is_static vi) -> diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 0ac5d0b006..6a7b306731 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -34,7 +34,7 @@ struct let mutex_addr_to_varinfo = function | LockDomain.Addr.Addr (v, `NoOffset) -> v | LockDomain.Addr.Addr (v, offs) -> - M.warn_each "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs; + M.warn "MutexGlobalsBase: ignoring offset %a%a" d_varinfo v LockDomain.Addr.Offs.pretty offs; v | _ -> failwith "MutexGlobalsBase.mutex_addr_to_varinfo" end diff --git a/src/analyses/condVars.ml b/src/analyses/condVars.ml index 8f71ea5007..c700a7b15e 100644 --- a/src/analyses/condVars.ml +++ b/src/analyses/condVars.ml @@ -64,7 +64,7 @@ struct | a when not (Queries.LS.is_top a) && Queries.LS.cardinal a > 0 -> let top_elt = (dummyFunDec.svar, `NoOffset) in let a' = if Queries.LS.mem top_elt a then ( - M.debug_each "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) + M.debug "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) Queries.LS.remove top_elt a ) else a in @@ -104,7 +104,7 @@ struct let save_expr lval expr = match mustPointTo ctx (AddrOf lval) with | Some clval -> - M.debug_each "CondVars: saving %a = %a" Lval.CilLval.pretty clval d_exp expr; + M.debug "CondVars: saving %a = %a" Lval.CilLval.pretty clval d_exp expr; D.add clval (D.V.singleton expr) d (* if lval must point to clval, add expr *) | None -> d in diff --git a/src/analyses/contain.ml b/src/analyses/contain.ml index 6c61b54725..ece52e010b 100644 --- a/src/analyses/contain.ml +++ b/src/analyses/contain.ml @@ -100,7 +100,7 @@ struct | [] -> () | f :: _ -> try - Messages.warn_each "Problems for safe objects from SAFE.json are suppressed!"; + Messages.warn "Problems for safe objects from SAFE.json are suppressed!"; let safe_tbl = objekt (JsonParser.value JsonLexer.token (Lexing.from_channel (open_in f))) in Object.iter (add_htbl_re D.safe_vars) !(objekt !(field safe_tbl "variables")); Object.iter (add_htbl_re D.safe_methods) !(objekt !(field safe_tbl "methods")); @@ -286,12 +286,12 @@ struct end else begin - (*Messages.warn_each ~msg:("CHECK METHOD : "^f.svar.vname) ();*) + (*Messages.warn ~msg:("CHECK METHOD : "^f.svar.vname) ();*) (*if D.is_top st then failwith "ARGH!";*) if (D.is_public_method_name f.svar.vname) (*|| is_fptr f.svar ctx*) then begin (*printf ("P");*) - (*Messages.warn_each ~msg:("PUBLIC METHOD : "^f.svar.vname) ();*) + (*Messages.warn ~msg:("PUBLIC METHOD : "^f.svar.vname) ();*) add_analyzed_fun f D.analyzed_funs; (*keep track of analyzed funs*) if D.is_bot ctx.local && not (islocal_notmain f.svar.vname ctx.global) then @@ -302,7 +302,7 @@ struct else begin (*rintf ("p");*) - (*Messages.warn_each ~msg:("PRIVATE METHOD : "^f.svar.vname) ();*) + (*Messages.warn ~msg:("PRIVATE METHOD : "^f.svar.vname) ();*) (*D.report("Dom : "^sprint 80 (D.pretty () ctx.local)^"\n");*) if not (danger_bot ctx) then begin @@ -496,7 +496,7 @@ struct end let eval_funvar ctx fval: varinfo list = (*also called for ignore funs*) - (*Messages.warn_each ~msg:(sprint 160 (d_exp () fval) ) ();*) + (*Messages.warn ~msg:(sprint 160 (d_exp () fval) ) ();*) if danger_bot ctx then [] else let fd,st,gd = ctx.local in match fval with @@ -504,11 +504,11 @@ struct | Lval (Mem e,NoOffset) -> (*fptr!*) if not ((get_bool "ana.cont.localclass")) then [D.unresFunDec.svar] else - (*Messages.warn_each ~msg:("fcheck vtbl : "^sprint 160 (d_exp () e)) ();*) + (*Messages.warn ~msg:("fcheck vtbl : "^sprint 160 (d_exp () e)) ();*) let vtbl_lst = get_vtbl e (fd,st,gd) ctx.global in if not (vtbl_lst=[]) then begin - (*List.iter (fun x -> Messages.warn_each ~msg:("VFUNC_CALL_RESOLVED : "^x.vname) ()) vtbl_lst;*) + (*List.iter (fun x -> Messages.warn ~msg:("VFUNC_CALL_RESOLVED : "^x.vname) ()) vtbl_lst;*) vtbl_lst end else @@ -517,18 +517,18 @@ struct let flds_bot = ContainDomain.FieldSet.is_bot flds in if cft && flds_bot then begin - (*Messages.warn_each ~msg:("fptr cft : "^string_of_bool cft) ();*) + (*Messages.warn ~msg:("fptr cft : "^string_of_bool cft) ();*) let fns = D.get_fptr_items ctx.global in let add_svar x y = match ContainDomain.FuncName.from_fun_name x with - | Some x -> Messages.warn_each "fptr check: %s" x.vname;(x)::y + | Some x -> Messages.warn "fptr check: %s" x.vname;(x)::y | _ -> y in ContainDomain.VarNameSet.fold (fun x y -> add_svar x y) fns [] end else begin - (*Messages.warn_each ~msg:("VARS:") ();*) + (*Messages.warn ~msg:("VARS:") ();*) let vars = D.get_vars e in let rvs = List.fold_left (fun y x -> ContainDomain.ArgSet.join (D.Danger.find x st) y) (ContainDomain.ArgSet.bot ()) vars diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index f376d828f6..115375b9ac 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -27,8 +27,8 @@ struct if !Goblintutil.in_verifying_stage then begin D.iter (fun e -> List.iter (fun (a,b) -> if ((MyLock.equal a e) && (MyLock.equal b newLock)) then ( - Messages.warn_each "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty e.addr ValueDomain.Addr.pretty newLock.addr CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc CilType.Location.pretty b.loc CilType.Location.pretty a.loc; - Messages.warn_each ~loc:a.loc "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty newLock.addr ValueDomain.Addr.pretty e.addr CilType.Location.pretty b.loc CilType.Location.pretty a.loc CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc; + Messages.warn "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty e.addr ValueDomain.Addr.pretty newLock.addr CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc CilType.Location.pretty b.loc CilType.Location.pretty a.loc; + Messages.warn ~loc:a.loc "Deadlock warning: Locking order %a, %a at %a, %a violates order at %a, %a." ValueDomain.Addr.pretty newLock.addr ValueDomain.Addr.pretty e.addr CilType.Location.pretty b.loc CilType.Location.pretty a.loc CilType.Location.pretty e.loc CilType.Location.pretty newLock.loc; ) else () ) !forbiddenList ) lockList; @@ -94,7 +94,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn_each "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] + | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* Called when calling a special/unknown function *) let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = diff --git a/src/analyses/extract_arinc.ml b/src/analyses/extract_arinc.ml index 95849da341..fb00b0405e 100644 --- a/src/analyses/extract_arinc.ml +++ b/src/analyses/extract_arinc.ml @@ -264,7 +264,7 @@ struct match ctx.ask (Queries.MayPointTo exp) with | x when not (LS.is_top x) -> let top_elt = dummyFunDec.svar, `NoOffset in - if LS.mem top_elt x then M.debug_each "Query result for MayPointTo contains top!"; + if LS.mem top_elt x then M.debug "Query result for MayPointTo contains top!"; let xs = LS.remove top_elt x |> LS.elements in List.map (fun (v,o) -> string_of_int (Res.i_by_v v)) xs | _ -> failwith @@ "Could not evaluate id-argument "^sprint d_plainexp exp @@ -338,10 +338,10 @@ struct let v,i = Res.get ("process", name) in assign_id pid' v; List.fold_left (fun d f -> extract_fun ~info_args:[f.vname] [string_of_int i]) ctx.local funs - | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug_each "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); ctx.local (* TODO: f *) + | _ -> let f (type a) (x: a Queries.result) = "TODO" in struct_fail (M.debug "%s") (`Result (f name, f entry_point, f pri, f per, f cap)); ctx.local (* TODO: f *) end | _ -> match Pml.special_fun fname with - | None -> M.debug_each "extract_arinc: unhandled function %s" fname; ctx.local + | None -> M.debug "extract_arinc: unhandled function %s" fname; ctx.local | Some eval_args -> if M.tracing then M.trace "extract_arinc" "extract %s, args: %i code, %i pml\n" f.vname (List.length arglist) (List.length eval_args); let rec combine_opt f a b = match a, b with diff --git a/src/analyses/extract_osek.ml b/src/analyses/extract_osek.ml index 61eaa1f0ce..169511c8f1 100644 --- a/src/analyses/extract_osek.ml +++ b/src/analyses/extract_osek.ml @@ -257,7 +257,7 @@ struct match ctx.ask (Queries.MayPointTo exp) with | x when not (LS.is_top x) -> let top_elt = dummyFunDec.svar, `NoOffset in - if LS.mem top_elt x then M.debug_each "Query result for MayPointTo contains top!"; + if LS.mem top_elt x then M.debug "Query result for MayPointTo contains top!"; let xs = LS.remove top_elt x |> LS.elements in List.map (fun (v,o) -> string_of_int (Res.i_by_v v)) xs | _ -> failwith @@ "Could not evaluate id-argument "^sprint d_plainexp exp @@ -294,7 +294,7 @@ struct pid, ctx_hash, Pred.of_node node in match Pml.special_fun fname with - | None -> M.debug_each "extract_osek: unhandled function %s" fname; ctx.local + | None -> M.debug "extract_osek: unhandled function %s" fname; ctx.local | Some eval_args -> if M.tracing then M.trace "extract_osek" "extract %s, args: %i code, %i pml\n" f.vname (List.length arglist) (List.length eval_args); let rec combine_opt f a b = match a, b with diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml index 9874ea16e1..6102e60259 100644 --- a/src/analyses/fileUse.ml +++ b/src/analyses/fileUse.ml @@ -22,7 +22,7 @@ struct (* queries *) let query ctx (type a) (q: a Queries.t) = match q with - | Queries.MayPointTo exp -> M.debug_each "query MayPointTo: %a" d_plainexp exp; Queries.Result.top q + | Queries.MayPointTo exp -> M.debug "query MayPointTo: %a" d_plainexp exp; Queries.Result.top q | _ -> Queries.Result.top q let query_lv (ask: Queries.ask) exp = @@ -33,7 +33,7 @@ struct let print_query_lv ?msg:(msg="") ask exp = let xs = query_lv ask exp in (* MayPointTo -> LValSet *) let pretty_key k = Pretty.text (D.string_of_key k) in - Messages.debug_each "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs + Messages.debug "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs let eval_fv ask exp: varinfo option = match query_lv ask exp with @@ -47,7 +47,7 @@ struct | _ -> [] let print_query_eq ?msg:(msg="") ask exp = let xs = query_eq ask exp in (* EqualSet -> ExpSet *) - Messages.debug_each "%s EqualSet %a = [%a]" msg d_exp exp (Pretty.d_list ", " d_exp) xs + Messages.debug "%s EqualSet %a = [%a]" msg d_exp exp (Pretty.d_list ", " d_exp) xs (* transfer functions *) let assign ctx (lval:lval) (rval:exp) : D.t = @@ -67,20 +67,20 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* we just care about Lval assignments *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug_each "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug_each "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); saveOpened k1 m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug_each "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); D.alias k1 k2 m | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug_each "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; + M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; saveOpened ~unknown:true k1 m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug_each "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; + M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m let branch ctx (exp:exp) (tv:bool) : D.t = @@ -98,7 +98,7 @@ struct D.error k m )else D.success k m - | _ -> M.debug_each "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m + | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -108,16 +108,16 @@ struct ignore(printf "%s %i\n" v.vname (Int64.to_int i)); m *) | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | e -> M.debug_each "branch: nothing matched the given exp: %a" d_plainexp e; m + | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = - (* M.debug_each @@ "body of function "^f.svar.vname; *) + (* M.debug @@ "body of function "^f.svar.vname; *) ctx.local let return ctx (exp:exp option) (f:fundec) : D.t = (* TODO check One Return transformation: oneret.ml *) let m = ctx.local in - (* M.debug_each @@ "return: ctx.local="^D.short 50 ctx.local^string_of_callstack m; *) + (* M.debug @@ "return: ctx.local="^D.short 50 ctx.local^string_of_callstack m; *) (* if f.svar.vname <> "main" && BatList.is_empty (callstack m) then M.write ("\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"); *) if f.svar.vname = "main" then ( let mustOpen, mayOpen = D.union (D.filter_values D.opened m) (D.get_value unclosed_var m) in @@ -153,7 +153,7 @@ struct (* D.only_globals au *) let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - (* M.debug_each @@ "entering function "^f.vname^string_of_callstack ctx.local; *) + (* M.debug @@ "entering function "^f.vname^string_of_callstack ctx.local; *) let m = if f.svar.vname <> "main" then (* push current location onto stack *) D.edit_callstack (BatList.cons !Tracing.current_loc) ctx.local @@ -176,7 +176,7 @@ struct ) else m let combine ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) : D.t = - (* M.debug_each @@ "leaving function "^f.vname^string_of_callstack au; *) + (* M.debug @@ "leaving function "^f.vname^string_of_callstack au; *) let m = ctx.local in (* pop the last location off the stack *) let m = D.edit_callstack List.tl m in (* TODO could it be problematic to keep this in the caller instead of callee domain? if we only add the stack for the callee in enter, then there would be no need to pop a location anymore... *) @@ -195,11 +195,11 @@ struct else (* v is now a local which is not top or a global which is aliased *) let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug_each @@ vvar.vname^" was a global -> alias" in *) + (* let _ = M.debug @@ vvar.vname^" was a global -> alias" in *) D.alias k vvar m else (* returned variable was a local *) let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug_each @@ vvar.vname^" was a local -> rebind"; *) + (* M.debug @@ vvar.vname^" was a local -> rebind"; *) D.add' k v m | _ -> m @@ -249,7 +249,7 @@ struct let m = check_overwrite_open k m in (match arglist with | Const(CStr(filename))::Const(CStr(mode))::[] -> - (* M.debug_each @@ "fopen(\""^filename^"\", \""^mode^"\")"; *) + (* M.debug @@ "fopen(\""^filename^"\", \""^mode^"\")"; *) D.fopen k loc filename mode m |> split_err_branch lval (* TODO k instead of lval? *) | e::Const(CStr(mode))::[] -> (* ignore(printf "CIL: %a\n" d_plainexp e); *) @@ -259,7 +259,7 @@ struct ) | xs -> let args = (String.concat ", " (List.map (sprint d_exp) xs)) in - M.debug_each "fopen args: %s" args; + M.debug "fopen args: %s" args; (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) xs; *) D.warn @@ "fopen needs two strings as arguments, given: "^args; m ) diff --git a/src/analyses/libraryFunctions.ml b/src/analyses/libraryFunctions.ml index 68ba050cad..140f8a952f 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/analyses/libraryFunctions.ml @@ -20,7 +20,7 @@ let osek_renames = ref false let classify' fn exps = let strange_arguments () = - M.warn_each "%s arguments are strange!" fn; + M.warn "%s arguments are strange!" fn; `Unknown fn in match fn with @@ -57,7 +57,7 @@ let classify' fn exps = | "assert" -> begin match exps with | [e] -> `Assert e - | _ -> M.warn_each "Assert argument mismatch!"; `Unknown fn + | _ -> M.warn "Assert argument mismatch!"; `Unknown fn end | "_spin_trylock" | "spin_trylock" | "mutex_trylock" | "_spin_trylock_irqsave" -> `Lock(true, true, true) diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index 64e586cd87..6024484379 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -47,7 +47,7 @@ struct if D.exists (fun x -> List.exists (fun x -> is_prefix_of x v) (Addr.to_var_offset x)) st then let var = Addr.from_var_offset v in - Messages.warn_each ~category:Messages.Category.Behavior.Undefined.nullpointer_dereference "Possible dereferencing of null on variable '%a'." Addr.pretty var + Messages.warn ~category:Messages.Category.Behavior.Undefined.nullpointer_dereference "Possible dereferencing of null on variable '%a'." Addr.pretty var with SetDomain.Unsupported _ -> () (* Warn null-lval dereferences, but not normal (null-) lvals*) diff --git a/src/analyses/mayLocks.ml b/src/analyses/mayLocks.ml index 83a611e89c..cf33e696be 100644 --- a/src/analyses/mayLocks.ml +++ b/src/analyses/mayLocks.ml @@ -34,7 +34,7 @@ struct match a.f (Queries.MayPointTo exp) with | a when not (Queries.LS.is_top a) -> Queries.LS.fold gather_addr (Queries.LS.remove (dummyFunDec.svar, `NoOffset) a) [] - | b -> Messages.warn_each "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] + | b -> Messages.warn "Could not evaluate '%a' to an points-to set, instead got '%a'." d_exp exp Queries.LS.pretty b; [] (* locking logic -- add all locks we can add *) let lock ctx rw may_fail return_value_on_success a lv arglist ls : D.ReverseAddrSet.t = diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index e619ccdff5..b0113d5db6 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -148,7 +148,7 @@ struct let ls = Lockset.filter snd ctx.local in let el = P.effect_fun ~write:w ls in ctx.sideg v el - | None -> M.warn_each "Write to unknown address: privatization is unsound." + | None -> M.warn "Write to unknown address: privatization is unsound." end; (*partitions & locks*) diff --git a/src/analyses/osek.ml b/src/analyses/osek.ml index 0d899f0411..ef04735712 100644 --- a/src/analyses/osek.ml +++ b/src/analyses/osek.ml @@ -484,8 +484,8 @@ struct | Failure _ -> None let unknown_access () = - (*M.warn_each ~msg:"unknown access 'with lockset:'" ();*) - Messages.warn_each "Access to unknown address could be global" + (*M.warn ~msg:"unknown access 'with lockset:'" ();*) + Messages.warn "Access to unknown address could be global" (* All else must have failed --- making a last ditch effort to generate type invariant if that fails then give up and become unsound. *) @@ -618,7 +618,7 @@ struct let access_address (ask: Queries.ask) regs write lv : accesses = if is_ignorable lv then [] else let add_reg (v,o) = - (* Messages.warn_each ~msg:("Region: "^(sprint 80 (d_lval () lv))^" = "^v.vname^(Offs.short 80 (Offs.from_offset (conv_offset o)))) (); *) + (* Messages.warn ~msg:("Region: "^(sprint 80 (d_lval () lv))^" = "^v.vname^(Offs.short 80 (Offs.from_offset (conv_offset o)))) (); *) Region (Some (Lval lv), v, Offs.from_offset (conv_offset o), write) in match ask.f (Queries.MayPointTo (mkAddrOf lv)) with @@ -664,7 +664,7 @@ struct (* let is_unknown x = match x with Unknown _ -> true | _ -> false in*) match a.f (Queries.Regions exp) with | regs when not (Queries.LS.is_top regs) -> - (* Messages.warn_each ~msg:((sprint 80 (d_exp () exp))^" is in regions "^Queries.LS.short 800 regs) (); *) + (* Messages.warn ~msg:((sprint 80 (d_exp () exp))^" is in regions "^Queries.LS.short 800 regs) (); *) accs (Queries.LS.elements regs) | _ -> accs [] (* Accesses during the evaluation of an lval, not the lval itself! *) diff --git a/src/analyses/region.ml b/src/analyses/region.ml index fab7878586..ebbd1ffa64 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -27,7 +27,7 @@ struct let ev = Reg.eval_exp exp in let to_exp (v,f) = (v,Lval.Fields.to_offs' f) in List.map to_exp (Reg.related_globals ev (part,reg)) - | `Top -> Messages.warn_each "Region state is broken :("; [] + | `Top -> Messages.warn "Region state is broken :("; [] | `Bot -> [] let is_bullet exp part st : bool = diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml index 32be8dff70..a9e9859771 100644 --- a/src/analyses/spec.ml +++ b/src/analyses/spec.ml @@ -57,23 +57,23 @@ struct warn key m msg; m (* no goto == implicit back edge *) | None -> - M.debug_each "GOTO %s: %s -> %s" (D.string_of_key key) (D.string_of_state key m) state; + M.debug "GOTO %s: %s -> %s" (D.string_of_key key) (D.string_of_state key m) state; if not change_state then m else if may then D.may_goto key loc state m else D.goto key loc state m (* match spec_exp, cil_exp *) let equal_exp ctx = function (* TODO match constants right away to avoid queries? *) - | `String a, Const(CStr b) -> M.debug_each "EQUAL String Const: %s = %s" a b; a=b + | `String a, Const(CStr b) -> M.debug "EQUAL String Const: %s = %s" a b; a=b (* | `String a, Const(CWStr xs as c) -> failwith "not implemented" *) (* CWStr is done in base.ml, query only returns `Str if it's safe *) | `String a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> M.debug_each "EQUAL String Query: %s = %s" a b; a=b - | _ -> M.debug_each "EQUAL String Query: no result!"; false + | `Lifted b -> M.debug "EQUAL String Query: %s = %s" a b; a=b + | _ -> M.debug "EQUAL String Query: no result!"; false ) | `Regex a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> M.debug_each "EQUAL Regex String Query: %s = %s" a b; Str.string_match (Str.regexp a) b 0 - | _ -> M.debug_each "EQUAL Regex String Query: no result!"; false + | `Lifted b -> M.debug "EQUAL Regex String Query: %s = %s" a b; Str.string_match (Str.regexp a) b 0 + | _ -> M.debug "EQUAL Regex String Query: no result!"; false ) | `Bool a, e -> (match ctx.ask (Queries.EvalInt e) with | b -> (match Queries.ID.to_bool b with Some b -> a=b | None -> false) @@ -82,7 +82,7 @@ struct | b -> (match Queries.ID.to_int b with Some b -> (Int64.of_int a)=(IntOps.BigIntOps.to_int64 b) | None -> false) ) | `Float a, Const(CReal (b, fkind, str_opt)) -> a=b - | `Float a, _ -> M.warn_each "EQUAL Float: unsupported!"; false + | `Float a, _ -> M.warn "EQUAL Float: unsupported!"; false (* arg is a key. currently there can only be one key per constraint, so we already used it for lookup. TODO multiple keys? *) | `Var a, b -> true (* arg is a identifier we use for matching constraints. TODO save in domain *) @@ -90,7 +90,7 @@ struct | `Error s, b -> failwith @@ "Spec error: "^s (* wildcard matches anything *) | `Free, b -> true - | a,b -> M.warn_each "EQUAL? Unmatched case - assume true..."; true + | a,b -> M.warn "EQUAL? Unmatched case - assume true..."; true let check_constraint ctx get_key matches m new_a old_key (a,ws,fwd,b,c as edge) = (* If we have come to a wildcard, we match it instantly, but since there is no way of determining a key @@ -117,7 +117,7 @@ struct (* get possible keys that &lval may point to *) let keys = D.keys_from_lval key (Analyses.ask_of_ctx ctx) in (* does MayPointTo query *) let check_key (m,n) var = - (* M.debug_each @@ "check_key: "^f.vname^"(...): "^D.string_of_entry var m; *) + (* M.debug @@ "check_key: "^f.vname^"(...): "^D.string_of_entry var m; *) let wildcard = SC.is_wildcard c && fwd && b<>"end" in (* skip transitions we can't take b/c we're not in the right state *) (* i.e. if not in map, we must be at the start node or otherwise we must be in one of the possible saved states *) @@ -133,7 +133,7 @@ struct let may = (List.length keys > 1) in (* do not change state for reflexive edges where the key is not assigned to (e.g. *$p = _) *) let change_state = not (old_a=b && SC.get_lval c <> Some `Var) in - M.debug_each "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); + M.debug "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); let new_m = goto ~may:may ~change_state:change_state var b m ws in (new_m,n+1) in @@ -152,13 +152,13 @@ struct try let rec check_fwd_loop m new_a old_key = (* TODO cycle detection? *) let new_m,fwd,new_a,key = List.find_map (check_constraint ctx get_key matches m new_a old_key) !edges in - (* List.iter (fun x -> M.debug_each (x^"\n")) (D.string_of_map new_m); *) - if fwd then M.debug_each "FWD: %B, new_a: %s, old_key: %s" fwd (dump new_a) (dump old_key); + (* List.iter (fun x -> M.debug (x^"\n")) (D.string_of_map new_m); *) + if fwd then M.debug "FWD: %B, new_a: %s, old_key: %s" fwd (dump new_a) (dump old_key); if fwd then check_fwd_loop new_m new_a key else new_m,key in (* now we get the new domain and the latest key that was used *) let new_m,key = check_fwd_loop m None None in - (* List.iter (fun x -> M.debug_each (x^"\n")) (D.string_of_map new_m); *) + (* List.iter (fun x -> M.debug (x^"\n")) (D.string_of_map new_m); *) (* next we have to check if there is a branch() transition we could take *) let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c) !edges in (* just for the compiler: key is initialized with None, but changes once some constaint matches. If none match, we wouldn't be here but at catch Not_found. *) @@ -168,7 +168,7 @@ struct let check_branch branches var = (* only keep those branch_edges for which our key might be in the right state *) let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> D.may_in_state var a new_m) branch_edges in - (* M.debug_each @@ D.string_of_entry var new_m^" -> branch_edges: "^String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges; *) + (* M.debug @@ D.string_of_entry var new_m^" -> branch_edges: "^String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges; *) (* count should be a multiple of 2 (true/false), otherwise the spec is malformed *) if List.length branch_edges mod 2 <> 0 then failwith "Spec is malformed: branch-transitions always need a true and a false case!" else (* if nothing matches, just return new_m without branching *) @@ -217,7 +217,7 @@ struct (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) let get_key c = match SC.get_key_variant c with | `Lval s -> - M.debug_each "Key variant assign `Lval %s; %s" s (SC.stmt_to_string c); + M.debug "Key variant assign `Lval %s; %s" s (SC.stmt_to_string c); (match SC.get_lval c, lval with | Some `Var, _ -> Some lval | Some `Ptr, (Mem Lval x, o) -> Some x (* TODO offset? *) @@ -242,23 +242,23 @@ struct match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* TODO for now we just care about Lval assignments -> should use Queries.MayPointTo *) | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug_each "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 |> D.alias k1 k2 | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug_each "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); (* saveOpened k1 *) m |> D.remove' k1 | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug_each "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); + M.debug "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); let m = D.alias k1 k2 m in (* point k1 to k2 *) if Lval.CilLval.class_tag k2 = `Temp (* check if k2 is a temporary Lval introduced by CIL *) then D.remove' k2 m (* if yes we need to remove it from our map *) else m (* otherwise no change *) | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug_each "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; + M.debug "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; (* saveOpened ~unknown:true k1 *) m |> D.unknown k1 | _ -> (* no change in D for other things *) - M.debug_each "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; + M.debug "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; m (* @@ -288,8 +288,8 @@ struct for pointers this won't help since it always returns `Top *) ( let i = ctx.ask (Queries.EvalInt exp) in (* when (Queries.ID.is_bool i) *) (match Queries.ID.to_bool i with - | Some b when b<>tv -> M.debug_each "EvalInt: `Int bool" (* D.remove k m TODO where to get the key?? *) - | _ -> M.debug_each "EvalInt: `Int no bool") + | Some b when b<>tv -> M.debug "EvalInt: `Int bool" (* D.remove k m TODO where to get the key?? *) + | _ -> M.debug "EvalInt: `Int no bool") ); let check a b tv = (* ignore(printf "check: %a = %a\n" d_plainexp a d_plainexp b); *) @@ -302,10 +302,10 @@ struct let key = D.key_from_lval lval in let value = D.find key m in if i = Int64.zero && tv then ( - M.debug_each "error-branch"; + M.debug "error-branch"; (* D.remove key m *) )else( - M.debug_each "success-branch"; + M.debug "success-branch"; (* m *) ); (* there should always be an entry in our domain for key *) @@ -333,12 +333,12 @@ struct let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem a states && branch_exp_eq c exp tv) !edges in (* there should be only one such edge or none *) if List.length branch_edges <> 1 then ( (* call of branch for an actual branch *) - M.debug_each "branch: branch_edges length is not 1! -> actual branch"; - M.debug_each "%s -> branch_edges1: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; + M.debug "branch: branch_edges length is not 1! -> actual branch"; + M.debug "%s -> branch_edges1: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; (* filter those edges that are branches, end with a state from states have the same branch expression and the same tv *) (* TODO they should end with any predecessor of the current state, not only the direct predecessor *) let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem b states && branch_exp_eq c exp tv) !edges in - M.debug_each "%s -> branch_edges2: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; + M.debug "%s -> branch_edges2: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; if List.length branch_edges <> 1 then m else (* meet current value with the target state. this is tricky: we can not simply take the target state, since there might have been more than one element already before the branching. -> find out what the alternative branch target was and remove it *) @@ -351,15 +351,15 @@ struct if D.V.length value = (1,1) then m else (* XX *) (* there are multiple possible states -> remove b *) let v2 = D.V.remove_state b value in - (* M.debug_each @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) + (* M.debug @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) D.add key v2 m ) else (* call of branch directly after splitting *) let (a,ws,fwd,b,c) = List.hd branch_edges in (* TODO may etc. *) let v2 = D.V.set_state b value in - (* M.debug_each @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) + (* M.debug @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) D.add key v2 m - | _ -> M.debug_each "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m + | _ -> M.debug "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m in match stripCasts (constFold true exp) with (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts @@ -369,15 +369,15 @@ struct | UnOp (LNot, a, _) -> check (stripCasts a) (integer 0) tv (* TODO makes 2 tests fail. probably check changes something it shouldn't *) (* | Lval _ as a -> check (stripCasts a) (integer 0) (not tv) *) - | e -> M.debug_each "branch: nothing matched the given exp: %a" d_plainexp e; m + | e -> M.debug "branch: nothing matched the given exp: %a" d_plainexp e; m let body ctx (f:fundec) : D.t = ctx.local let return ctx (exp:exp option) (f:fundec) : D.t = let m = ctx.local in - (* M.debug_each @@ "return: ctx.local="^D.short 50 m^D.string_of_callstack m; *) - (* if f.svar.vname <> "main" && BatList.is_empty (D.callstack m) then M.debug_each @@ "\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"; *) + (* M.debug @@ "return: ctx.local="^D.short 50 m^D.string_of_callstack m; *) + (* if f.svar.vname <> "main" && BatList.is_empty (D.callstack m) then M.debug @@ "\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"; *) if f.svar.vname = "main" then ( let warn_main msg_loc msg_end = (* there is an end warning for local, return or both *) (* find edges that have 'end' as a target *) @@ -418,14 +418,14 @@ struct List.fold_left (fun m var -> D.remove' (var, `NoOffset) m) au (f.sformals @ f.slocals) let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - (* M.debug_each @@ "entering function "^f.vname^D.string_of_callstack ctx.local; *) + (* M.debug @@ "entering function "^f.vname^D.string_of_callstack ctx.local; *) if f.svar.vname = "main" then load_specfile (); let m = if f.svar.vname <> "main" then D.edit_callstack (BatList.cons !Tracing.current_loc) ctx.local else ctx.local in [m, m] let combine ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) : D.t = - (* M.debug_each @@ "leaving function "^f.vname^D.string_of_callstack au; *) + (* M.debug @@ "leaving function "^f.vname^D.string_of_callstack au; *) let au = D.edit_callstack List.tl au in let return_val = D.find_option return_var au in match lval, return_val with @@ -440,11 +440,11 @@ struct else (* v is now a local which is not top or a global which is aliased *) let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug_each @@ vvar.vname^" was a global -> alias" in *) + (* let _ = M.debug @@ vvar.vname^" was a global -> alias" in *) D.alias k vvar au else (* returned variable was a local *) let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug_each @@ vvar.vname^" was a local -> rebind"; *) + (* M.debug @@ vvar.vname^" was a local -> rebind"; *) D.add' k v au | _ -> au @@ -453,10 +453,10 @@ struct let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) let get_key c = match SC.get_key_variant c with | `Lval s -> - M.debug_each "Key variant special `Lval %s; %s" s (SC.stmt_to_string c); + M.debug "Key variant special `Lval %s; %s" s (SC.stmt_to_string c); lval | `Arg(s, i) -> - M.debug_each "Key variant special `Arg(%s, %d). %s" s i (SC.stmt_to_string c); + M.debug "Key variant special `Arg(%s, %d). %s" s i (SC.stmt_to_string c); (try let arg = List.at arglist i in match arg with @@ -464,7 +464,7 @@ struct | AddrOf x -> Some x | _ -> None with Invalid_argument s -> - M.debug_each "Key out of bounds! Msg: %s" s; (* TODO what to do if spec says that there should be more args... *) + M.debug "Key out of bounds! Msg: %s" s; (* TODO what to do if spec says that there should be more args... *) None ) | _ -> None (* `Rval or `None *) @@ -474,7 +474,7 @@ struct if List.length spec_args = 1 && List.hd spec_args = `Free then true (* wildcard as an argument matches everything *) else if List.length arglist <> List.length spec_args then ( - M.debug_each "SKIP the number of arguments doesn't match the specification!"; + M.debug "SKIP the number of arguments doesn't match the specification!"; false )else List.for_all (SpecCheck.equal_exp ctx) (List.combine spec_args cil_args) (* TODO Cil.constFold true arg. Test: Spec and c-file: 1+1 *) diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index 784423a463..03000d24c3 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -82,7 +82,7 @@ struct | `Unlock -> D.remove (Analyses.ask_of_ctx ctx) (List.hd arglist) ctx.local | `Unknown fn when VarEq.safe_fn fn -> - Messages.warn_each "Assume that %s does not change lockset." fn; + Messages.warn "Assume that %s does not change lockset." fn; ctx.local | `Unknown x -> begin let st = @@ -175,7 +175,7 @@ struct let lock = ValueDomain.Addr.from_var_offset (v, conv_const_offset o) in LSSet.add ("i-lock",ValueDomain.Addr.show lock) xs | _ -> - Messages.warn_each "Internal error: found a strange lockstep pattern."; + Messages.warn "Internal error: found a strange lockstep pattern."; xs in let do_perel e xs = diff --git a/src/analyses/termination.ml b/src/analyses/termination.ml index 24a58dc19b..8eb4bae2b4 100644 --- a/src/analyses/termination.ml +++ b/src/analyses/termination.ml @@ -207,7 +207,7 @@ struct (* match !MyCFG.current_node with *) (* | Some (MyCFG.Statement({ skind = If (e, tb, fb, loc) })) -> *) (* let str_exit b = match exits b with Some loc -> string_of_int loc.line | None -> "None" in *) - (* M.debug_each @@ *) + (* M.debug @@ *) (* "\nCil-exp: " ^ sprint d_exp e *) (* (*^ "; Goblint-exp: " ^ sprint d_exp exp*) *) (* ^ "; Goblint: " ^ sprint Queries.Result.pretty (ctx.ask (Queries.EvalInt exp)) *) diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 4555f968e7..f8dbc07099 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -12,7 +12,7 @@ let has_escaped (ask: Queries.ask) (v: varinfo): bool = else ask.f (Queries.MayEscape v) (* | Top -> - M.warn_each @@ "Variable " ^ v.vname ^ " considered escaped since its address is taken somewhere and the thread escape analysis is not active!"; + M.warn @@ "Variable " ^ v.vname ^ " considered escaped since its address is taken somewhere and the thread escape analysis is not active!"; true *) diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index 6aab1b3a5c..e400386c92 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -46,7 +46,7 @@ struct let to_extra (v,o) xs = (v, Base.Offs.from_offset (conv_offset o), write) :: xs in Queries.LS.fold to_extra a [] | _ -> - M.warn_each "Access to unknown address could be global"; [] + M.warn "Access to unknown address could be global"; [] let rec access_one_byval a rw (exp:exp) = match exp with @@ -123,7 +123,7 @@ struct List.exists (is_prefix_of a) (Addr.to_var_offset addr) in if D.exists f st then begin - Messages.warn_each "Uninitialized variable %a accessed." Addr.pretty (Addr.from_var_offset a); + Messages.warn "Uninitialized variable %a accessed." Addr.pretty (Addr.from_var_offset a); false end else t in @@ -162,7 +162,7 @@ struct | x::xs, y::ys -> [] (* found a mismatch *) | _ -> - M.warn_each "Failed to analyze union at point %a -- did not find %s" Addr.pretty (Addr.from_var_offset (v,rev cx)) tf.fname; + M.warn "Failed to analyze union at point %a -- did not find %s" Addr.pretty (Addr.from_var_offset (v,rev cx)) tf.fname; [] in let utar, uoth = unrollType target, unrollType other in @@ -190,7 +190,7 @@ struct (* step into all other fields *) List.concat (List.rev_map (fun oth_f -> get_pfx v (`Field (oth_f, cx)) ofs utar oth_f.ftype) c2.cfields) | _ -> - M.warn_each "Failed to analyze union at point %a" Addr.pretty (Addr.from_var_offset (v,rev cx)); + M.warn "Failed to analyze union at point %a" Addr.pretty (Addr.from_var_offset (v,rev cx)); [] diff --git a/src/analyses/varEq.ml b/src/analyses/varEq.ml index e2d0a52a78..abffbb16ef 100644 --- a/src/analyses/varEq.ml +++ b/src/analyses/varEq.ml @@ -203,8 +203,8 @@ struct let rec type_may_change_apt a = (* With abstract points-to (like in type invariants in accesses). Here we implement it in part --- minimum to protect local integers. *) - (* Messages.warn_each ~msg:("a: "^sprint 80 (d_plainexp () a)) (); *) - (* Messages.warn_each ~msg:("b: "^sprint 80 (d_plainexp () b)) (); *) + (* Messages.warn ~msg:("a: "^sprint 80 (d_plainexp () a)) (); *) + (* Messages.warn ~msg:("b: "^sprint 80 (d_plainexp () b)) (); *) (* ignore (printf "may_change %a %a\n*%a\n*%a\n\n" d_exp a d_exp b d_plainexp a d_plainexp b); *) match a, b with | Lval (Var _,NoOffset), AddrOf (Mem(Lval _),Field(_, _)) -> @@ -227,7 +227,7 @@ struct | TPtr (t,a) -> t | at -> at in - (* Messages.warn_each + (* Messages.warn ( sprint 80 (d_type () at) ^ " : " ^ sprint 80 (d_type () bt) @@ -245,9 +245,9 @@ struct | Lval (Var _,o) | AddrOf (Var _,o) | StartOf (Var _,o) -> may_change_t_offset o - | Lval (Mem e,o) -> (*Messages.warn_each "Lval" ;*) may_change_t_offset o || type_may_change_t true e - | AddrOf (Mem e,o) -> (*Messages.warn_each "Addr" ;*) may_change_t_offset o || type_may_change_t false e - | StartOf (Mem e,o) -> (*Messages.warn_each "Start";*) may_change_t_offset o || type_may_change_t false e + | Lval (Mem e,o) -> (*Messages.warn "Lval" ;*) may_change_t_offset o || type_may_change_t true e + | AddrOf (Mem e,o) -> (*Messages.warn "Addr" ;*) may_change_t_offset o || type_may_change_t false e + | StartOf (Mem e,o) -> (*Messages.warn "Start";*) may_change_t_offset o || type_may_change_t false e | CastE (t,e) -> type_may_change_t deref e | Question _ -> failwith "Logical operations should be compiled away by CIL." | _ -> failwith "Unmatched pattern." @@ -289,7 +289,7 @@ struct let als = pt e in (als, lval_is_not_disjoint bl als) in - (* Messages.warn_each + (* Messages.warn ( sprint 80 (Lval.CilLval.pretty () bl) ^ " in PT(" ^ sprint 80 (d_exp () a) @@ -320,13 +320,13 @@ struct in let r = if Queries.LS.is_top bls || Queries.LS.mem (dummyFunDec.svar, `NoOffset) bls - then ((*Messages.warn_each "No PT-set: switching to types ";*) type_may_change_apt a ) + then ((*Messages.warn "No PT-set: switching to types ";*) type_may_change_apt a ) else Queries.LS.exists (lval_may_change_pt a) bls in (* if r - then (Messages.warn_each ~msg:("Kill " ^sprint 80 (Exp.pretty () a)^" because of "^sprint 80 (Exp.pretty () b)) (); r) - else (Messages.warn_each ~msg:("Keep " ^sprint 80 (Exp.pretty () a)^" because of "^sprint 80 (Exp.pretty () b)) (); r) - Messages.warn_each ~msg:(sprint 80 (Exp.pretty () b) ^" changed lvalues: "^sprint 80 (Queries.LS.pretty () bls)) (); + then (Messages.warn ~msg:("Kill " ^sprint 80 (Exp.pretty () a)^" because of "^sprint 80 (Exp.pretty () b)) (); r) + else (Messages.warn ~msg:("Keep " ^sprint 80 (Exp.pretty () a)^" because of "^sprint 80 (Exp.pretty () b)) (); r) + Messages.warn ~msg:(sprint 80 (Exp.pretty () b) ^" changed lvalues: "^sprint 80 (Queries.LS.pretty () bls)) (); *) r (* Remove elements, that would change if the given lval would change.*) @@ -376,7 +376,7 @@ struct in let st = *) let lvt = unrollType @@ Cilfacade.typeOfLval lv in - (* Messages.warn_each ~msg:(sprint 80 (d_type () lvt)) (); *) + (* Messages.warn ~msg:(sprint 80 (d_type () lvt)) (); *) if is_global_var ask (Lval lv) = Some false && Exp.interesting rv && is_global_var ask rv = Some false @@ -577,7 +577,7 @@ struct true | Queries.EqualSet e -> let r = eq_set_clos e ctx.local in - (* Messages.warn_each ~msg:("equset of "^(sprint 80 (d_exp () e))^" is "^(Queries.ES.short 80 r)) (); *) + (* Messages.warn ~msg:("equset of "^(sprint 80 (d_exp () e))^" is "^(Queries.ES.short 80 r)) (); *) r | _ -> Queries.Result.top x diff --git a/src/cdomains/arincDomain.ml b/src/cdomains/arincDomain.ml index 6015593089..4510bba4e4 100644 --- a/src/cdomains/arincDomain.ml +++ b/src/cdomains/arincDomain.ml @@ -64,8 +64,8 @@ struct let leq x y = Pid.leq x.pid y.pid && Pri.leq x.pri y.pri && Per.leq x.per y.per && Cap.leq x.cap y.cap && Pmo.leq x.pmo y.pmo && PrE.leq x.pre y.pre && Pred.leq x.pred y.pred && Ctx.leq x.ctx y.ctx let op_scheme op1 op2 op3 op4 op5 op6 op7 op8 x y: t = { pid = op1 x.pid y.pid; pri = op2 x.pri y.pri; per = op3 x.per y.per; cap = op4 x.cap y.cap; pmo = op5 x.pmo y.pmo; pre = op6 x.pre y.pre; pred = op7 x.pred y.pred; ctx = op8 x.ctx y.ctx } let join x y = let r = op_scheme Pid.join Pri.join Per.join Cap.join Pmo.join PrE.join Pred.join Ctx.join x y in - (* let s x = if is_top x then "TOP" else if is_bot x then "BOT" else short 0 x in M.debug_each @@ "JOIN\t" ^ if equal x y then "EQUAL" else s x ^ "\n\t" ^ s y ^ "\n->\t" ^ s r; *) - if Pred.cardinal r.pred > 5 then (Messages.debug_each "Pred.cardinal r.pred = %d with value %a" (Pred.cardinal r.pred) pretty r(* ; failwith "STOP" *)); + (* let s x = if is_top x then "TOP" else if is_bot x then "BOT" else short 0 x in M.debug @@ "JOIN\t" ^ if equal x y then "EQUAL" else s x ^ "\n\t" ^ s y ^ "\n->\t" ^ s r; *) + if Pred.cardinal r.pred > 5 then (Messages.debug "Pred.cardinal r.pred = %d with value %a" (Pred.cardinal r.pred) pretty r(* ; failwith "STOP" *)); r let widen = join let meet = op_scheme Pid.meet Pri.meet Per.meet Cap.meet Pmo.meet PrE.meet Pred.meet Ctx.meet diff --git a/src/cdomains/arrayDomain.ml b/src/cdomains/arrayDomain.ml index 8dabfee4a5..1fcfc7e63f 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomains/arrayDomain.ml @@ -575,15 +575,15 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) | Some true, Some true -> (* Certainly in bounds on both sides.*) () | Some true, Some false -> (* The following matching differentiates the must and may cases*) - M.error_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Must access array past end" + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "Must access array past end" | Some true, None -> - M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end" + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.past_end "May access array past end" | Some false, Some true -> - M.error_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Must access array before start" + M.error ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "Must access array before start" | None, Some true -> - M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May access array before start" + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.before_start "May access array before start" | _ -> - M.warn_each ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown "May access array out of bounds" + M.warn ~category:M.Category.Behavior.Undefined.ArrayOutOfBounds.unknown "May access array out of bounds" else () diff --git a/src/cdomains/containDomain.ml b/src/cdomains/containDomain.ml index cb02b60ec5..ffaba43a78 100644 --- a/src/cdomains/containDomain.ml +++ b/src/cdomains/containDomain.ml @@ -41,7 +41,7 @@ let report x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each "CW: %s" x + Messages.warn "CW: %s" x module FieldVars = struct @@ -173,7 +173,7 @@ struct let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1)) && (!Goblintutil.in_verifying_stage|| !final) then (*filter noise*) - Messages.warn_each "CW: %s" x + Messages.warn "CW: %s" x module Danger = struct @@ -187,7 +187,7 @@ struct if loc.line>=dbg_line_start && loc.line<=dbg_line_end then (*counter := !counter + 1;*) if not (loc.file ="LLVM INTERNAL") || not (loc.line=1) then (*filter noise*) - Messages.warn_each ~msg:((*(string_of_int !counter)^*)"CW: "^x) () + Messages.warn ~msg:((*(string_of_int !counter)^*)"CW: "^x) () let add k v mp = dbg_report("Danger.add "^k.vname^" -> "^sprint 160 (ArgSet.pretty () v)^" was "^sprint 160 (ArgSet.pretty () (find k mp))); add k v mp @@ -256,14 +256,14 @@ struct if enable_dbg && loc.line>=dbg_line_start && loc.line<=dbg_line_end then (*counter := !counter + 1;*) if not (loc.file ="LLVM INTERNAL") || not (loc.line=1) then (*filter noise*) - Messages.warn_each "CW: %s" x - (* Messages.warn_each "%dCW: %s" !counter x *) + Messages.warn "CW: %s" x + (* Messages.warn "%dCW: %s" !counter x *) let error x = let loc = !Tracing.current_loc in if (not (loc.file ="LLVM INTERNAL") || not (loc.line=1))&& !Goblintutil.in_verifying_stage then (*filter noise*) - Messages.warn_each ~category:Messages.Category.Analyzer "CW: %s" x (* TODO: used to call report_error, add error severity *) + Messages.warn ~category:Messages.Category.Analyzer "CW: %s" x (* TODO: used to call report_error, add error severity *) let taintedFunDec = (emptyFunction "@tainted_fields").svar @@ -839,13 +839,13 @@ struct if (not cft || it) && (is_ext (FieldVars.get_var x).vname) glob && not (is_safe_name (FieldVars.get_var x).vname) then begin - (*Messages.warn_each ~msg:((string_of_int (!uid) )^":"^(sprint 160 (FieldVars.pretty () x))^" it "^string_of_bool it^" cft "^string_of_bool cft) ();*) + (*Messages.warn ~msg:((string_of_int (!uid) )^":"^(sprint 160 (FieldVars.pretty () x))^" it "^string_of_bool it^" cft "^string_of_bool cft) ();*) false end else y) args true in - (*Messages.warn_each ~msg:((string_of_int (!uid) )^":"^"danger.UPDATE_THIS_2 "^v.vname^" -> "^(sprint 160 (FieldVars.pretty () fv))^" = "^sprint 160 (ArgSet.pretty () args)^" rhs_ctf : "^string_of_bool rhs_cft) ();*) + (*Messages.warn ~msg:((string_of_int (!uid) )^":"^"danger.UPDATE_THIS_2 "^v.vname^" -> "^(sprint 160 (FieldVars.pretty () fv))^" = "^sprint 160 (ArgSet.pretty () args)^" rhs_ctf : "^string_of_bool rhs_cft) ();*) if not rhs_cft&& not (FieldVars.get_var fv).vglob then begin let flds = get_field_from_this (Lval (Var (FieldVars.get_var fv),NoOffset)) st in @@ -924,7 +924,7 @@ struct let (fd,st,gd) = if (*not must_assign && MUST PROPAGATE HERE!!!*)not (ArgSet.is_bot ds) then begin - (*Messages.warn_each ~msg:((string_of_int (!uid) )^":"^"danger.prop_ds_1 "^v.vname^" -> "^sprint 160 (ArgSet.pretty () ds)^" = "^sprint 160 (ArgSet.pretty () args)) ();*) + (*Messages.warn ~msg:((string_of_int (!uid) )^":"^"danger.prop_ds_1 "^v.vname^" -> "^sprint 160 (ArgSet.pretty () ds)^" = "^sprint 160 (ArgSet.pretty () args)) ();*) ArgSet.fold (fun x y -> update_this x y args) ds (fd,st,gd) (*args???*) end else @@ -1333,7 +1333,7 @@ struct let assign_argmap fs lval exp (fd, st, df) must_assign glob = (*keep track of used fun args*) match used_args st exp with | s when ArgSet.is_top s -> - Messages.warn_each "Expression %a too complicated." d_exp exp; + Messages.warn "Expression %a too complicated." d_exp exp; fd, st, df | s when ArgSet.is_bot s -> let vars= get_vars exp in let s = List.fold_left (fun y x->if not (is_safe_name x.vname) then begin ArgSet.add (FieldVars.gen x) y end else y) (ArgSet.empty()) vars in @@ -1397,7 +1397,7 @@ struct in begin (*muid := !muid +1; - Messages.warn_each ~msg:((string_of_int !muid)^":no_vtbl2t : "^(sprint 160 (d_lval () lval))^ " = "^sprint 160 (ArgSet.pretty () ns)) ();*) + Messages.warn ~msg:((string_of_int !muid)^":no_vtbl2t : "^(sprint 160 (d_lval () lval))^ " = "^sprint 160 (ArgSet.pretty () ns)) ();*) assign_to_lval fs lval (fd, st, df) ns must_assign glob "L1388:" end end diff --git a/src/cdomains/intDomain.ml b/src/cdomains/intDomain.ml index fcbc00d045..6abd0c724a 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomains/intDomain.ml @@ -539,7 +539,7 @@ struct let set_overflow_flag ik = if Cil.isSigned ik && !GU.in_verifying_stage then ( Goblintutil.did_overflow := true; - M.warn_each ~category:M.Category.Integer.overflow ~tags:[M.Tag.CWE 190] "Integer overflow" + M.warn ~category:M.Category.Integer.overflow ~tags:[M.Tag.CWE 190] "Integer overflow" ) let norm ik = function None -> None | Some (x,y) -> @@ -1298,7 +1298,7 @@ struct v ) else if should_ignore_overflow ik then ( - M.warn_each ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; `Bot ) else ( @@ -2723,7 +2723,7 @@ module IntDomTupleImpl = struct let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in if n = 1 then Some (List.hd xs) else ( - if n>1 then Messages.warn_each "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort, but we need some unsound category *) + if n>1 then Messages.warn "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort, but we need some unsound category *) None ) let to_int = same BI.to_string % mapp2 { fp2 = fun (type a) (module I:S with type t = a and type int_t = int_t) -> I.to_int } diff --git a/src/cdomains/lvalMapDomain.ml b/src/cdomains/lvalMapDomain.ml index c7326e2b21..52875221de 100644 --- a/src/cdomains/lvalMapDomain.ml +++ b/src/cdomains/lvalMapDomain.ml @@ -252,10 +252,10 @@ struct let warn ?may:(may=false) ?loc:(loc=[!Tracing.current_loc]) msg = match msg |> Str.split (Str.regexp "[ \n\r\x0c\t]+") with - | [] -> (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) "%s" msg + | [] -> (if may then Messages.warn else Messages.error) ~loc:(List.last loc) "%s" msg | h :: t -> let warn_type = Messages.Category.from_string_list (h |> Str.split (Str.regexp "[.]")) - in (if may then Messages.warn_each else Messages.error_each) ~loc:(List.last loc) ~category:warn_type "%a" (Pretty.docList ~sep:(Pretty.text " ") Pretty.text) t + in (if may then Messages.warn else Messages.error) ~loc:(List.last loc) ~category:warn_type "%a" (Pretty.docList ~sep:(Pretty.text " ") Pretty.text) t (* getting keys from Cil Lvals *) let sprint f x = Pretty.sprint 80 (f () x) @@ -275,6 +275,6 @@ struct let exp = AddrOf lval in let xs = query_lv ask exp in (* MayPointTo -> LValSet *) let pretty_key k = Pretty.text (string_of_key k) in - Messages.debug_each "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs; + Messages.debug "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) xs; xs end diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index 352337f9df..e3d9b6e115 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -252,11 +252,11 @@ struct else RegMap.find vfd m in - (* Messages.warn_each ~msg:("ok? "^sprint 80 (V.pretty () (fst vfd)++F.pretty () (snd vfd))) (); *) + (* Messages.warn ~msg:("ok? "^sprint 80 (V.pretty () (fst vfd)++F.pretty () (snd vfd))) (); *) List.map (add_o os) (RS.to_vf_list vfd_class) | Some (false, vfd, os) -> if is_global vfd then [vfd] else [] - | None -> Messages.warn_each "Access to unknown address could be global"; [] + | None -> Messages.warn "Access to unknown address could be global"; [] end (* TODO: remove Lift *) diff --git a/src/cdomains/shapeDomain.ml b/src/cdomains/shapeDomain.ml index 9ab6c692e8..2e3e2c78bc 100644 --- a/src/cdomains/shapeDomain.ml +++ b/src/cdomains/shapeDomain.ml @@ -180,7 +180,7 @@ let eval_lp ask (e:exp) : lexp option = | _ -> None -let warn_todo s = Messages.warn_each "NotImplemented exception! %s" s +let warn_todo s = Messages.warn "NotImplemented exception! %s" s let alias_top lp = SHMap.remove lp @@ -526,7 +526,7 @@ let sync_one ask gl upd (sm:SHMap.t) : SHMap.t * ((varinfo * bool) list) * ((var (blab (not (lpv'.vglob)) (fun () -> Pretty.printf "global %s is never dead\n" lpv'.vname) && let killer = ref dummyFunDec.svar in blab (if Usedef.VS.exists (fun x -> if CilType.Varinfo.equal lpv' x then (killer := x; true) else false) alive - then ((*ignore (Messages.warn_each ~msg:("List "^ListPtr.short 80 lp^" totally destroyed by "^(!killer).vname) ());*)false) + then ((*ignore (Messages.warn ~msg:("List "^ListPtr.short 80 lp^" totally destroyed by "^(!killer).vname) ());*)false) else true) (fun () -> Pretty.printf "%s in alive list\n" lpv'.vname )) in blab (not (ListPtrSet.is_top pointedBy)) (fun () -> Pretty.printf "everything points at me\n") && @@ -546,7 +546,7 @@ let sync_one ask gl upd (sm:SHMap.t) : SHMap.t * ((varinfo * bool) list) * ((var else let isbroken = not (proper_list k) in (*if isbroken then Messages.waitWhat (ListPtr.short 80 k) ;*) - (* Messages.warn_each ~msg:("checking :"^ListPtr.short 80 k^" -- "^if isbroken then " broken " else "still a list") (); *) + (* Messages.warn ~msg:("checking :"^ListPtr.short 80 k^" -- "^if isbroken then " broken " else "still a list") (); *) (kill ask gl upd k sm, (ListPtr.get_var k, isbroken) :: ds, reg_for k :: rms) in SHMap.fold f sm (sm,[],[]) diff --git a/src/cdomains/valueDomain.ml b/src/cdomains/valueDomain.ml index e190ed7e39..7252bcbf1e 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomains/valueDomain.ml @@ -324,7 +324,7 @@ struct a (* probably garbage, but this is deref's problem *) (*raise (CastError s)*) | SizeOfError (s,t) -> - M.warn_each "size of error: %s" s; + M.warn "size of error: %s" s; a end | x -> x (* TODO we should also keep track of the type here *) @@ -442,7 +442,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.join AD.null_ptr y @@ -469,7 +469,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.join x y) with IntDomain.IncompatibleIKinds m -> Messages.warn "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.join AD.null_ptr y @@ -497,7 +497,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal BI.zero x -> AD.widen AD.null_ptr y @@ -562,7 +562,7 @@ struct | (_, `Top) -> `Top | (`Bot, x) -> x | (x, `Bot) -> x - | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn_each "%s" m; `Top) + | (`Int x, `Int y) -> (try `Int (ID.widen x y) with IntDomain.IncompatibleIKinds m -> Messages.warn "%s" m; `Top) | (`Int x, `Address y) | (`Address y, `Int x) -> `Address (match ID.to_int x with | Some x when BI.equal x BI.zero -> AD.widen AD.null_ptr y @@ -764,14 +764,14 @@ struct (*hack for lists*) begin match f ad with | `List l -> `Address (Lists.entry_rand l) - | _ -> M.warn_each "Trying to read a field, but was not given a struct"; top () + | _ -> M.warn "Trying to read a field, but was not given a struct"; top () end | `Struct str -> let x = Structs.get str fld in let l', o' = shift_one_over l o in do_eval_offset ask f x offs exp l' o' v t - | `Top -> M.debug_each "Trying to read a field, but the struct is unknown"; top () - | _ -> M.warn_each "Trying to read a field, but was not given a struct"; top () + | `Top -> M.debug "Trying to read a field, but the struct is unknown"; top () + | _ -> M.warn "Trying to read a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin match x with @@ -780,8 +780,8 @@ struct let l', o' = shift_one_over l o in do_eval_offset ask f x offs exp l' o' v t | `Union (_, valu) -> top () - | `Top -> M.debug_each "Trying to read a field, but the union is unknown"; top () - | _ -> M.warn_each "Trying to read a field, but was not given a union"; top () + | `Top -> M.debug "Trying to read a field, but the union is unknown"; top () + | _ -> M.warn "Trying to read a field, but was not given a union"; top () end | `Index (idx, offs) -> begin let l', o' = shift_one_over l o in @@ -794,8 +794,8 @@ struct do_eval_offset ask f x offs exp l' o' v t (* this used to be `blob `address -> we ignore the index *) end | x when Goblintutil.opt_predicate (BI.equal (BI.zero)) (IndexDomain.to_int idx) -> eval_offset ask f x offs exp v t - | `Top -> M.debug_each "Trying to read an index, but the array is unknown"; top () - | _ -> M.warn_each "Trying to read an index, but was not given an array (%a)" pretty x; top () + | `Top -> M.debug "Trying to read an index, but the array is unknown"; top () + | _ -> M.warn "Trying to read an index, but was not given an array (%a)" pretty x; top () end in let l, o = match exp with @@ -856,8 +856,8 @@ struct let strc = init_comp fld.fcomp in let l', o' = shift_one_over l o in `Struct (Structs.replace strc fld (do_update_offset ask `Bot offs value exp l' o' v t)) - | `Top -> M.warn_each "Trying to update a field, but the struct is unknown"; top () - | _ -> M.warn_each "Trying to update a field, but was not given a struct"; top () + | `Top -> M.warn "Trying to update a field, but the struct is unknown"; top () + | _ -> M.warn "Trying to update a field, but was not given a struct"; top () end | `Field (fld, offs) -> begin let t = fld.ftype in @@ -885,14 +885,14 @@ struct | `Index (idx, _) when IndexDomain.equal idx (IndexDomain.of_int (Cilfacade.ptrdiff_ikind ()) BI.zero) -> (* Why does cil index unions? We'll just pick the first field. *) top (), `Field (List.nth fld.fcomp.cfields 0,`NoOffset) - | _ -> M.warn_each "Why are you indexing on a union? Normal people give a field name."; + | _ -> M.warn "Why are you indexing on a union? Normal people give a field name."; top (), offs end in `Union (`Lifted fld, do_update_offset ask tempval tempoffs value exp l' o' v t) | `Bot -> `Union (`Lifted fld, do_update_offset ask `Bot offs value exp l' o' v t) - | `Top -> M.warn_each "Trying to update a field, but the union is unknown"; top () - | _ -> M.warn_each "Trying to update a field, but was not given a union"; top () + | `Top -> M.warn "Trying to update a field, but the union is unknown"; top () + | _ -> M.warn "Trying to update a field, but was not given a union"; top () end | `Index (idx, offs) -> begin let l', o' = shift_one_over l o in @@ -914,9 +914,9 @@ struct let new_value_at_index = do_update_offset ask `Bot offs value exp l' o' v t in let new_array_value = CArrays.set ask x' (e, idx) new_value_at_index in `Array new_array_value - | `Top -> M.warn_each "Trying to update an index, but the array is unknown"; top () + | `Top -> M.warn "Trying to update an index, but the array is unknown"; top () | x when Goblintutil.opt_predicate (BI.equal BI.zero) (IndexDomain.to_int idx) -> do_update_offset ask x offs value exp l' o' v t - | _ -> M.warn_each "Trying to update an index, but was not given an array(%a)" pretty x; top () + | _ -> M.warn "Trying to update an index, but was not given an array(%a)" pretty x; top () end in mu result in diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 3eb8ec34a2..b5a5a22ff0 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -475,7 +475,7 @@ struct let vdecl ctx _ = ctx.local let asm x = - ignore (M.warn_each "ASM statement ignored."); + ignore (M.warn "ASM statement ignored."); x.local (* Just ignore. *) let skip x = x.local (* Just ignore. *) diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index f25570c31f..28bb6ee23f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -500,7 +500,7 @@ struct ignore (getl (Function fd, c)) | exception Not_found -> (* unknown function *) - M.warn_each "Created a thread from unknown function %s" f.vname + M.warn "Created a thread from unknown function %s" f.vname (* actual implementation (e.g. invalidation) is done by threadenter *) ) ds in @@ -633,7 +633,7 @@ struct let one_function f = match Cilfacade.find_varinfo_fundec f with | fd when LibraryFunctions.use_special f.vname -> - M.warn_each "Using special for defined function %s" f.vname; + M.warn "Using special for defined function %s" f.vname; tf_special_call ctx lv f args | fd -> tf_normal_call ctx lv e fd args getl sidel getg sideg diff --git a/src/framework/control.ml b/src/framework/control.ml index d1b6d962e3..5d083f17e4 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -166,7 +166,7 @@ struct (* If the function is not defined, and yet has been included to the * analysis result, we generate a warning. *) with Not_found -> - Messages.warn_each "Calculated state for undefined function: unexpected node %a" Node.pretty_plain n + Messages.warn "Calculated state for undefined function: unexpected node %a" Node.pretty_plain n in LHT.iter add_local_var h; res @@ -553,7 +553,7 @@ struct (* Use "normal" constraint solving *) let timeout_reached () = - M.error_each ~loc:!Tracing.current_loc "Timeout reached!"; + M.error ~loc:!Tracing.current_loc "Timeout reached!"; (* let module S = Generic.SolverStats (EQSys) (LHT) in *) (* Can't call Generic.SolverStats...print_stats :( print_stats is triggered by dbg.solver-signal, so we send that signal to ourself in maingoblint before re-raising Timeout. diff --git a/src/maingoblint.ml b/src/maingoblint.ml index 910ce6811a..2ce9e836df 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -318,7 +318,7 @@ let do_analyze change_info merged_AST = with e -> let backtrace = Printexc.get_raw_backtrace () in (* capture backtrace immediately, otherwise the following loses it (internal exception usage without raise_notrace?) *) let loc = !Tracing.current_loc in - Messages.error_each ~loc "About to crash!"; (* TODO: move severity coloring to Messages *) + Messages.error ~loc "About to crash!"; (* TODO: move severity coloring to Messages *) (* trigger Generic.SolverStats...print_stats *) Goblintutil.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); do_stats (); diff --git a/src/util/arincUtil.ml b/src/util/arincUtil.ml index 0bd750ef95..861c8139e6 100644 --- a/src/util/arincUtil.ml +++ b/src/util/arincUtil.ml @@ -1,6 +1,6 @@ open Prelude open Cil -(* we don't want to use M.debug_each because everything here should be done after the analysis, so the location would be some old value for all invocations *) +(* we don't want to use M.debug because everything here should be done after the analysis, so the location would be some old value for all invocations *) let debug_each msg = print_endline @@ MessageUtil.colorize ~fd:Unix.stdout @@ "{blue}"^msg (* ARINC types and Hashtables for collecting CFG *) diff --git a/src/util/cilfacade.ml b/src/util/cilfacade.ml index 8e699ecdc6..1c329e9b0a 100644 --- a/src/util/cilfacade.ml +++ b/src/util/cilfacade.ml @@ -239,7 +239,7 @@ let rec get_ikind t = | TEnum ({ekind = ik; _},_) -> ik | TPtr _ -> get_ikind !Cil.upointType | _ -> - Messages.warn_each "Something that we expected to be an integer type has a different type, assuming it is an IInt"; + Messages.warn "Something that we expected to be an integer type has a different type, assuming it is an IInt"; Cil.IInt let ptrdiff_ikind () = get_ikind !ptrdiffType diff --git a/src/util/messages.ml b/src/util/messages.ml index 8ec146ec30..fa44b85c13 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -217,7 +217,7 @@ let warn_group_old group_name errors = let current_context: Obj.t option ref = ref None (** (Control.get_spec ()) context, represented type: (Control.get_spec ()).C.t *) -let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) fmt = +let msg severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category.Unknown) fmt = let finish doc = let text = Pretty.sprint ~width:max_int doc in add {tags = Category category :: tags; severity; multipiece = Single {loc = Some loc; text; context = !current_context}} @@ -225,10 +225,10 @@ let msg_each severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Cat Pretty.gprintf finish fmt (* must eta-expand to get proper (non-weak) polymorphism for format *) -let warn_each ?loc = msg_each Warning ?loc -let error_each ?loc = msg_each Error ?loc +let warn ?loc = msg Warning ?loc +let error ?loc = msg Error ?loc (* TODO: info *) -let debug_each ?loc = msg_each Debug ?loc -let success_each ?loc = msg_each Success ?loc +let debug ?loc = msg Debug ?loc +let success ?loc = msg Success ?loc include Tracing From 84a09d8d91f23686beec6dbba48bea2ce6677d7b Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:36:52 +0300 Subject: [PATCH 93/95] Add _noloc message functions for future use --- src/util/messages.ml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/util/messages.ml b/src/util/messages.ml index fa44b85c13..0a6f329ceb 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -224,11 +224,22 @@ let msg severity ?loc:(loc= !Tracing.current_loc) ?(tags=[]) ?(category=Category in Pretty.gprintf finish fmt +let msg_noloc severity ?(tags=[]) ?(category=Category.Unknown) fmt = + let finish doc = + let text = Pretty.sprint ~width:max_int doc in + add {tags = Category category :: tags; severity; multipiece = Single {loc = None; text; context = !current_context}} + in + Pretty.gprintf finish fmt + (* must eta-expand to get proper (non-weak) polymorphism for format *) let warn ?loc = msg Warning ?loc +let warn_noloc ?tags = msg_noloc Warning ?tags let error ?loc = msg Error ?loc +let error_noloc ?tags = msg_noloc Error ?tags (* TODO: info *) let debug ?loc = msg Debug ?loc +let debug_noloc ?tags = msg_noloc Debug ?tags let success ?loc = msg Success ?loc +let success_noloc ?tags = msg_noloc Success ?tags include Tracing From 4e7aecd8be8e308e295ec512fda015bf4e4a677d Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:37:53 +0300 Subject: [PATCH 94/95] Add info severity message functions --- src/util/messages.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/util/messages.ml b/src/util/messages.ml index 0a6f329ceb..06da5afb2c 100644 --- a/src/util/messages.ml +++ b/src/util/messages.ml @@ -236,7 +236,8 @@ let warn ?loc = msg Warning ?loc let warn_noloc ?tags = msg_noloc Warning ?tags let error ?loc = msg Error ?loc let error_noloc ?tags = msg_noloc Error ?tags -(* TODO: info *) +let info ?loc = msg Info ?loc +let info_noloc ?tags = msg_noloc Info ?tags let debug ?loc = msg Debug ?loc let debug_noloc ?tags = msg_noloc Debug ?tags let success ?loc = msg Success ?loc From 8f0aaf21692cb4e7ba8a5c7b5f48382924340b87 Mon Sep 17 00:00:00 2001 From: Simmo Saan Date: Mon, 6 Sep 2021 12:44:22 +0300 Subject: [PATCH 95/95] Update messaging documentation about locations --- docs/developer-guide/messaging.md | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/docs/developer-guide/messaging.md b/docs/developer-guide/messaging.md index 9eeab78889..bea252343d 100644 --- a/docs/developer-guide/messaging.md +++ b/docs/developer-guide/messaging.md @@ -14,8 +14,8 @@ A message consists of the following: 3. **Content.** One of the following: * **Single.** Contains the following: 1. **Text.** - 2. **Location.** - 3. **Context.** Currently completely abstract, so not very useful. + 2. **Location.** Optional. + 3. **Context.** Optional. Currently completely abstract, so not very useful. * **Group.** For messages related to numerous locations with different texts. Contains the following: 1. **Group text.** An overall description of the group message. 2. **Pieces.** A list of single messages as described above. @@ -32,12 +32,18 @@ Messages.debug "Text"; (* severity functions *) Messages.warn "Text %s %d %a" "foo" 42 Cil.d_exp exp; (* Pretty format *) Messages.warn ~category:Messages.Category.Integer.overflow "Text"; (* category *) Messages.warn ~category:Messages.Category.Integer.overflow ~tags:[Messages.Tag.CWE 190] "Text"; (* extra tags *) +Messages.warn ~loc:otherloc "Text"; (* non-current location *) +Messages.warn_noloc "Text"; (* no location *) ``` The `~category` argument is optional and defaults to `Unknown`, but all newly added messages should have non-unknown category. New categories should be defined if necessary. The `~tags` argument is optional and allows an arbitrary list of tags (including multiple different categories). The `~category` argument is simply for convenience to add one category tag. +The `~loc` argument is optional and defaults to the current location, but allows messages at a non-current location. + +The `_noloc` suffixed functions allow general messages without any location (not even current). + By convention, may-warnings (the usual case) should use warning severity and must-warnings should use error severity. ### Spec analysis