From 3791216bfb2b9d966718f83fd414e8bcd5f7a066 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= Date: Tue, 20 Mar 2012 21:17:18 +0100 Subject: [PATCH] Change the logging infrastructure: - rely on the Format module to correctly indent log messages - re-use the Pretty module has much as possible to print sequences and arrays. - add version of print_list and print_array that take a printer as optional argument to print the separator (rather than a string). --- include/log.ml | 17 +++------- include/utils.ml | 29 +++++++++-------- src/ata.ml | 81 +++++++++++++++++++++++------------------------ src/l2JIT.ml | 4 +-- src/logger.ml | 21 +++++++++--- src/logger.mli | 4 ++- src/options.ml | 2 +- src/pretty.ml | 31 ++++++++++++++---- src/pretty.mli | 4 +++ src/resJIT.ml | 12 +++---- src/runtime.ml | 43 ++++++++++++------------- src/transition.ml | 75 ++++++++++++++++++++++++------------------- src/translist.ml | 3 +- 13 files changed, 181 insertions(+), 145 deletions(-) diff --git a/include/log.ml b/include/log.ml index b9ad225..3180901 100644 --- a/include/log.ml +++ b/include/log.ml @@ -1,24 +1,17 @@ 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 diff --git a/include/utils.ml b/include/utils.ml index 88a1dd2..7d3690a 100644 --- a/include/utils.ml +++ b/include/utils.ml @@ -64,9 +64,9 @@ let time_mem f x = 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 ;; @@ -105,16 +105,19 @@ let stop_perf () = 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;; diff --git a/src/ata.ml b/src/ata.ml index 5287ed5..b24fd6b 100644 --- a/src/ata.ml +++ b/src/ata.ml @@ -120,9 +120,8 @@ let compute_jump auto tree states l marking = | _ -> 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 @@ -210,41 +209,40 @@ let top_down_approx auto states tree = (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 @@ -261,11 +259,10 @@ let get_trans ?(attributes=TagSet.empty) auto states tag = 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 diff --git a/src/l2JIT.ml b/src/l2JIT.ml index de41e62..90105d8 100644 --- a/src/l2JIT.ml +++ b/src/l2JIT.ml @@ -195,8 +195,8 @@ let compute_jump auto tree tag states dir = 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") diff --git a/src/logger.ml b/src/logger.ml index a206382..1b123f1 100644 --- a/src/logger.ml +++ b/src/logger.ml @@ -5,7 +5,7 @@ type level = int 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 @@ -17,9 +17,22 @@ let deactivate s = Hashtbl.remove active_loggers s 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 diff --git a/src/logger.mli b/src/logger.mli index a9c827d..4f2dd5c 100644 --- a/src/logger.mli +++ b/src/logger.mli @@ -6,6 +6,8 @@ val level : t -> level 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 + diff --git a/src/options.ml b/src/options.ml index 8285888..03d24a9 100644 --- a/src/options.ml +++ b/src/options.ml @@ -88,7 +88,7 @@ let spec = Arg.align "-v", Arg.Set(verbose), " verbose mode"; ] @ IFNDEF NTRACE THEN [ - "-log", Arg.String (set_tracer), + "-log", Arg.String (set_logger), " enable logging with the specified level. Valid loggers are: " ^ (pretty_loggers ()) ] diff --git a/src/pretty.ml b/src/pretty.ml index 402433e..1a52d59 100644 --- a/src/pretty.ml +++ b/src/pretty.ml @@ -1,3 +1,5 @@ +open Format + exception InvalidUtf8Codepoint of int let subscripts = "₀₁₂₃₄₅₆₇₈₉" @@ -101,19 +103,34 @@ let line = mk_repeater '_' 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) diff --git a/src/pretty.mli b/src/pretty.mli index 87a2558..20be199 100644 --- a/src/pretty.mli +++ b/src/pretty.mli @@ -28,5 +28,9 @@ val pp_strike : Format.formatter -> string -> unit 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 diff --git a/src/resJIT.ml b/src/resJIT.ml index 215938b..1c32357 100644 --- a/src/resJIT.ml +++ b/src/resJIT.ml @@ -275,7 +275,7 @@ DEFINE EXEC_REC_TEMPLATE = (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; @@ -283,7 +283,7 @@ DEFINE EXEC_REC_TEMPLATE = 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; @@ -292,11 +292,11 @@ DEFINE EXEC_REC_TEMPLATE = 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 = diff --git a/src/runtime.ml b/src/runtime.ml index 2f59c65..d489a64 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -43,8 +43,7 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = 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 @@ -130,7 +129,6 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = else sl1 else sl2 in - eprintf "Here 1\n%!"; U.exec sl sl1 sl2 node code; res, sl end @@ -142,7 +140,6 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = else sl1 else sl2 in - eprintf "Here 2\n%!"; U.exec sl sl1 sl2 node code; res, sl end @@ -170,19 +167,19 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = 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 @@ -192,8 +189,8 @@ DEFINE LOOP (t, states, ctx) = ( 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)) @@ -228,8 +225,8 @@ DEFINE LOOP_TAG (t, states, tag, 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 @@ -521,7 +518,7 @@ let dispatch_param1 conf id2 y0 y1 = 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 @@ -727,7 +724,7 @@ let dispatch_param1 conf id2 y0 y1 = 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 @@ -744,7 +741,7 @@ let dispatch_param1 conf id2 y0 y1 = 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 = @@ -755,8 +752,8 @@ let dispatch_param1 conf id2 y0 y1 = 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 @@ -818,12 +815,12 @@ let dispatch_param1 conf id2 y0 y1 = (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 @@ -840,7 +837,7 @@ let dispatch_param1 conf id2 y0 y1 = 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 diff --git a/src/transition.ml b/src/transition.ml index 9f03aa0..6d868fb 100644 --- a/src/transition.ml +++ b/src/transition.ml @@ -15,38 +15,47 @@ include Hcons.Make(struct 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; @@ -54,25 +63,25 @@ let format_list l = 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 diff --git a/src/translist.ml b/src/translist.ml index f3bcccd..dd7d4b9 100644 --- a/src/translist.ml +++ b/src/translist.ml @@ -1,5 +1,6 @@ +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 -- 2.17.1