diff --git a/sledge/report/sledge_report.ml b/sledge/report/sledge_report.ml index 029f0389c..74e3ea378 100644 --- a/sledge/report/sledge_report.ml +++ b/sledge/report/sledge_report.ml @@ -343,7 +343,7 @@ let write_html ranges rows chan = | ss -> List.iter ss ~f:(fun s -> match (s : Report.status) with - | Safe | Unsafe _ | Ok -> + | Safe _ | Unsafe _ | Ok -> Printf.fprintf ppf "%a\n" pf_status s diff --git a/sledge/src/control.ml b/sledge/src/control.ml index 05f92828c..f2491bddd 100644 --- a/sledge/src/control.ml +++ b/sledge/src/control.ml @@ -400,6 +400,7 @@ module Make (Dom : Domain_intf.Dom) = struct fun opts pgm stk state block -> [%Trace.info "@[<2>exec term@\n@[%a@]@\n%a@]" Dom.pp state Llair.Term.pp block.term] ; + Report.step () ; match block.term with | Switch {key; tbl; els} -> IArray.fold tbl @@ -465,6 +466,7 @@ module Make (Dom : Domain_intf.Dom) = struct fun state inst -> [%Trace.info "@[<2>exec inst@\n@[%a@]@\n%a@]" Dom.pp state Llair.Inst.pp inst] ; + Report.step () ; Dom.exec_inst state inst |> Result.of_option ~error:(state, inst) let exec_block : diff --git a/sledge/src/report.ml b/sledge/src/report.ml index e9a118640..ecaefdc2b 100644 --- a/sledge/src/report.ml +++ b/sledge/src/report.ml @@ -40,9 +40,16 @@ let invalid_access_inst fmt_thunk inst = let invalid_access_term fmt_thunk term = invalid_access fmt_thunk Llair.Term.pp term Llair.Term.loc +(** Functional statistics *) + +let steps = ref 0 +let step () = Int.incr steps + +(** Status reporting *) + type status = - | Safe - | Unsafe of int + | Safe of {steps: int} + | Unsafe of {alarms: int; steps: int} | Ok | Unsound | Incomplete @@ -58,8 +65,8 @@ type status = let pp_status ppf stat = let pf fmt = Format.fprintf ppf fmt in match stat with - | Safe -> pf "Safe" - | Unsafe i -> pf "Unsafe: %i" i + | Safe {steps} -> pf "Safe (%i)" steps + | Unsafe {alarms; steps} -> pf "Unsafe: %i (%i)" alarms steps | Ok -> pf "Ok" | Unsound -> pf "Unsound" | Incomplete -> pf "Incomplete" @@ -72,7 +79,8 @@ let pp_status ppf stat = | UnknownError msg -> pf "Unknown error: %s" msg let safe_or_unsafe () = - if !invalid_access_count = 0 then Safe else Unsafe !invalid_access_count + if !invalid_access_count = 0 then Safe {steps= !steps} + else Unsafe {alarms= !invalid_access_count; steps= !steps} type gc_stats = {allocated: float; promoted: float; peak_size: float} [@@deriving sexp] diff --git a/sledge/src/report.mli b/sledge/src/report.mli index 8d2b50f31..703771982 100644 --- a/sledge/src/report.mli +++ b/sledge/src/report.mli @@ -8,13 +8,14 @@ (** Issue reporting *) val init : ?append:bool -> string -> unit +val step : unit -> unit val unknown_call : Llair.term -> unit val invalid_access_inst : (Formatter.t -> unit) -> Llair.inst -> unit val invalid_access_term : (Formatter.t -> unit) -> Llair.term -> unit type status = - | Safe - | Unsafe of int + | Safe of {steps: int} + | Unsafe of {alarms: int; steps: int} | Ok | Unsound | Incomplete