From 7c4c61cec6fe1ae3a1b83a59b17ce90adcfe9b0b Mon Sep 17 00:00:00 2001 From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= Date: Mon, 19 Mar 2012 18:40:25 +0100 Subject: [PATCH] Rename 'Tracer' module to 'Logger'. --- include/log.ml | 28 ++++++ include/trace.ml | 26 ------ myocamlbuild.ml | 4 +- src/ata.ml | 15 +++- src/cache.ml | 8 +- src/l2JIT.ml | 223 ++++++++++++++++++++++------------------------- src/logger.ml | 25 ++++++ src/logger.mli | 11 +++ src/main.ml | 5 +- src/options.ml | 24 +++-- src/options.mli | 1 + src/resJIT.ml | 14 +-- src/runtime.ml | 34 ++++---- src/tracer.ml | 25 ------ src/tracer.mli | 11 --- 15 files changed, 223 insertions(+), 231 deletions(-) create mode 100644 include/log.ml delete mode 100644 include/trace.ml create mode 100644 src/logger.ml create mode 100644 src/logger.mli delete mode 100644 src/tracer.ml delete mode 100644 src/tracer.mli diff --git a/include/log.ml b/include/log.ml new file mode 100644 index 0000000..b9ad225 --- /dev/null +++ b/include/log.ml @@ -0,0 +1,28 @@ +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 +;; +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)) + +ELSE + +DEFINE LOG(t, l, r) = () + +END + + + + +END diff --git a/include/trace.ml b/include/trace.ml deleted file mode 100644 index 0e36ecc..0000000 --- a/include/trace.ml +++ /dev/null @@ -1,26 +0,0 @@ -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 9c90feb..d0277af 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -105,8 +105,8 @@ let () = dispatch begin Options.ocamldoc := ocamlfind (A"ocamldoc"); Options.ocamlmktop := ocamlfind (A"ocamlmktop"); - if not (List.mem "trace" !Options.tags) then begin - pp_macro_options @= [ A "-DNTRACE" ]; + if not (List.mem "log" !Options.tags) then begin + pp_macro_options @= [ A "-DNLOG" ]; end; if (List.mem "profile" !Options.tags) then begin pp_macro_options @= [ A "-DPROFILE" ]; diff --git a/src/ata.ml b/src/ata.ml index 8f7529f..5287ed5 100644 --- a/src/ata.ml +++ b/src/ata.ml @@ -1,6 +1,6 @@ INCLUDE "debug.ml" INCLUDE "utils.ml" -INCLUDE "trace.ml" +INCLUDE "log.ml" open Format @@ -120,7 +120,7 @@ let compute_jump auto tree states l marking = | _ -> if Ptset.Int.mem Tag.pcdata rel_labels then begin - TRACE("top-down-approx", 3, __ "Computed rel_labels: %a\n" + LOG("top-down-approx", 3, __ "Computed rel_labels: %a\n" TagSet.print (TagSet.inj_positive rel_labels)); NODE @@ -209,7 +209,7 @@ let top_down_approx auto states tree = merge_trans by_states merge_labels (List.sort by_states uniq_states_trs) in - TRACE( + LOG( "top-down-approx", 2, let is_pairwise_disjoint l = List.for_all (fun ((ts, _) as tr) -> @@ -260,7 +260,14 @@ let get_trans ?(attributes=TagSet.empty) auto states tag = List.fold_left (fun ((tr_acc, l_acc, r_acc) as acc) (ts, tr) -> let ts = if ts == TagSet.star then TagSet.diff ts attributes else ts in - if TagSet.mem tag ts then + let b = TagSet.mem tag ts in + let () = LOG("transition", 3, __ "Transition: %a, tag=%s, %s\n%!" + Transition.print + tr + (Tag.to_string tag) + (if b then "selected" else "not selected")) + in + if b then let _, _, _, f = Transition.node tr in let l, r = Formula.st f in (Translist.cons tr tr_acc, diff --git a/src/cache.ml b/src/cache.ml index 60301fe..68cae67 100644 --- a/src/cache.ml +++ b/src/cache.ml @@ -1,4 +1,3 @@ -INCLUDE "trace.ml" let realloc l old_size new_size dummy = let l' = Array.create new_size dummy in @@ -30,11 +29,9 @@ struct Format.fprintf fmt "%s" "E")) a.line let add a i v = - TRACE("twopass", 2, __ "Before add (%i): %a\n%!" i print a); if a.offset == ~-1 then a.offset <- i; let offset = a.offset in let len = Array.length a.line in - let () = if i >= offset && i < offset + len then a.line.(i - offset) <- v else @@ -58,8 +55,6 @@ struct narray.(i - offset) <- v; a.line <- narray end - in - TRACE("twopass", 2, __ "After add (%i): %a\n%!" i print a) let find a i = let offset = a.offset in @@ -94,16 +89,15 @@ struct let add a i j v = - TRACE("twopass", 2, __ "Adding %i %i\n%!" i j); let line = Lvl1.find a i in if line == a.Lvl1.dummy then let nline = Lvl1.create 0 line.Lvl1.dummy in - TRACE("twopass", 2, __ "Reallocating\n%!"); Lvl1.add a i nline; Lvl1.add nline j v else Lvl1.add line j v + let find a i j = let v = Lvl1.find a i in if v == a.Lvl1.dummy then a.Lvl1.dummy.Lvl1.dummy diff --git a/src/l2JIT.ml b/src/l2JIT.ml index 4abb5e7..de41e62 100644 --- a/src/l2JIT.ml +++ b/src/l2JIT.ml @@ -1,6 +1,6 @@ INCLUDE "debug.ml" INCLUDE "utils.ml" -INCLUDE "trace.ml" +INCLUDE "log.ml" open Format open Ata @@ -45,39 +45,39 @@ let jump_stat_table = Hashtbl.create 17 let jump_stat_init () = Hashtbl.clear jump_stat_table let jump_stat j = let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in - Hashtbl.replace jump_stat_table j (i+1) + Hashtbl.replace jump_stat_table j (i+1) let print_jump fmt j = match j with - | NOP _ -> fprintf fmt "nop" - | FIRST_CHILD _ -> fprintf fmt "first_child" - | NEXT_SIBLING _ -> fprintf fmt "next_sibling" - | FIRST_ELEMENT _ -> fprintf fmt "first_element" - | NEXT_ELEMENT _ -> fprintf fmt "next_element" + | NOP _ -> fprintf fmt "nop" + | FIRST_CHILD _ -> fprintf fmt "first_child" + | NEXT_SIBLING _ -> fprintf fmt "next_sibling" + | FIRST_ELEMENT _ -> fprintf fmt "first_element" + | NEXT_ELEMENT _ -> fprintf fmt "next_element" - | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag) + | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag) - | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag) + | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag) - | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)" - TagSet.print (TagSet.inj_positive tags) + | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)" + TagSet.print (TagSet.inj_positive tags) - | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)" - TagSet.print (TagSet.inj_positive tags) + | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)" + TagSet.print (TagSet.inj_positive tags) - | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag) + | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag) - | TAGGED_FOLLOWING_SIBLING (_, tag) -> - fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag) + | TAGGED_FOLLOWING_SIBLING (_, tag) -> + fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag) - | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)" - TagSet.print (TagSet.inj_positive tags) + | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)" + TagSet.print (TagSet.inj_positive tags) - | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)" - TagSet.print (TagSet.inj_positive tags) + | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)" + TagSet.print (TagSet.inj_positive tags) - | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag) - | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree" + | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag) + | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree" let jump_stat_summary fmt = fprintf fmt "Jump function summary:\n%!"; @@ -102,36 +102,36 @@ let print_opcode fmt o = match o with | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2 (* -let print_cache fmt d = + let print_cache fmt d = let c = Cache.Lvl2.to_array d in Array.iteri begin fun tag a -> - let tagstr = Tag.to_string tag in - if a != Cache.Lvl2.dummy_line d && tagstr <> "" - then begin - fprintf fmt "Entry %s: \n" tagstr; - Array.iter (fun o -> if o != dummy then begin - print_opcode fmt o; - fprintf fmt "\n%!" end) a; - fprintf fmt "---------------------------\n%!" - end + let tagstr = Tag.to_string tag in + if a != Cache.Lvl2.dummy_line d && tagstr <> "" + then begin + fprintf fmt "Entry %s: \n" tagstr; + Array.iter (fun o -> if o != dummy then begin + print_opcode fmt o; + fprintf fmt "\n%!" end) a; + fprintf fmt "---------------------------\n%!" + end end c *) let create () = Cache.Lvl2.create 4096 dummy (* -let stats fmt c = + let stats fmt c = let d = Cache.Lvl2.to_array c in let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in let lvl2 = Array.fold_left (fun acc a -> - Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1) - acc a) 0 d + Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1) + acc a) 0 d in fprintf fmt "L2JIT Statistics: -\t%i entries -\t%i used L1 lines -\t%i used L2 lines -\ttable size: %ikb\n" - len lvl1 lvl2 (Ocaml.size_kb d); + \t%i entries + \t%i used L1 lines + \t%i used L2 lines + \ttable size: %ikb\n" + len lvl1 lvl2 (Ocaml.size_kb d); fprintf fmt "%s" "L2JIT Content:\n"; print_cache fmt c *) @@ -140,62 +140,53 @@ let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v -let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) = - if TagSet.mem tag labels - then - let _, _, _, f = Transition.node tr in - let s1, s2 = Formula.st f in - (Translist.cons tr a_t, - StateSet.union s1 a_s1, - StateSet.union s2 a_s2) - else acc let has_text l = Ptset.Int.mem Tag.pcdata l let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s = let child, desc, sib, fol = Tree.tags tree tag in - match jkind, dir with - | NIL, _ -> _nop - | NODE, DIR_LEFT -> FIRST_CHILD s - | STAR, DIR_LEFT -> FIRST_ELEMENT s - | NODE, DIR_RIGHT -> NEXT_SIBLING s - | STAR, DIR_RIGHT -> NEXT_ELEMENT s - | JUMP_ONE t, _ -> - let l_one, l_many, tagged_one, select_one, any, any_notext = - if dir = DIR_LEFT then - child, desc, _tagged_child, _select_child,_first_child, _first_element - else - sib, fol, _tagged_following_sibling, _select_following_sibling, - _next_sibling, _next_element - in - let labels = Ptset.Int.inter l_one t in - let c = Ptset.Int.cardinal labels in - if c == 0 then _nop - else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then - translate_jump tree tag (JUMP_MANY(labels)) dir s - else if c == 1 then tagged_one s (Ptset.Int.choose labels) - else if c > 5 then if has_text labels then any s else any_notext s - else select_one s labels - - | JUMP_MANY t, _ -> - let l_many, tagged_many, select_many, any, any_notext = - if dir == DIR_LEFT then - desc, _tagged_descendant, _select_descendant,_first_child, _first_element - else - fol, _tagged_following, _select_following, _next_sibling, _next_element - in - let labels = Ptset.Int.inter l_many t in - let c = Ptset.Int.cardinal labels in - if c == 0 then _nop - else if c == 1 then tagged_many s (Ptset.Int.choose labels) - else if c > 5 then if has_text labels then any s else any_notext s - else select_many s labels - - | CAPTURE_MANY (t), DIR_LEFT -> - if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t) - else if t == Tree.element_tags tree then ELEMENT_SUBTREE s - else assert false - | _ -> assert false + match jkind, dir with + | NIL, _ -> _nop + | NODE, DIR_LEFT -> FIRST_CHILD s + | STAR, DIR_LEFT -> FIRST_ELEMENT s + | NODE, DIR_RIGHT -> NEXT_SIBLING s + | STAR, DIR_RIGHT -> NEXT_ELEMENT s + | JUMP_ONE t, _ -> + let l_one, l_many, tagged_one, select_one, any, any_notext = + if dir = DIR_LEFT then + child, desc, _tagged_child, _select_child,_first_child, _first_element + else + sib, fol, _tagged_following_sibling, _select_following_sibling, + _next_sibling, _next_element + in + let labels = Ptset.Int.inter l_one t in + let c = Ptset.Int.cardinal labels in + if c == 0 then _nop + else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then + translate_jump tree tag (JUMP_MANY(labels)) dir s + else if c == 1 then tagged_one s (Ptset.Int.choose labels) + else if c > 5 then if has_text labels then any s else any_notext s + else select_one s labels + + | JUMP_MANY t, _ -> + let l_many, tagged_many, select_many, any, any_notext = + if dir == DIR_LEFT then + desc, _tagged_descendant, _select_descendant,_first_child, _first_element + else + fol, _tagged_following, _select_following, _next_sibling, _next_element + in + let labels = Ptset.Int.inter l_many t in + let c = Ptset.Int.cardinal labels in + if c == 0 then _nop + else if c == 1 then tagged_many s (Ptset.Int.choose labels) + else if c > 5 then if has_text labels then any s else any_notext s + else select_many s labels + + | CAPTURE_MANY (t), DIR_LEFT -> + if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t) + else if t == Tree.element_tags tree then ELEMENT_SUBTREE s + else assert false + | _ -> assert false let compute_jump auto tree tag states dir = if !Options.no_jump then @@ -204,49 +195,43 @@ 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 - TRACE("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") - print_jump jump - ); + 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") + print_jump jump + ); jump let compile cache2 auto tree tag states = let tr_list, states1, states2 = - StateSet.fold - (fun q acc -> - List.fold_left (collect_trans tag) - acc - (Hashtbl.find auto.trans q)) - states - (Translist.nil, StateSet.empty, StateSet.empty) + Ata.get_trans ~attributes:(TagSet.inj_positive (Tree.attribute_tags tree)) auto states tag in let op = let empty_s1 = StateSet.is_empty states1 in let empty_s2 = StateSet.is_empty states2 in - if empty_s1 && empty_s2 then RETURN - else if empty_s1 then - RIGHT (tr_list, - compute_jump auto tree tag states2 DIR_RIGHT) - else if empty_s2 then - LEFT (tr_list, - compute_jump auto tree tag states1 DIR_LEFT) - else - let j1 = compute_jump auto tree tag states1 DIR_LEFT in - let j2 = compute_jump auto tree tag states2 DIR_RIGHT in - BOTH (tr_list, j1, j2); + if empty_s1 && empty_s2 then RETURN + else if empty_s1 then + RIGHT (tr_list, + compute_jump auto tree tag states2 DIR_RIGHT) + else if empty_s2 then + LEFT (tr_list, + compute_jump auto tree tag states1 DIR_LEFT) + else + let j1 = compute_jump auto tree tag states1 DIR_LEFT in + let j2 = compute_jump auto tree tag states2 DIR_RIGHT in + BOTH (tr_list, j1, j2); in let op = match op with - (*BOTH(_, NOP _, NOP _) | LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *) + (*BOTH(_, NOP _, NOP _) | LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *) | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l) | BOTH(tr, l, NOP _) -> LEFT (tr, l) | BOTH(tr, NOP _, r) -> RIGHT (tr, r) | _ -> op in - add cache2 tag states op; - op + add cache2 tag states op; + op let get_transitions = function | CACHE | RETURN -> failwith "get_transitions" diff --git a/src/logger.ml b/src/logger.ml new file mode 100644 index 0000000..a206382 --- /dev/null +++ b/src/logger.ml @@ -0,0 +1,25 @@ +open Format + +type t = string +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 available () = loggers + +let is_logger s = List.mem s loggers +let level s = try Hashtbl.find active_loggers s with Not_found -> 0 +let is_active s = Hashtbl.mem active_loggers s +let activate s lvl = if not (is_active s) then Hashtbl.add active_loggers s lvl +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 = + if l <= level t + then begin + fprintf !logger_output "%s: " t; + fprintf !logger_output "%s%!" s + end diff --git a/src/logger.mli b/src/logger.mli new file mode 100644 index 0000000..a9c827d --- /dev/null +++ b/src/logger.mli @@ -0,0 +1,11 @@ +type t = string +type level = int +val is_logger : t -> bool +val is_active : t -> bool +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 available : unit -> string list diff --git a/src/main.ml b/src/main.ml index 2349ad1..605c0e6 100644 --- a/src/main.ml +++ b/src/main.ml @@ -78,7 +78,10 @@ let main v query_string output = let module R = ResJIT.Count in let module M = Runtime.Make(R) in (* mk_runtime run auto doc arg count print outfile *) - mk_runtime M.twopass_top_down_run auto v Tree.root R.NS.length R.NS.serialize None + if !Options.twopass then + mk_runtime M.twopass_top_down_run auto v Tree.root R.NS.length R.NS.serialize None + else + mk_runtime M.top_down_run auto v Tree.root R.NS.length R.NS.serialize None else let module R = ResJIT.Mat in let module M = Runtime.Make(R) in diff --git a/src/options.ml b/src/options.ml index 70d702d..8285888 100644 --- a/src/options.ml +++ b/src/options.ml @@ -17,10 +17,7 @@ let no_jump = ref false let verbose = ref false let text_index_type = ref 0 let do_perf = ref false - -(* Only valid if compiled with -DTRACE *) -let trace_file = ref "trace.dot" - +let twopass = ref false let set_index_type = function | "default" -> text_index_type := 0 @@ -38,31 +35,34 @@ let anon_fun = | 2 -> output_file := Some s; incr pos | _ -> raise (Arg.Bad(s)) -let set_tracer s = +let set_logger 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 + if Logger.is_logger tr then Logger.activate tr l else raise (Arg.Bad (t)) | _ -> raise (Arg.Bad (t)) ) (String.explode s ',') -let pretty_tracers () = +let pretty_loggers () = ignore(flush_str_formatter()); Pretty.print_list ~sep:", " (fun f s -> fprintf f "%s" s) str_formatter - (Tracer.available ()); + (Logger.available ()); flush_str_formatter () let spec = Arg.align [ "-c", Arg.Set(count_only), " counting only (don't materialize the result set)"; + "-two", Arg.Set(twopass), + " Use twopass algorithm"; + "-f", Arg.Set_int(sample_factor), " sample factor [default=64]"; @@ -88,11 +88,9 @@ let spec = Arg.align "-v", Arg.Set(verbose), " verbose mode"; ] @ IFNDEF NTRACE THEN [ - "-trace-file", Arg.Set_string(trace_file), - " save the full trace in dot format in "; - "-trace", Arg.String (set_tracer), - " enable tracing with the specified level. Valid tracers are: " - ^ (pretty_tracers ()) + "-log", Arg.String (set_tracer), + " enable logging with the specified level. Valid loggers are: " + ^ (pretty_loggers ()) ] ELSE [] END diff --git a/src/options.mli b/src/options.mli index 57f142b..e57f0cb 100644 --- a/src/options.mli +++ b/src/options.mli @@ -14,3 +14,4 @@ val no_jump : bool ref val verbose : bool ref val text_index_type : int ref val do_perf : bool ref +val twopass : bool ref diff --git a/src/resJIT.ml b/src/resJIT.ml index 25502b6..215938b 100644 --- a/src/resJIT.ml +++ b/src/resJIT.ml @@ -1,6 +1,6 @@ INCLUDE "debug.ml" INCLUDE "utils.ml" -INCLUDE "trace.ml" +INCLUDE "log.ml" open Format @@ -275,7 +275,7 @@ DEFINE EXEC_REC_TEMPLATE = (match code with | Nil -> () | Cons(dst, opcode, code1) -> - TRACE("res-jit", 3, __ " %a := %a\n%!" + LOG("res-jit", 3, __ " %a := %a\n%!" 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) -> - TRACE("res-jit", 3, __ " %a := %a\n%!" + LOG("res-jit", 3, __ " %a := %a\n%!" 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 = -(* (TRACE("res-jit", 3, __ "Node %i:\n" (Node.to_int t)); - TRACE("res-jit", 3, __ " LEFT : %a\n" pr_slot slot1); - TRACE("res-jit", 3, __ " RIGHT : %a\n" pr_slot slot2); *) + (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); exec slot slot1 slot2 t code; -(* TRACE("res-jit", 3, __ " RES : %a\n\n%!" pr_slot slot))*) + LOG("res-jit", 3, __ " RES : %a\n\n%!" print slot)) module type S = diff --git a/src/runtime.ml b/src/runtime.ml index 2d76bc1..2f59c65 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -1,5 +1,5 @@ INCLUDE "debug.ml" -INCLUDE "trace.ml" +INCLUDE "log.ml" INCLUDE "utils.ml" open Format @@ -43,8 +43,8 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = let eval_trans auto s1 s2 trans = - TRACE("top-down-run", 2, __ "Evaluating transition list:\n%!"); - TRACE("top-down-run", 2, __ "%a\n%!" Translist.print trans); + LOG("top-down-run", 2, __ "Evaluating transition list:\n%!"); + LOG("top-down-run", 2, __ "%a\n%!" Translist.print trans); Translist.fold (fun t ((a_st, a_op, a_todo) as acc)-> let q, _, m, f = Transition.node t in @@ -170,14 +170,14 @@ 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 - TRACE("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 - TRACE("top-down-run", 3, + 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)) @@ -192,7 +192,7 @@ DEFINE LOOP (t, states, ctx) = ( DEFINE LOOP_TAG (t, states, tag, ctx) = ( let _t = (t) in (* to avoid duplicating expression t *) - TRACE("top-down-run", 3, + LOG("top-down-run", 3, __ "Entering node %i with loop_tag (tag %s, context %i) with states %a\n%!" (Node.to_int _t) (Tag.to_string (tag)) @@ -228,7 +228,9 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( match opcode with | L2JIT.RETURN -> nil_res | L2JIT.CACHE -> - eprintf "New configuration\n%!"; + LOG("top-down-run", 3, + __ "Top-down cache miss for configuration %s %a\n%!" + (Tag.to_string tag) StateSet.print states); let opcode = L2JIT.compile cache2 auto tree tag states in l2jit_dispatch t tag states ctx opcode @@ -254,7 +256,7 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( l3jit_dispatch tr_list res1 res2 t slot1 slot2 and l2jit_dispatch_instr t ctx instr = - match instr with + match instr with | L2JIT.NOP () -> nil_res | L2JIT.FIRST_CHILD s -> LOOP ((Tree.first_child tree t), s, ctx) | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_sibling tree t), s, ctx) @@ -519,7 +521,7 @@ let dispatch_param1 conf id2 y0 y1 = in let lambda = ref 0 in let rec start_loop idx states = - TRACE("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 @@ -725,7 +727,7 @@ let dispatch_param1 conf id2 y0 y1 = let set a i v = - TRACE("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 @@ -742,7 +744,7 @@ let dispatch_param1 conf id2 y0 y1 = auto.bottom_states else let tag = Tree.tag tree t in - TRACE("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 = @@ -753,8 +755,8 @@ let dispatch_param1 conf id2 y0 y1 = c else c in - TRACE("twopass", 2, __ "\nTransitions are:\n%!"); - TRACE("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 @@ -816,12 +818,12 @@ let dispatch_param1 conf id2 y0 y1 = (Uid.to_int trans.Translist.Node.id) c;c else c in - TRACE("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 ); - TRACE("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 @@ -838,7 +840,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 - TRACE("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/tracer.ml b/src/tracer.ml deleted file mode 100644 index 17e0540..0000000 --- a/src/tracer.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Format - -type tracer = string -type level = int - -let tracers = [ "top-down-run"; "top-down-approx"; "result-set"; "level2-jit"; "res-jit"; "grammar"; "twopass" ] -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 deleted file mode 100644 index 99c078b..0000000 --- a/src/tracer.mli +++ /dev/null @@ -1,11 +0,0 @@ -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 -- 2.17.1