IFNDEF LOG__ML__
THEN
DEFINE LOG__ML__
-let __ x =
- ignore (Format.flush_str_formatter());
- Format.kfprintf
- (fun _ -> Format.flush_str_formatter())
- Format.str_formatter x
-;;
+let __ x = Logger.log x
+(* Format.fprintf !Logger.logger_output x *)
+;;
IFNDEF NLOG
THEN
-DEFINE LOG(t, l, r) =
- (let __log__t = t in
- let __log__l = l in
- if __log__l <= Logger.level __log__t then
- Logger.log __log__t __log__l (r))
+DEFINE LOG(e) = (e)
ELSE
-DEFINE LOG(t, l, r) = ()
+DEFINE LOG(e) = ()
END
let t2 = Unix.gettimeofday () in
let t = (1000. *. (t2 -. t1)) in
l:= t::!l;
- Printf.eprintf " %fms\n%!" t ;
- Printf.eprintf "Mem use before: %s\n%!" s1;
- Printf.eprintf "Final Mem: %s\n\n\n%!" s2;
+ Logger.print Format.err_formatter " %fms\n%!" t ;
+ Logger.print Format.err_formatter "Mem use before: %s\n%!" s1;
+ Logger.print Format.err_formatter "Final Mem: %s\n\n\n%!" s2;
r
;;
let time f ?(count=1) ?(msg="") x =
let rec loop i =
Gc.compact();
- let t1 = Unix.gettimeofday () in
- let r = f x in
- let t2 = Unix.gettimeofday () in
- let t = (1000. *. (t2 -. t1)) in
- Printf.eprintf "%s: " msg;
- if (count != 1) then Printf.eprintf "run %i/%i, " i count;
- Printf.eprintf "%fms\n%!" t;
- if i >= count then (l:= t::!l;r)
- else loop (i+1)
- in loop 1
+ let t1 = Unix.gettimeofday () in
+ let r = f x in
+ let t2 = Unix.gettimeofday () in
+ let t = (1000. *. (t2 -. t1)) in
+ Logger.print Format.err_formatter "%s: " msg;
+ if (count != 1) then Logger.print Format.err_formatter "run %i/%i, " i count;
+ Logger.print Format.err_formatter "%fms" t;
+ if i >= count then (l:= t::!l;r)
+ else loop (i+1)
+ in
+ let r = loop 1 in
+ Logger.print Format.err_formatter "@\n";
+ r
;;
let total_time () = List.fold_left (+.) 0. !l;;
| _ ->
if Ptset.Int.mem Tag.pcdata rel_labels then begin
- LOG("top-down-approx", 3, __ "Computed rel_labels: %a\n"
- TagSet.print
- (TagSet.inj_positive rel_labels));
+ LOG(__ "top-down-approx" 3 "Computed rel_labels: %a@\n"
+ TagSet.print (TagSet.inj_positive rel_labels));
NODE
end else STAR
(List.sort by_states uniq_states_trs)
in
LOG(
- "top-down-approx", 2,
- let is_pairwise_disjoint l =
- List.for_all (fun ((ts, _) as tr) ->
- List.for_all (fun ((ts', _) as tr') ->
- (ts == ts' && (by_states tr tr' == 0)) ||
- TagSet.is_empty (TagSet.cap ts ts')) l) l
- in
- let is_complete l = TagSet.positive
- (List.fold_left (fun acc (ts, _) -> TagSet.cup acc ts)
- TagSet.empty l)
- ==
- (Tree.node_tags tree)
- in
- let pr_td_approx fmt td_approx =
- List.iter (fun (ts,(l,r, m)) ->
- let ts = if TagSet.cardinal ts >10
- then TagSet.diff TagSet.any
- (TagSet.diff
- (TagSet.inj_positive (Tree.node_tags tree))
- ts)
- else ts
- in
- fprintf fmt "\t%a, %a, %b -> %a, %a\n%!"
- StateSet.print states
- TagSet.print ts
- m
- StateSet.print l
- StateSet.print r
- ) td_approx;
- fprintf fmt "\n%!"
- in
- __ " pairwise-disjoint:%b, complete:%b:\n%a"
- (is_pairwise_disjoint td_approx)
- (is_complete td_approx)
- pr_td_approx td_approx
+ let is_pairwise_disjoint l =
+ List.for_all (fun ((ts, _) as tr) ->
+ List.for_all (fun ((ts', _) as tr') ->
+ (ts == ts' && (by_states tr tr' == 0)) ||
+ TagSet.is_empty (TagSet.cap ts ts')) l) l
+ in
+ let is_complete l = TagSet.positive
+ (List.fold_left (fun acc (ts, _) -> TagSet.cup acc ts)
+ TagSet.empty l)
+ ==
+ (Tree.node_tags tree)
+ in
+ let pr_td_approx fmt td_approx =
+ List.iter (fun (ts,(l,r, m)) ->
+ let ts = if TagSet.cardinal ts >10
+ then TagSet.diff TagSet.any
+ (TagSet.diff
+ (TagSet.inj_positive (Tree.node_tags tree))
+ ts)
+ else ts
+ in
+ fprintf fmt "%a, %a, %b -> %a, %a@\n"
+ StateSet.print states
+ TagSet.print ts
+ m
+ StateSet.print l
+ StateSet.print r
+ ) td_approx;
+ fprintf fmt "\n%!"
+ in
+ __ "top-down-approx" 2 " pairwise-disjoint:%b, complete:%b:@\n%a"
+ (is_pairwise_disjoint td_approx)
+ (is_complete td_approx)
+ pr_td_approx td_approx
);
let jump =
compute_jump
let ts = if ts == TagSet.star then TagSet.diff ts attributes else ts
in
let b = TagSet.mem tag ts in
- let () = LOG("transition", 3, __ "Transition: %a, tag=%s, %s\n%!"
- Transition.print
- tr
+ let () = LOG(__ "transition" 3 "tag=<%s>, %s: %a7C"
(Tag.to_string tag)
- (if b then "selected" else "not selected"))
+ (if b then " taking" else "not taking")
+ Transition.print tr)
in
if b then
let _, _, _, f = Transition.node tr in
else
let jkind = Ata.top_down_approx auto states tree in
let jump = translate_jump tree tag jkind dir states in
- LOG("level2-jit", 2,
- __ "Computed jumps for %s %a %s: %a\n%!"
+ LOG(__ "level2-jit" 2
+ "Computed jumps for %s %a %s: %a\n%!"
(Tag.to_string tag)
StateSet.print states
(if dir == DIR_LEFT then "left" else "right")
let loggers = [ "top-down-run"; "top-down-approx"; "result-set"; "level2-jit"; "res-jit"; "grammar"; "twopass";"transition" ]
let active_loggers : (t, int) Hashtbl.t = Hashtbl.create 17
-
+let margin = List.fold_left (fun m l -> max m (String.length l)) 0 loggers
let available () = loggers
let is_logger s = List.mem s loggers
let logger_output = ref err_formatter
let set_output f = logger_output := f
-let log t l s =
+let log t l fmt =
if l <= level t
then begin
- fprintf !logger_output "%s: " t;
- fprintf !logger_output "%s%!" s
+ pp_open_hovbox !logger_output (margin + 3);
+ fprintf !logger_output "%-.*s : " margin t;
+ kfprintf (fun _ ->
+ pp_close_box !logger_output ();
+ fprintf !logger_output "@?@\n";
+ ) !logger_output fmt
end
+ else
+ ifprintf !logger_output fmt
+
+let print ppf fmt =
+ pp_open_hovbox ppf 0;
+ kfprintf (fun _ ->
+ pp_close_box ppf ();
+ fprintf ppf "@?")
+ ppf fmt
val activate : t -> level -> unit
val deactivate : t -> unit
val set_output : Format.formatter -> unit
-val log : t -> level -> string -> unit
+val log : t -> level -> ('a, Format.formatter, unit) format -> 'a
+val print : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
val available : unit -> string list
+
"-v", Arg.Set(verbose), " verbose mode"; ] @
IFNDEF NTRACE
THEN [
- "-log", Arg.String (set_tracer),
+ "-log", Arg.String (set_logger),
"<logger1:l1,...,loggern:ln> enable logging with the specified level. Valid loggers are: "
^ (pretty_loggers ())
]
+open Format
+
exception InvalidUtf8Codepoint of int
let subscripts = "₀₁₂₃₄₅₆₇₈₉"
let ppf f fmt s =
- Format.fprintf fmt "%s" (f s)
+ pp_print_string fmt (f s)
let pp_overline = ppf overline
let pp_underline = ppf underline
let pp_strike = ppf strike
let pp_subscript = ppf subscript
let pp_superscript = ppf superscript
+let dummy_printer fmt () = ()
-let print_list ?(sep=" ") printer fmt l =
+let pp_print_list ?(sep=dummy_printer) printer fmt l =
match l with
- [] -> ()
- | [ e ] -> printer fmt e
- | e::es -> printer fmt e; List.iter (fun x -> Format.fprintf fmt "%s%a" sep printer x) es
+ [] -> ()
+ | [ e ] -> printer fmt e
+ | e :: es -> printer fmt e; List.iter
+ (fun x ->
+ sep fmt ();
+ fprintf fmt "%a" printer x) es
+
+let pp_print_array ?(sep=dummy_printer) printer fmt a =
+ pp_print_list ~sep:sep printer fmt (Array.to_list a)
+
+let print_list ?(sep=" ") printer fmt l =
+ let sep_printer fmt () =
+ pp_print_string fmt sep
+ in
+ pp_print_list ~sep:sep_printer printer fmt l
+
+let print_array ?(sep=" ") printer fmt a =
+ print_list ~sep:sep printer fmt (Array.to_list a)
+
-let print_array ?(sep=" ") printer fmt l =
- print_list ~sep:sep printer fmt (Array.to_list l)
val pp_subscript : Format.formatter -> int -> unit
val pp_superscript : Format.formatter -> int -> unit
+val pp_print_list :
+ ?sep:(Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
+val pp_print_array :
+ ?sep:(Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a array -> unit
val print_list : ?sep:string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
val print_array : ?sep:string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a array -> unit
(match code with
| Nil -> ()
| Cons(dst, opcode, code1) ->
- LOG("res-jit", 3, __ " %a := %a\n%!"
+ LOG(__ "res-jit" 3 " %a := %a"
State.print dst print_opcode opcode;
);
exec_code slot slot1 slot2 t dst opcode;
match code1 with
| Nil -> ()
| Cons(dst, opcode, code1) ->
- LOG("res-jit", 3, __ " %a := %a\n%!"
+ LOG(__ "res-jit" 3 " %a := %a"
State.print dst print_opcode opcode;
);
exec_code slot slot1 slot2 t dst opcode;
end)
DEFINE EXEC_TEMPLATE =
- (LOG("res-jit", 3, __ "Node %i:\n" (Node.to_int t));
- LOG("res-jit", 3, __ " LEFT : %a\n" print slot1);
- LOG("res-jit", 3, __ " RIGHT : %a\n" print slot2);
+ (LOG(__ "res-jit" 3 "Node %i:@\nLEFT : %a@\nRIGHT : %a"
+ (Node.to_int t) print slot1 print slot2
+ );
exec slot slot1 slot2 t code;
- LOG("res-jit", 3, __ " RES : %a\n\n%!" print slot))
+ LOG(__ "res-jit" 3 "RES : %a" print slot))
module type S =
let eval_trans auto s1 s2 trans =
- LOG("top-down-run", 2, __ "Evaluating transition list:\n%!");
- LOG("top-down-run", 2, __ "%a\n%!" Translist.print trans);
+ LOG(__ "top-down-run" 3 "Evaluating transition list:@\n%a" Translist.print trans);
Translist.fold
(fun t ((a_st, a_op, a_todo) as acc)->
let q, _, m, f = Transition.node t in
else sl1
else sl2
in
- eprintf "Here 1\n%!";
U.exec sl sl1 sl2 node code;
res, sl
end
else sl1
else sl2
in
- eprintf "Here 2\n%!";
U.exec sl sl1 sl2 node code;
res, sl
end
let cache_apply cache auto tlist s1 s2 =
let f = gen_code auto tlist s1 s2 in
- LOG("grammar", 2, __ "Inserting: %i, %a, %a\n%!"
+ LOG(__ "grammar" 2 "Inserting: %i, %a, %a\n%!"
(Uid.to_int tlist.Translist.Node.id) StateSet.print s1 StateSet.print s2);
add cache tlist s1 s2 f; f
end
DEFINE LOOP (t, states, ctx) = (
let _t = t in
- LOG("top-down-run", 3,
- __ "Entering node %i with loop (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));
+ LOG(__ "top-down-run" 3
+ "Entering node %i with loop (tag %s, context %i) with states %a"
+ (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
DEFINE LOOP_TAG (t, states, tag, ctx) = (
let _t = (t) in (* to avoid duplicating expression t *)
- LOG("top-down-run", 3,
- __ "Entering node %i with loop_tag (tag %s, context %i) with states %a\n%!"
+ LOG(__ "top-down-run" 3
+ "Entering node %i with loop_tag (tag %s, context %i) with states %a"
(Node.to_int _t)
(Tag.to_string (tag))
(Node.to_int (ctx))
match opcode with
| L2JIT.RETURN -> nil_res
| L2JIT.CACHE ->
- LOG("top-down-run", 3,
- __ "Top-down cache miss for configuration %s %a\n%!"
+ LOG(__ "top-down-run" 3
+ "Top-down cache miss for configuration %s %a"
(Tag.to_string tag) StateSet.print states);
let opcode = L2JIT.compile cache2 auto tree tag states in
l2jit_dispatch t tag states ctx opcode
in
let lambda = ref 0 in
let rec start_loop idx states =
- LOG("grammar", 2, __ "Node %i\n%!" (Node.to_int idx));
+ LOG(__ "grammar" 2 "Node %i\n%!" (Node.to_int idx));
if states == dummy_set then nil_res else
if idx < Node.null then nil_res
else begin
let set a i v =
- LOG("twopass", 2, __ "Setting node %i to state %a\n%!"
+ LOG(__ "twopass" 2 "Setting node %i to state %a\n%!"
i StateSet.print v);
a.(i) <- v
auto.bottom_states
else
let tag = Tree.tag tree t in
- LOG("twopass", 2, __ "Traversing node %i (tag %s) in states %a\n%!" (Node.to_int t) (Tag.to_string tag)
+ LOG(__ "twopass" 2 "Traversing node %i (tag %s) in states %a\n%!" (Node.to_int t) (Tag.to_string tag)
StateSet.print states
);
let trans, lstates, rstates =
c
else c
in
- LOG("twopass", 2, __ "\nTransitions are:\n%!");
- LOG("twopass", 2, __ "\nTransitions are:\n%a\n%!"
+ LOG(__ "twopass" 2 "\nTransitions are:\n%!");
+ LOG(__ "twopass" 2"\nTransitions are:\n%a\n%!"
Translist.print trans
);
let s1 = loop (Tree.first_child tree t) lstates ctx
(Uid.to_int trans.Translist.Node.id) c;c
else c
in
- LOG("twopass", 2, __ "Evaluating node %i (tag %s).\n%!States=%a\n%!"
+ LOG(__ "twopass" 2 "Evaluating node %i (tag %s).\n%!States=%a\n%!"
(Node.to_int t)
(Tag.to_string tag)
StateSet.print states
);
- LOG("twopass", 2, __ "Translist=%a\nLeft=%a\nRight=%a\nMark=%s\n\n%!"
+ LOG(__ "twopass" 2 "Translist=%a\nLeft=%a\nRight=%a\nMark=%s\n\n%!"
Translist.print trans
StateSet.print s1
StateSet.print s2
let twopass_top_down_run auto tree root =
let len = Node.to_int (Tree.closing tree root) + 1 in
- LOG("twopass", 2, __ "Creating array of size: %i\n%!" len);
+ LOG(__ "twopass" 2 "Creating array of size: %i\n%!" len);
let states_array = Array.make len StateSet.empty in
let _, cache =
twopass_top_down states_array auto tree root auto.init Tree.nil
end)
let compare t1 t2 =
let s1, l1, m1, f1 = node t1
- and s2, l2, m2, f2 = node t2
- in
+ and s2, l2, m2, f2 = node t2 in
let r = compare s1 s2 in
+ if r != 0 then r else
+ let r = TagSet.compare l1 l2 in
if r != 0 then r else
- let r = TagSet.compare l1 l2 in
- if r != 0 then r else
- let r = compare m1 m2 in
- if r != 0 then r else
- Formula.compare f1 f2
+ let r = compare m1 m2 in
+ if r != 0 then r else
+ Formula.compare f1 f2
-let print_lhs ppf t =
+let print_lhs (ppf: Format.formatter) (t : t) : unit =
let state, tagset , _, _ = node t in
- fprintf ppf "(%a, %a)"
- State.print state TagSet.print tagset
+ fprintf ppf "(%a, %a)%!"
+ State.print state TagSet.print tagset
let print_arrow ppf t =
let _, _, mark, _ = node t in
- fprintf ppf "%s"
- (if mark then Pretty.double_right_arrow else Pretty.right_arrow)
+ fprintf ppf "%s%!"
+ (if mark then Pretty.double_right_arrow else Pretty.right_arrow)
let print_rhs ppf t =
let _, _, _, f = node t in
- Formula.print ppf f
+ Formula.print ppf f
-let print ppf f =
- print_lhs ppf f;
- print_arrow ppf f;
- print_rhs ppf f
+let string_of f x =
+ ignore (flush_str_formatter());
+ fprintf str_formatter "%a" f x;
+ flush_str_formatter ()
-let format_list l =
+let print ppf f =
+ let s1 = string_of print_lhs f in
+ let s2 = string_of print_arrow f in
+ let s3 = string_of print_rhs f in
+ fprintf ppf "%s %s %s%!" s1 s2 s3
+(*
+ fprintf ppf "%!%a%a%a%!" print_lhs f print_arrow f print_rhs f
+*)
+let format_list =
+ let b = Buffer.create 10 in
+ fun l ->
let make_str f x =
- let b = Buffer.create 10 in
+ Buffer.clear b;
let fmt = formatter_of_buffer b in
pp_print_flush fmt ();
fprintf fmt "%a" f x;
Buffer.contents b
in
let str_trans t =
- let lhs = make_str print_lhs t
- and arrow = make_str print_arrow t
- and rhs = make_str print_rhs t in
- (lhs, arrow, rhs)
+ let lhs = make_str print_lhs t in
+ let arrow = make_str print_arrow t in
+ let rhs = make_str print_rhs t in
+ (lhs, arrow, rhs)
in
let size, strings =
List.fold_left
(fun (a_size, a_str) tr ->
- let lhs, _, _ as str = str_trans tr in
- let len = String.length lhs in
- ((if len > a_size then len else a_size),
- str::a_str)) (0, []) l
+ let lhs, _, _ as str = str_trans tr in
+ let len = String.length lhs in
+ ((if len > a_size then len else a_size),
+ str::a_str)) (0, []) l
in
- List.map (fun (lhs, arrow, rhs) ->
- sprintf "%s%s%s %s"
- lhs
- (Pretty.padding (size - Pretty.length lhs))
- arrow
- rhs) (List.rev strings)
+ List.map (fun (lhs, arrow, rhs) ->
+ sprintf "%s%s%s %s@?"
+ lhs
+ (Pretty.padding (size - Pretty.length lhs))
+ arrow
+ rhs) (List.rev strings)
module Infix = struct
let ( ?< ) x = x
+open Format
include Hlist.Make(Transition)
let print ppf fl =
let l = fold (fun t acc -> t :: acc) fl [] in
let strings = Transition.format_list l in
- List.iter (fun s -> Format.fprintf ppf "%s\n%!" s) strings
+ Pretty.pp_print_list ~sep:pp_force_newline pp_print_string ppf strings
projects / SXSI / xpathcomp.git / commitdiff