Add tracing infrastructure.

Adds the tracing instruction:
     TRACE(t, l, __ format arg1 arg2 ... argn)
where t is a tracer (that can be enabled on the command line) and
l is a level. Any TRACE whose level is below the one specified on
the command line for the tracer is printed.

The project is built without -trace, the TRACE() command is a noop.

git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@1194 3cdefd35-fc62-479d-8e8d-bae585ffb9ca

diff --git a/include/debug.ml b/include/debug.ml
index e3694ab..09fd43f 100644 (file)
--- a/include/debug.ml
+++ b/include/debug.ml
@@ -21,7 +21,6 @@ DEFINE D_IGNORE_(e1,e2) = (let () = e1 in ();e2)
 DEFINE D_IF_(e1,e2) = e1
 DEFINE D_TRACE_(e) = e
 
-
 ELSE
 DEFINE D_IGNORE_(e1,e2) = (e2)
 DEFINE D_IF_(e1,e2) = e2

diff --git a/include/trace.ml b/include/trace.ml
new file mode 100644 (file)
index 0000000..21e3a95
--- /dev/null
+++ b/include/trace.ml
@@ -0,0 +1,27 @@
+IFNDEF TRACE__ML__
+THEN
+DEFINE TRACE__ML__
+
+let __ x =
+  ignore (Format.flush_str_formatter());
+  Format.kfprintf
+    (fun _ -> Format.flush_str_formatter())
+    Format.str_formatter x
+;;
+IFNDEF NTRACE
+THEN
+
+DEFINE TRACE(t, l, r) =
+  (if l <= Tracer.level t then
+      Tracer.trace t l (r))
+
+ELSE
+
+DEFINE TRACE(t, l, r) = ()
+
+END
+
+
+
+
+END

diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index bbe7fc0..3e14dfa 100644 (file)
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -106,8 +106,8 @@ let () = dispatch begin
       Options.ocamldoc := ocamlfind (A"ocamldoc");
       Options.ocamlmktop := ocamlfind (A"ocamlmktop");
 
-      if (List.mem "trace" !Options.tags) then begin
-       pp_macro_options @= [ A "-DTRACE" ];
+      if not (List.mem "trace" !Options.tags) then begin
+       pp_macro_options @= [ A "-DNTRACE" ];
       end;
       if (List.mem "profile" !Options.tags) then begin
        pp_macro_options @= [ A "-DPROFILE" ];

diff --git a/src/options.ml b/src/options.ml
index d72763e..70d702d 100644 (file)
--- a/src/options.ml
+++ b/src/options.ml
@@ -1,3 +1,6 @@
+open Utils
+open Format
+
 let index_empty_texts = ref false
 let sample_factor = ref 64
 let disable_text_collection = ref false
@@ -27,7 +30,6 @@ let set_index_type = function
 
 let usage_msg = Printf.sprintf "%s [options] <input.{xml|srx}> 'query' [output]" Sys.argv.(0)
 
-
 let pos = ref 0
 let anon_fun =
   fun s -> match !pos with
@@ -36,6 +38,27 @@ let anon_fun =
     | 2 -> output_file := Some s; incr pos
     | _ -> raise (Arg.Bad(s))
 
+let set_tracer s =
+  List.iter (fun t ->
+    if t = "" then ()
+    else
+      match String.explode t ':' with
+       [ tr; lvl ] ->
+         let l = try int_of_string lvl with _ -> raise (Arg.Bad (lvl)) in
+         if Tracer.is_tracer tr then Tracer.activate tr l
+         else raise (Arg.Bad (t))
+      | _ -> raise (Arg.Bad (t))
+  ) (String.explode s ',')
+
+let pretty_tracers () =
+  ignore(flush_str_formatter());
+  Pretty.print_list
+    ~sep:", "
+    (fun f s -> fprintf f "%s" s)
+    str_formatter
+    (Tracer.available ());
+  flush_str_formatter ()
+
 let spec = Arg.align
   [ "-c", Arg.Set(count_only),
     " counting only (don't materialize the result set)";
@@ -63,10 +86,13 @@ let spec = Arg.align
     " choose text index type";
 
     "-v", Arg.Set(verbose), " verbose mode"; ] @
