src/l2JIT.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3 INCLUDE "trace.ml"
   4
   5 open Format
   6 open Ata
   7
   8 type jump =
   9   | FIRST_CHILD of StateSet.t
  10   | NEXT_SIBLING of StateSet.t
  11   | FIRST_ELEMENT of StateSet.t
  12   | NEXT_ELEMENT of StateSet.t
  13   | TAGGED_DESCENDANT of StateSet.t * Tag.t
  14   | TAGGED_FOLLOWING of StateSet.t * Tag.t
  15   | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.unordered_set
  16   | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.unordered_set
  17   | TAGGED_CHILD of StateSet.t * Tag.t
  18   | TAGGED_FOLLOWING_SIBLING of StateSet.t * Tag.t
  19   | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.unordered_set
  20   | SELECT_FOLLOWING_SIBLING of StateSet.t * Ptset.Int.t * Tree.unordered_set
  21   | TAGGED_SUBTREE of StateSet.t * Tag.t
  22   | ELEMENT_SUBTREE of StateSet.t
  23
  24 type dir = DIR_LEFT | DIR_RIGHT
  25 let _nop = None
  26 let _first_child s = Some (FIRST_CHILD s)
  27 let _next_sibling s = Some (NEXT_SIBLING s)
  28 let _first_element s = Some (FIRST_ELEMENT s)
  29 let _next_element s = Some (NEXT_ELEMENT s)
  30 let _tagged_descendant s t = Some (TAGGED_DESCENDANT(s,t))
  31 let _tagged_following s t = Some (TAGGED_FOLLOWING(s,t))
  32 let _select_descendant s t = Some (SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t))
  33 let _select_following s t = Some (SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t))
  34 let _tagged_child s t = Some (TAGGED_CHILD(s,t))
  35 let _tagged_following_sibling s t = Some (TAGGED_FOLLOWING_SIBLING(s,t))
  36 let _select_child s t = Some (SELECT_CHILD(s,t, Tree.unordered_set_of_set t))
  37 let _select_following_sibling s t = Some (SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t))
  38 let _tagged_subtree s t = Some (TAGGED_SUBTREE (s, t))
  39 let _element_subtree s = Some (ELEMENT_SUBTREE s)
  40
  41
  42 let jump_stat_table = Hashtbl.create 17
  43 let jump_stat_init () = Hashtbl.clear jump_stat_table
  44 let jump_stat j =
  45   let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in
  46     Hashtbl.replace jump_stat_table j (i+1)
  47
  48 let print_jump fmt j =
  49   match j with
  50     | FIRST_CHILD _ -> fprintf fmt "first_child"
  51     | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
  52     | FIRST_ELEMENT _ -> fprintf fmt "first_element"
  53     | NEXT_ELEMENT _ -> fprintf fmt "next_element"
  54
  55     | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag)
  56
  57     | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag)
  58
  59     | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)"
  60         TagSet.print (TagSet.inj_positive tags)
  61
  62     | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)"
  63         TagSet.print (TagSet.inj_positive tags)
  64
  65     | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
  66
  67     | TAGGED_FOLLOWING_SIBLING (_, tag) ->
  68         fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
  69
  70     | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
  71         TagSet.print (TagSet.inj_positive tags)
  72
  73     | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
  74         TagSet.print (TagSet.inj_positive tags)
  75
  76     | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
  77     | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree"
  78
  79 let jump_stat_summary fmt =
  80   fprintf fmt "Jump function summary:\n%!";
  81   Hashtbl.iter (fun k v -> fprintf fmt "%i calls to %a\n" v print_jump k) jump_stat_table;
  82   fprintf fmt "%!"
  83
  84
  85 type opcode =
  86   | CACHE
  87   | RETURN
  88   | LEFT of Translist.t * jump
  89   | RIGHT of Translist.t * jump
  90   | BOTH of Translist.t * jump * jump
  91
  92 type t = opcode Cache.Lvl2.t
  93
  94 let dummy = CACHE
  95 let print_opcode fmt o = match o with
  96   | CACHE  -> fprintf fmt "CACHE"
  97   | RETURN  -> fprintf fmt "RETURN"
  98   | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
  99   | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
 100   | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
 101
 102 let show_stats a =
 103   let count = ref 0 in
 104   Cache.Lvl2.iteri (fun _ _ _ b -> if not b then incr count) a;
 105   eprintf "%!L2JIT: %i used entries\n%!" !count
 106
 107 let create () =
 108   let v = Cache.Lvl2.create 4096 dummy in
 109   if !Options.verbose then
 110     at_exit (fun () -> show_stats v);
 111   v
 112
 113 let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
 114
 115 let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v
 116
 117 let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) =
 118   if TagSet.mem tag labels
 119   then
 120     let _, _, _, f = Transition.node tr in
 121     let (_, _, s1), (_, _, s2) = Formula.st f in
 122       (Translist.cons tr a_t,
 123        StateSet.union s1 a_s1,
 124        StateSet.union s2 a_s2)
 125   else acc
 126
 127 let has_text l = Ptset.Int.mem Tag.pcdata l
 128
 129 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
 130   let child, desc, sib, fol = Tree.tags tree tag in
 131      match jkind, dir with
 132       | NIL, _ -> None
 133       | NODE, DIR_LEFT -> Some (FIRST_CHILD s)
 134       | STAR, DIR_LEFT -> Some (FIRST_ELEMENT s)
 135       | NODE, DIR_RIGHT -> Some (NEXT_SIBLING s)
 136       | STAR, DIR_RIGHT -> Some (NEXT_ELEMENT s)
 137       | JUMP_ONE t, _ ->
 138           let l_one, l_many, tagged_one, select_one, any, any_notext =
 139             if dir = DIR_LEFT then
 140               child, desc, _tagged_child, _select_child,_first_child, _first_element
 141             else
 142               sib, fol, _tagged_following_sibling, _select_following_sibling,
 143             _next_sibling, _next_element
 144           in
 145           let labels = Ptset.Int.inter l_one t in
 146           let c = Ptset.Int.cardinal labels in
 147             if c == 0 then None
 148             else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
 149               translate_jump tree tag (JUMP_MANY(labels)) dir s
 150             else if c == 1 then tagged_one s (Ptset.Int.choose labels)
 151             else if c > 5 then if has_text labels then any s else any_notext s
 152             else select_one s labels
 153
 154       | JUMP_MANY t, _ ->
 155           let l_many, tagged_many, select_many, any, any_notext =
 156             if dir == DIR_LEFT then
 157               desc, _tagged_descendant, _select_descendant,_first_child, _first_element
 158             else
 159               fol, _tagged_following, _select_following, _next_sibling, _next_element
 160           in
 161           let labels = Ptset.Int.inter l_many t in
 162           let c = Ptset.Int.cardinal labels in
 163             if c == 0 then _nop
 164             else if c == 1 then tagged_many s (Ptset.Int.choose labels)
 165             else if c > 5 then if has_text labels then any s else any_notext s
 166             else select_many s labels
 167
 168       | CAPTURE_MANY (t), DIR_LEFT ->
 169           if Ptset.Int.is_singleton t then Some (TAGGED_SUBTREE(s, Ptset.Int.choose t))
 170           else if t == Tree.element_tags tree then Some (ELEMENT_SUBTREE s)
 171           else assert false
 172       | _ -> assert false
 173
 174 let compute_jump auto tree tag states dir =
 175   if !Options.no_jump then
 176     if dir == DIR_LEFT then Some (FIRST_CHILD states)
 177     else Some (NEXT_SIBLING states)
 178   else
 179     let jkind = Ata.top_down_approx auto states tree in
 180     translate_jump tree tag jkind dir states
 181
 182 let mk_left tr_list j =
 183   match j with
 184     Some x -> LEFT(tr_list, x)
 185   | _ -> RETURN
 186
 187 let mk_right tr_list j =
 188   match j with
 189     Some x -> RIGHT(tr_list, x)
 190   | _ -> RETURN
 191
 192 let mk_both tr_list j1 j2 =
 193   match j1, j2 with
 194   | Some x1, Some x2 -> BOTH(tr_list, x1, x2)
 195   | None, Some x -> RIGHT(tr_list,x)
 196   | Some x, None -> LEFT(tr_list, x)
 197   | None, None -> RETURN
 198
 199 let compile cache2 auto tree tag states =
 200   let tr_list, states1, states2 =
 201     StateSet.fold
 202       (fun q acc ->
 203          List.fold_left (collect_trans tag)
 204            acc
 205            (Hashtbl.find auto.trans q))
 206       states
 207       (Translist.nil, StateSet.empty, StateSet.empty)
 208   in
 209   let op =
 210     let empty_s1 = StateSet.is_empty states1 in
 211     let empty_s2 = StateSet.is_empty states2 in
 212       if empty_s1 && empty_s2 then RETURN
 213       else if empty_s1 then
 214         mk_right tr_list
 215           (compute_jump auto tree tag states2 DIR_RIGHT)
 216       else if empty_s2 then
 217         mk_left tr_list
 218           (compute_jump auto tree tag states1 DIR_LEFT)
 219       else
 220         let j1 = compute_jump auto tree tag states1 DIR_LEFT in
 221         let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
 222         mk_both tr_list j1 j2
 223   in
 224     add cache2 tag states op;
 225     op
 226
 227 let get_transitions = function
 228   | CACHE  | RETURN  -> failwith "get_transitions"
 229   | LEFT (tr, _)
 230   | RIGHT (tr, _)
 231   | BOTH (tr, _, _) -> tr
 232