X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=src%2Fl2JIT.ml;h=90105d8795339eecf2a2e7bc42d26182fac14db0;hb=3791216bfb2b9d966718f83fd414e8bcd5f7a066;hp=6eccae3ba56445730a9cbdc4f6488ae89f13dc6e;hpb=4b52da1a20a4fe031930bb96d2ca46bec06dc529;p=SXSI%2Fxpathcomp.git diff --git a/src/l2JIT.ml b/src/l2JIT.ml index 6eccae3..90105d8 100644 --- a/src/l2JIT.ml +++ b/src/l2JIT.ml @@ -1,5 +1,6 @@ INCLUDE "debug.ml" INCLUDE "utils.ml" +INCLUDE "log.ml" open Format open Ata @@ -44,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%!"; @@ -85,168 +86,155 @@ let jump_stat_summary fmt = type opcode = - | CACHE of unit - | RETURN of unit + | CACHE + | RETURN | LEFT of Translist.t * jump | RIGHT of Translist.t * jump | BOTH of Translist.t * jump * jump type t = opcode Cache.Lvl2.t -let dummy = CACHE() + +let dummy = CACHE let print_opcode fmt o = match o with - | CACHE _ -> fprintf fmt "CACHE()" - | RETURN _ -> fprintf fmt "RETURN ()" + | CACHE -> fprintf fmt "CACHE" + | RETURN -> fprintf fmt "RETURN" | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j | 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 1024 dummy - -let stats fmt c = +*) +let create () = Cache.Lvl2.create 4096 dummy +(* + 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 +*) -let find t tag set = Cache.Lvl2.find t tag (Uid.to_int set.StateSet.Node.id) +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 tag (Uid.to_int set.StateSet.Node.id) v +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 = - (*PROF_CFUN("L2JIT.compute_jump"); *) if !Options.no_jump then if dir == DIR_LEFT then FIRST_CHILD states else NEXT_SIBLING states else let jkind = Ata.top_down_approx auto states tree in let jump = translate_jump tree tag jkind dir states in - D_TRACE_(eprintf "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 + 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 = - (*PROF_CFUN("L2JIT.compile"); *) 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 - BOTH (tr_list, - compute_jump auto tree tag states1 DIR_LEFT, - compute_jump auto tree tag states2 DIR_RIGHT) + 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" + | CACHE | RETURN -> failwith "get_transitions" | LEFT (tr, _) | RIGHT (tr, _) | BOTH (tr, _, _) -> tr