-IFDEF TRACE
+IFNDEF NTRACE
 THEN [
     "-trace-file", Arg.Set_string(trace_file),
-    "<trace_file> save the full trace in dot format in <trace_file>"
+    "<trace_file> save the full trace in dot format in <trace_file>";
+    "-trace", Arg.String (set_tracer),
+    "<tracer1:l1,...,tracern:ln> enable tracing with the specified level. Valid tracers are: "
+      ^ (pretty_tracers ())
      ]
 ELSE []
 END

diff --git a/src/runtime.ml b/src/runtime.ml
index e32812b..d74c26a 100644 (file)
--- a/src/runtime.ml
+++ b/src/runtime.ml
@@ -1,4 +1,5 @@
 INCLUDE "debug.ml"
+INCLUDE "trace.ml"
 INCLUDE "utils.ml"
 
 open Format
@@ -189,6 +190,12 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t =
 
 DEFINE LOOP (t, states, ctx) = (
   let _t = (t) in
+  TRACE("top-down-run", 3,
+       __ "Entering node %i (tag %s, context %i) with states %a\n%!"
+         (Node.to_int _t)
+         (Tag.to_string (Tree.tag tree _t))
+         (Node.to_int (ctx))
+         (StateSet.print) (states));
   if _t == Tree.nil then nil_res
   else
     let tag = Tree.tag tree _t in

diff --git a/src/tracer.ml b/src/tracer.ml
new file mode 100644 (file)
index 0000000..eae76a5
--- /dev/null
+++ b/src/tracer.ml
@@ -0,0 +1,25 @@
+open Format
+
+type tracer = string
+type level = int
+
+let tracers = [ "top-down-run"; "top-down-approx"; "result-set" ]
+let active_tracers : (tracer, int) Hashtbl.t = Hashtbl.create 17
+
+let available () = tracers
+
+let is_tracer s = List.mem s tracers
+let level s = try Hashtbl.find active_tracers s with Not_found -> 0
+let is_active s = Hashtbl.mem active_tracers s
+let activate s lvl = if not (is_active s) then Hashtbl.add active_tracers s lvl
+let deactivate s = Hashtbl.remove active_tracers s
+
+let tracer_output = ref err_formatter
+let set_output f = tracer_output := f
+
+let trace t l s =
+  if l <= level t
+  then begin
+    fprintf !tracer_output "%s: " t;
+    fprintf !tracer_output "%s" s
+  end

diff --git a/src/tracer.mli b/src/tracer.mli
new file mode 100644 (file)
index 0000000..99c078b
--- /dev/null
+++ b/src/tracer.mli
@@ -0,0 +1,11 @@
+type tracer = string
+type level = int
+val is_tracer : tracer -> bool
+val is_active : tracer -> bool
+val level : tracer -> level
+val activate : tracer -> level -> unit
+val deactivate : tracer -> unit
+val set_output : Format.formatter -> unit
+val trace : tracer -> level -> string -> unit
+
+val available : unit -> string list

diff --git a/src/utils.ml b/src/utils.ml
new file mode 100644 (file)
index 0000000..c5547aa
--- /dev/null
+++ b/src/utils.ml
@@ -0,0 +1,24 @@
+module String =
+struct
+  include String
+
+  let explode s sep =
+    let len = length s in
+    let buff = Buffer.create 40 in
+    let rec loop i =
+      if i >= len then
+       [ Buffer.contents buff ]
+      else
+       let c = s.[i] in
+       if c == sep then
+         let ss = Buffer.contents buff in
+         Buffer.clear buff;
+         ss :: loop (i+1)
+       else begin
+         Buffer.add_char buff c;
+         loop (i+1);
+       end
+    in
+    loop 0
+end
+;;