use trace instead of our own custom tracing setup

dune-project

@@ -29,8 +29,10 @@
     (< 4.0)))
   (iter
    (>= 1.0))
+  (trace (>= 0.3))
   (zarith :with-test)
   (alcotest :with-test)
+  (trace-tef (and :with-test (>= 0.3)))
   (odoc :with-doc))
  (depopts
   (mtime
@@ -74,4 +76,6 @@
    (= :version))
   (sidekick-base
    (= :version))
-  menhir))
+  menhir)
+ (depopts
+   (trace-tef (>= 0.3))))

examples/sudoku/dune

@@ -5,7 +5,7 @@
   sidekick.core
   sidekick.util
   sidekick.sat
-  sidekick.tef ; for profiling
+  trace-tef ; for profiling
   iter
   containers)
  (flags :standard -warn-error -a+8 -color always -safe-string

examples/sudoku/sudoku_solve.ml

@@ -311,7 +311,7 @@ end = struct
   type t = { grid0: Grid.t; tst: Term.store; theory: Theory.t; solver: Sat.t }
 
   let solve (self : t) : _ option =
-    let@ () = Profile.with_ "sudoku.solve" in
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "sudoku.solve" in
     let assumptions =
       Grid.all_cells self.grid0
       |> Iter.filter (fun (_, _, c) -> Cell.is_full c)
@@ -359,7 +359,7 @@ let chrono ~pp_time : (module CHRONO) =
   (module M)
 
 let solve_file ~use_stats ~pp_time file =
-  let@ () = Profile.with_ "solve-file" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "solve-file" in
   let open (val chrono ~pp_time) in
   Format.printf "solve grids in file %S@." file;
 
@@ -401,7 +401,7 @@ let solve_file ~use_stats ~pp_time file =
   ()
 
 let () =
-  let@ () = Sidekick_tef.with_setup in
+  let@ () = Trace_tef.with_setup () in
   Fmt.set_color_default true;
   let files = ref [] in
   let debug = ref 0 in

examples/sudoku/tests/dune

@@ -8,5 +8,6 @@
 
 (rule
  (alias runtest)
+ (package sidekick)
  (action
   (diff head15_top1465.expected head15_top1465.out)))

sidekick-bin.opam

@@ -14,6 +14,9 @@ depends: [
   "sidekick-base" {= version}
   "menhir"
 ]
+depopts: [
+  "trace-tef" {>= "0.3"}
+]
 build: [
   ["dune" "subst"] {pinned}
   [

sidekick.opam

@@ -12,8 +12,10 @@ depends: [
   "dune" {>= "2.0"}
   "containers" {>= "3.6" & < "4.0"}
   "iter" {>= "1.0"}
+  "trace" {>= "0.3"}
   "zarith" {with-test}
   "alcotest" {with-test}
+  "trace-tef" {with-test & >= "0.3"}
   "odoc" {with-doc}
 ]
 depopts: [

src/algos/simplex/sidekick_simplex.ml

@@ -652,6 +652,8 @@ module Make (Arg : ARG) :
      See page 14, figure 3.1 *)
   let pivot_and_update (self : t) (x_i : var_state) (x_j : var_state) (v : erat)
       : unit =
+    Profile.messagef (fun k ->
+        k "pivot x_i=%a x_j=%a" V.pp x_i.var V.pp x_j.var);
     assert (Var_state.is_basic x_i);
     assert (Var_state.is_n_basic x_j);
     _check_invariants_internal self;

src/bin-lib/Sidekick_bin_lib.ml

@@ -4,3 +4,4 @@ module Dimacs_lexer = Dimacs_lexer
 module Dimacs_parser = Dimacs_parser
 module Drup_lexer = Drup_lexer
 module Drup_parser = Drup_parser
+module Trace_setup = Trace_setup

src/bin-lib/dune

@@ -2,7 +2,10 @@
  (name sidekick_bin_lib)
  (public_name sidekick-bin.lib)
  (synopsis "Utils for the sidekick binaries")
- (libraries containers sidekick.util)
+ (libraries containers sidekick.util
+            (select trace_setup.ml from
+              (trace-tef -> trace_setup.real.ml)
+              (-> trace_setup.dummy.ml)))
  (flags :standard -warn-error -a+8 -open Sidekick_util))
 
 (ocamllex

src/bin-lib/trace_setup.dummy.ml

@@ -0,0 +1 @@
+let with_trace f = f ()

src/bin-lib/trace_setup.mli

@@ -0,0 +1,2 @@
+
+val with_trace : (unit -> 'a) -> 'a

src/bin-lib/trace_setup.real.ml

@@ -0,0 +1 @@
+let with_trace f = Trace_tef.with_setup () f

src/cc/CC.ml

@@ -218,7 +218,7 @@ exception E_confl of Result_action.conflict
 
 let raise_conflict_ (cc : t) ~th (e : Lit.t list) (p : Sidekick_proof.Step.id) :
     _ =
-  Profile.instant "cc.conflict";
+  Profile.message "cc.conflict";
   (* clear tasks queue *)
   Vec.clear cc.pending;
   Vec.clear cc.combine;

src/checker/drup_check.ml

@@ -69,7 +69,7 @@ end = struct
 
   (* check event, return [true] if it's valid *)
   let check_op (self : t) i (op : Trace.op) : bool =
-    Profile.with_ "check-op" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "check-op" in
     Log.debugf 20 (fun k -> k "(@[check-op :idx %d@ :op %a@])" i Trace.pp_op op);
 
     match op with

src/checker/dune

@@ -2,6 +2,6 @@
  (name main)
  (public_name sidekick-checker)
  (package sidekick-bin)
- (libraries containers sidekick-bin.lib sidekick.util sidekick.tef
+ (libraries containers sidekick-bin.lib sidekick.util
    sidekick.drup)
  (flags :standard -warn-error -a+8 -open Sidekick_util))

src/checker/main.ml

@@ -6,7 +6,7 @@ let clause_of_int_l store atoms : Drup_check.clause =
   |> Drup_check.Clause.of_iter store
 
 let check ?pb proof : bool =
-  Profile.with_ "check" @@ fun () ->
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "check" in
   let cstore = Drup_check.Clause.create () in
   let trace = Drup_check.Trace.create cstore in
 
@@ -14,7 +14,7 @@ let check ?pb proof : bool =
   (match pb with
   | None -> ()
   | Some f when Filename.extension f = ".cnf" ->
-    Profile.with_ "parse-pb.cnf" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "parse-pb.cnf" in
     CCIO.with_in f (fun ic ->
         let parser_ = BL.Dimacs_parser.create ic in
         BL.Dimacs_parser.iter parser_ (fun atoms ->
@@ -42,11 +42,11 @@ let check ?pb proof : bool =
   (match proof with
   | f when Filename.extension f = ".drup" ->
     (* read file *)
-    Profile.with_ "parse-proof.drup" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "parse-proof.drup" in
     CCIO.with_in f add_proof_from_chan
   | f when Filename.extension f = ".gz" ->
     (* read compressed proof *)
-    Profile.with_ "parse-proof.drup" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "parse-proof.drup" in
     (* TODO: more graceful failure mode here *)
     assert (Filename.extension @@ Filename.chop_extension f = ".drup");
     let cmd = Printf.sprintf "gzip --keep -d -c \"%s\"" f in
@@ -70,7 +70,7 @@ let () =
   let files = ref [] in
   let opts = [ "-d", Arg.Int Log.set_debug, " set debug level" ] |> Arg.align in
   Printexc.record_backtrace true;
-  Sidekick_tef.setup ();
+  let@ () = Sidekick_bin_lib.Trace_setup.with_trace in
 
   let t1 = Unix.gettimeofday () in
 

src/drup/sidekick_drup.ml

@@ -364,7 +364,7 @@ module Make () : S = struct
     (* perform boolean propagation in a fixpoint
        @raise Conflict if a clause is false *)
     let bcp_fixpoint_ (self : t) : unit =
-      Profile.with_ "bcp-fixpoint" @@ fun () ->
+      let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "bcp-fixpoint" in
       while self.trail_ptr < Atom.Stack.size self.trail do
         let a = Atom.Stack.get self.trail self.trail_ptr in
         Log.debugf 50 (fun k -> k "(@[bcp@ :atom %a@])" Atom.pp a);

src/main/dune

@@ -7,7 +7,7 @@
  (modules main pure_sat_solver)
  (modes native)
  (libraries containers iter result sidekick.sat sidekick.core sidekick-base
-   sidekick.smt-solver sidekick-base.smtlib sidekick.tef sidekick.drup
+   sidekick.smt-solver sidekick-base.smtlib sidekick.drup
    sidekick.memtrace sidekick-bin.lib)
  (flags :standard -safe-string -color always -open Sidekick_util))
 

src/main/main.ml

@@ -211,7 +211,10 @@ let main_smt ~config () : _ result =
     Solver.Smt_solver.Solver.add_theory solver Sidekick_smtlib.Check_cc.theory;
 
   let parse_res =
-    let@ () = Profile.with_ "parse" ~args:[ "file", !file ] in
+    let@ _sp =
+      Profile.with_span ~__FILE__ ~__LINE__ "parse" ~data:(fun () ->
+          [ "file", `String !file ])
+    in
     Sidekick_smtlib.parse tst !file
   in
 
@@ -252,7 +255,7 @@ let main () =
   Sys.catch_break true;
 
   (* instrumentation and tracing *)
-  Sidekick_tef.with_setup @@ fun () ->
+  let@ () = Sidekick_bin_lib.Trace_setup.with_trace in
   Sidekick_memtrace.trace_if_requested ~context:"sidekick" ();
 
   CCFormat.set_color_default true;

src/main/pure_sat_solver.ml

@@ -150,7 +150,10 @@ let tracer ~(sink : Tr.Sink.t) () : SAT.Tracer.t =
 let start = Sys.time ()
 
 let solve ?check:(_ = false) (solver : SAT.t) : (unit, string) result =
-  let res = Profile.with_ "solve" (fun () -> SAT.solve solver) in
+  let res =
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "solve" in
+    SAT.solve solver
+  in
   let t2 = Sys.time () in
   Printf.printf "\r";
   flush stdout;

src/quip/Sidekick_quip.ml

@@ -143,7 +143,7 @@ module Make_printer (Out : OUT) = struct
   (* toplevel wrapper *)
   let pp self : printer =
    fun out ->
-    Profile.with_ "quip.print" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "quip.print" in
     l [ a "quip"; a "1"; pp_rec self ] out
 
   let pp_debug self : printer = pp self

src/sat/solver.ml

@@ -419,9 +419,10 @@ let clause_bump_activity self (c : clause) : unit =
   )
 
 let emit_counters_ (self : t) =
-  if Profile.enabled () then
+  if Profile.enabled () then (
-    Profile.count "sat"
+    Profile.counter_int "sat.decisions" (decision_level self);
-      [ "decisions", decision_level self; "trail", AVec.size self.trail ]
+    Profile.counter_int "sat.trail" (AVec.size self.trail)
+  )
 
 (* Simplification of clauses.
 
@@ -1658,7 +1659,7 @@ let pick_branch_lit ~full self : bool =
 (* do some amount of search, until the number of conflicts or clause learnt
    reaches the given parameters *)
 let search (self : t) ~on_progress ~(max_conflicts : int) : unit =
-  let@ () = Profile.with_ "sat.search" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "sat.search" in
   Log.debugf 3 (fun k ->
       k "(@[sat.search@ :max-conflicts %d@ :max-learnt %d@])" max_conflicts
         !(self.max_clauses_learnt));
@@ -1683,7 +1684,7 @@ let search (self : t) ~on_progress ~(max_conflicts : int) : unit =
       assert (self.elt_head = AVec.size self.trail);
       assert (self.elt_head = self.th_head);
       if max_conflicts > 0 && !n_conflicts >= max_conflicts then (
-        Profile.instant "sat.restart";
+        Profile.message "sat.restart";
         Log.debug 1 "(sat.restarting)";
         cancel_until self 0;
         Stat.incr self.n_restarts;
@@ -1721,7 +1722,7 @@ let[@inline] eval st lit = fst @@ eval_level st lit
 (* fixpoint of propagation and decisions until a model is found, or a
    conflict is reached *)
 let solve_ ~on_progress (self : t) : unit =
-  let@ () = Profile.with_ "sat.solve" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "sat.solve" in
   Log.debugf 5 (fun k ->
       k "(@[sat.solve :assms %d@])" (AVec.size self.assumptions));
   check_unsat_ self;
@@ -1767,7 +1768,7 @@ let solve_ ~on_progress (self : t) : unit =
           Clause.iter self.store c ~f:(fun a ->
               insert_var_order self (Atom.var a));
 
-          Profile.instant "sat.th-conflict";
+          Profile.message "sat.th-conflict";
           Log.debugf 5 (fun k ->
               k "(@[sat.theory-conflict-clause@ %a@])" (Clause.debug self.store)
                 c);

src/smt/solver.ml

@@ -141,11 +141,10 @@ let add_clause_nopreproc_ ~internal (self : t) (c : lit array) (proof : step_id)
   reset_last_res_ self;
   Log.debugf 50 (fun k ->
       k "(@[solver.add-clause@ %a@])" (Util.pp_array Lit.pp) c);
-  let pb = Profile.begin_ "add-clause" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "add-clause" in
   Sat_solver.add_clause_a self.solver
     (c :> lit array)
-    (fun () -> Proof.Pterm.ref proof);
+    (fun () -> Proof.Pterm.ref proof)
-  Profile.exit pb
 
 let add_clause_nopreproc_l_ ~internal self c p =
   add_clause_nopreproc_ ~internal self (CCArray.of_list c) p
@@ -181,7 +180,7 @@ let add_ty (self : t) ty = SI.add_ty self.si ~ty
 
 let solve ?(on_exit = []) ?(on_progress = fun _ -> ())
     ?(should_stop = fun _ -> false) ~assumptions (self : t) : res =
-  let@ () = Profile.with_ "smt-solver.solve" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "smt-solver.solve" in
   let do_on_exit () = List.iter (fun f -> f ()) on_exit in
 
   let on_progress =

src/smt/solver_internal.ml

@@ -328,7 +328,7 @@ let rec pop_lvls_theories_ n = function
 
 (* make model from the congruence closure *)
 let mk_model_ (self : t) (lits : lit Iter.t) : Model.t =
-  let@ () = Profile.with_ "smt-solver.mk-model" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "smt-solver.mk-model" in
   Log.debug 1 "(smt.solver.mk-model)";
   let module MB = Model_builder in
   let { cc; tst; model_ask = model_ask_hooks; model_complete; _ } = self in
@@ -483,19 +483,20 @@ let[@inline] iter_atoms_ (acts : theory_actions) : _ Iter.t =
   let (module A) = acts in
   A.iter_assumptions f
 
-(* propagation from the bool solver *)
+(** propagation from the bool solver *)
 let check_ ~final (self : t) (acts : sat_acts) =
-  let pb =
+  let[@inline] with_trace () f =
     if final then
-      Profile.begin_ "solver.final-check"
+      let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "solver.final-check" in
+      f ()
     else
-      Profile.null_probe
+      f ()
   in
+  let@ () = with_trace () in
   let iter = iter_atoms_ acts in
   Log.debugf 5 (fun k -> k "(smt-solver.assume :len %d)" (Iter.length iter));
   Event.emit self.on_progress ();
-  assert_lits_ ~final self acts iter;
+  assert_lits_ ~final self acts iter
-  Profile.exit pb
 
 (* propagation from the bool solver *)
 let[@inline] partial_check (self : t) (acts : Sidekick_sat.acts) : unit =

src/smtlib/Driver.ml

@@ -94,7 +94,7 @@ let solve (self : t) ~assumptions () : Solver.res =
   in
 
   let res =
-    let@ () = Profile.with_ "process.solve" in
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "process.solve" in
     Asolver.solve ~assumptions ?on_progress ~should_stop self.solver ()
   in
   let t2 = now () in
@@ -153,7 +153,7 @@ let known_logics =
 
 (* process a single statement *)
 let process_stmt (self : t) (stmt : Statement.t) : unit or_error =
-  let@ () = Profile.with_ "smtlib.process-stmt" in
+  let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "smtlib.process-stmt" in
   Log.debugf 5 (fun k ->
       k "(@[smtlib.process-statement@ %a@])" Statement.pp stmt);
 

src/smtlib/dune

@@ -4,5 +4,5 @@
  (synopsis "SMTLIB 2.6 driver for Sidekick")
  (private_modules Common_)
  (libraries containers zarith sidekick.core sidekick.util sidekick-base
-   sidekick.abstract-solver sidekick.mini-cc smtlib-utils sidekick.tef)
+   sidekick.abstract-solver sidekick.mini-cc smtlib-utils)
  (flags :standard -warn-error -a+8 -open Sidekick_util))

src/tef/Sidekick_tef.dummy.ml

@@ -1,3 +0,0 @@
-let setup () = ()
-let teardown () = ()
-let with_setup f = f ()

src/tef/Sidekick_tef.mli

@@ -1,24 +0,0 @@
-(** {1 Tracing Event Format}
-
-    A nice profiling format based on json, useful for visualizing what goes on.
-    It provides a backend for {!Sidekick_util.Profile} so that
-    profiling probes will emit TEF events.
-
-    Profiling is enabled if {!setup} is called, and if
-    the environment variable "TRACE" is set to "1" or "true".
-    The trace is emitted in the file "trace.json.gz" in the directory
-    where the solver is launched; you can open it in
-    chrome/chromium at "chrome://tracing".
-
-    {{: https://github.com/wolfpld/tracy} Tracy} can import (uncompressed)
-    trace files with a nice native trace explorer.
-
-    See {{: https://docs.google.com/document/d/1CvAClvFfyA5R-PhYUmn5OOQtYMH4h6I0nSsKchNAySU/}
-          the documentation of TEF}
-*)
-
-val setup : unit -> unit
-(** Install the TEF logger as a profiling backend. *)
-
-val teardown : unit -> unit
-val with_setup : (unit -> 'a) -> 'a

src/tef/Sidekick_tef.real.ml

@@ -1,130 +0,0 @@
-module P = Sidekick_util.Profile
-
-let active =
-  lazy
-    (match Sys.getenv "TRACE" with
-    | "1" | "true" -> true
-    | _ -> false
-    | exception Not_found -> false)
-
-let program_start = Mtime_clock.now ()
-
-module Make () : P.BACKEND = struct
-  let first_ = ref true
-  let closed_ = ref false
-
-  let teardown_ oc =
-    if not !closed_ then (
-      closed_ := true;
-      output_char oc ']';
-      (* close array *)
-      flush oc;
-      close_out_noerr oc
-    )
-
-  (* connection to subprocess writing into the file *)
-  let oc =
-    let oc = open_out_bin "trace.json" in
-    output_char oc '[';
-    at_exit (fun () -> teardown_ oc);
-    oc
-
-  let get_ts () : float =
-    let now = Mtime_clock.now () in
-    Mtime.Span.to_float_ns (Mtime.span program_start now) /. 1e3
-
-  let emit_sep_ () =
-    if !first_ then
-      first_ := false
-    else
-      output_string oc ",\n"
-
-  let char = output_char
-  let raw_string = output_string
-  let int oc i = Printf.fprintf oc "%d" i
-
-  let str_val oc (s : string) =
-    char oc '"';
-    let encode_char c =
-      match c with
-      | '"' -> raw_string oc {|\"|}
-      | '\\' -> raw_string oc {|\\|}
-      | '\n' -> raw_string oc {|\n|}
-      | '\b' -> raw_string oc {|\b|}
-      | '\r' -> raw_string oc {|\r|}
-      | '\t' -> raw_string oc {|\t|}
-      | _ when Char.code c <= 0x1f ->
-        raw_string oc {|\u00|};
-        Printf.fprintf oc "%02x" (Char.code c)
-      | c -> char oc c
-    in
-    String.iter encode_char s;
-    char oc '"'
-
-  (* emit args, if not empty. [ppv] is used to print values. *)
-  let emit_args_o_ ppv oc args : unit =
-    if args <> [] then (
-      Printf.fprintf oc {json|,"args": {|json};
-      List.iteri
-        (fun i (n, value) ->
-          if i > 0 then Printf.fprintf oc ",";
-          Printf.fprintf oc {json|"%s":%a|json} n ppv value)
-        args;
-      char oc '}'
-    )
-
-  let emit_duration_event ~name ~start ~end_ ~args () : unit =
-    let dur = end_ -. start in
-    let ts = start in
-    let pid = Unix.getpid () in
-    let tid = Thread.id (Thread.self ()) in
-    emit_sep_ ();
-    Printf.fprintf oc
-      {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json}
-      pid tid dur ts str_val name (emit_args_o_ str_val) args;
-    ()
-
-  let emit_instant_event ~name ~ts ~args () : unit =
-    let pid = Unix.getpid () in
-    let tid = Thread.id (Thread.self ()) in
-    emit_sep_ ();
-    Printf.fprintf oc
-      {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"I"%a}|json}
-      pid tid ts str_val name (emit_args_o_ str_val) args;
-    ()
-
-  let emit_count_event ~name ~ts (cs : _ list) : unit =
-    let pid = Unix.getpid () in
-    let tid = Thread.id (Thread.self ()) in
-    emit_sep_ ();
-    Printf.fprintf oc
-      {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"C"%a}|json}
-      pid tid ts str_val name (emit_args_o_ int) cs;
-    ()
-
-  let teardown () = teardown_ oc
-end
-
-let setup_ =
-  lazy
-    (let (lazy active) = active in
-     let b =
-       if active then
-         Some (module Make () : P.BACKEND)
-       else
-         None
-     in
-     P.Control.setup b)
-
-let setup () = Lazy.force setup_
-let teardown = P.Control.teardown
-
-let[@inline] with_setup f =
-  setup ();
-  try
-    let x = f () in
-    teardown ();
-    x
-  with e ->
-    teardown ();
-    raise e

src/tef/dune

@@ -1,15 +0,0 @@
-(library
- (name sidekick_tef)
- (public_name sidekick.tef)
- (synopsis "profiling backend based on TEF")
- (flags :standard -warn-error -a+8)
- (libraries
-  sidekick.util
-  unix
-  threads
-  (select
-   Sidekick_tef.ml
-   from
-   (mtime mtime.clock.os -> Sidekick_tef.real.ml)
-   (-> Sidekick_tef.dummy.ml)))
- (optional))

src/th-data/Sidekick_th_data.ml

@@ -712,7 +712,7 @@ end = struct
      need it. *)
   let on_final_check (self : t) (solver : SI.t) (acts : SI.theory_actions)
       _trail =
-    Profile.with_ "data.final-check" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "data.final-check" in
     (* acyclicity check first *)
     Acyclicity_.check self solver acts;
 
@@ -736,7 +736,7 @@ end = struct
       Log.debugf 10 (fun k ->
           k "(@[%s.final-check.must-decide@ %a@])" name (Util.pp_list E_node.pp)
             l);
-      Profile.instant "data.case-split";
+      Profile.message "data.case-split";
       List.iter (decide_class_ self solver acts) l);
     ()
 

src/th-lra/sidekick_th_lra.ml

@@ -499,7 +499,10 @@ module Make (A : ARG) = (* : S with module A = A *) struct
 
   (* raise conflict from certificate *)
   let fail_with_cert (self : state) si acts cert : 'a =
-    Profile.with1 "lra.simplex.check-cert" SimpSolver._check_cert cert;
+    (let@ _sp =
+       Profile.with_span ~__FILE__ ~__LINE__ "lra.simplex.check-cert"
+     in
+     SimpSolver._check_cert cert);
     let confl =
       SimpSolver.Unsat_cert.lits cert
       |> CCList.flat_map (Tag.to_lits si)
@@ -527,7 +530,14 @@ module Make (A : ARG) = (* : S with module A = A *) struct
           (SimpSolver.n_vars self.simplex)
           (SimpSolver.n_rows self.simplex));
     let res =
-      Profile.with_ "lra.simplex.solve" @@ fun () ->
+      let@ _sp =
+        Profile.with_span ~__FILE__ ~__LINE__ "lra.simplex.solve"
+          ~data:(fun () ->
+            [
+              "nvars", `Int (SimpSolver.n_vars self.simplex);
+              "nrows", `Int (SimpSolver.n_rows self.simplex);
+            ])
+      in
       SimpSolver.check self.simplex ~on_propagate:(on_propagate_ self si acts)
     in
     Log.debug 5 "(lra.check-simplex.done)";
@@ -666,7 +676,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct
   (* partial checks is where we add literals from the trail to the
      simplex. *)
   let partial_check_ self si acts trail : unit =
-    Profile.with_ "lra.partial-check" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "lra.partial-check" in
     reset_res_ self;
     let changed = ref false in
 
@@ -679,7 +689,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct
   let final_check_ (self : state) si (acts : SI.theory_actions)
       (trail : _ Iter.t) : unit =
     Log.debug 5 "(th-lra.final-check)";
-    Profile.with_ "lra.final-check" @@ fun () ->
+    let@ _sp = Profile.with_span ~__FILE__ ~__LINE__ "lra.final-check" in
     reset_res_ self;
 
     let changed = ref false in

src/util/Log.ml

@@ -1,7 +1,6 @@
 (** {1 Logging functions, real version} *)
 
 let enabled = true (* NOTE: change here for 0-overhead? *)
-
 let debug_level_ = ref 0
 let set_debug l = debug_level_ := l
 let get_debug () = !debug_level_
@@ -20,7 +19,7 @@ let[@inline never] debug_real_ l k =
         Format.fprintf _fmt "@]@?";
         let msg = Buffer.contents buf_ in
         (* forward to profiling *)
-        if Profile.enabled () then Profile.instant msg;
+        if Profile.enabled () then Profile.message msg;
         Format.fprintf !debug_fmt_ "@[<2>@{<Blue>[%d|%.3f]@}@ %s@]@." l now msg
       in
 

src/util/Profile.ml

@@ -1,110 +1 @@
-module type BACKEND = sig
+include Trace_core
-  val get_ts : unit -> float
-
-  val emit_duration_event :
-    name:string ->
-    start:float ->
-    end_:float ->
-    args:(string * string) list ->
-    unit ->
-    unit
-
-  val emit_instant_event :
-    name:string -> ts:float -> args:(string * string) list -> unit -> unit
-
-  val emit_count_event : name:string -> ts:float -> (string * int) list -> unit
-  val teardown : unit -> unit
-end
-
-type backend = (module BACKEND)
-type probe = No_probe | Probe of { name: string; start: float }
-
-let null_probe = No_probe
-
-(* where to print events *)
-let out_ : backend option ref = ref None
-
-let[@inline] enabled () =
-  match !out_ with
-  | Some _ -> true
-  | None -> false
-
-let[@inline never] begin_with_ (module B : BACKEND) name : probe =
-  Probe { name; start = B.get_ts () }
-
-let[@inline] begin_ name : probe =
-  match !out_ with
-  | None -> No_probe
-  | Some b -> begin_with_ b name
-
-let[@inline] instant ?(args = []) name =
-  match !out_ with
-  | None -> ()
-  | Some (module B) ->
-    let now = B.get_ts () in
-    B.emit_instant_event ~name ~ts:now ~args ()
-
-let[@inline] count name cs =
-  if cs <> [] then (
-    match !out_ with
-    | None -> ()
-    | Some (module B) ->
-      let now = B.get_ts () in
-      B.emit_count_event ~name ~ts:now cs
-  )
-
-(* slow path *)
-let[@inline never] exit_full_ (module B : BACKEND) ~args name start =
-  let now = B.get_ts () in
-  B.emit_duration_event ~name ~start ~end_:now ~args ()
-
-let[@inline] exit_with_ ~args b pb =
-  match pb with
-  | No_probe -> ()
-  | Probe { name; start } -> exit_full_ ~args b name start
-
-let[@inline] exit ?(args = []) pb =
-  match pb, !out_ with
-  | Probe { name; start }, Some b -> exit_full_ ~args b name start
-  | _ -> ()
-
-let[@inline] with_ ?(args = []) name f =
-  match !out_ with
-  | None -> f ()
-  | Some b ->
-    let pb = begin_with_ b name in
-    (try
-       let x = f () in
-       exit_with_ ~args b pb;
-       x
-     with e ->
-       exit_with_ ~args b pb;
-       raise e)
-
-let[@inline] with1 ?(args = []) name f x =
-  match !out_ with
-  | None -> f x
-  | Some b ->
-    let pb = begin_with_ b name in
-    (try
-       let res = f x in
-       exit_with_ ~args b pb;
-       res
-     with e ->
-       exit_with_ ~args b pb;
-       raise e)
-
-let[@inline] with2 ?args name f x y = with_ ?args name (fun () -> f x y)
-
-module Control = struct
-  let setup b =
-    assert (!out_ = None);
-    out_ := b
-
-  let teardown () =
-    match !out_ with
-    | None -> ()
-    | Some (module B) ->
-      out_ := None;
-      B.teardown ()
-end

src/util/Profile.mli

@@ -1,45 +0,0 @@
-(** Profiling probes.
-
-   This basic library can produce Catapult traces (a json file)
-   that can be read at [http://ui.perfetto.dev].
- *)
-
-type probe
-
-val null_probe : probe
-val enabled : unit -> bool
-val instant : ?args:(string * string) list -> string -> unit
-val begin_ : string -> probe
-val exit : ?args:(string * string) list -> probe -> unit
-val with_ : ?args:(string * string) list -> string -> (unit -> 'a) -> 'a
-val with1 : ?args:(string * string) list -> string -> ('a -> 'b) -> 'a -> 'b
-
-val with2 :
-  ?args:(string * string) list -> string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
-
-val count : string -> (string * int) list -> unit
-
-module type BACKEND = sig
-  val get_ts : unit -> float
-
-  val emit_duration_event :
-    name:string ->
-    start:float ->
-    end_:float ->
-    args:(string * string) list ->
-    unit ->
-    unit
-
-  val emit_instant_event :
-    name:string -> ts:float -> args:(string * string) list -> unit -> unit
-
-  val emit_count_event : name:string -> ts:float -> (string * int) list -> unit
-  val teardown : unit -> unit
-end
-
-type backend = (module BACKEND)
-
-module Control : sig
-  val setup : backend option -> unit
-  val teardown : unit -> unit
-end

src/util/Sidekick_util.ml

@@ -26,4 +26,4 @@ module Chunk_stack = Chunk_stack
 module Ser_value = Ser_value
 module Ser_decode = Ser_decode
 
-let[@inline] ( let@ ) f x = f x
+let ( let@ ) = ( @@ )

src/util/dune

@@ -2,4 +2,4 @@
  (name sidekick_util)
  (public_name sidekick.util)
  (flags :standard -warn-error -a+8)
- (libraries containers iter sidekick.sigs bigarray unix))
+ (libraries containers iter sidekick.sigs bigarray unix trace.core))