src/l2JIT.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3 INCLUDE "log.ml"
   4
   5 open Format
   6 open Ata
   7
   8 type jump =
   9   | NOP of unit
  10   | FIRST_CHILD of StateSet.t
  11   | NEXT_SIBLING of StateSet.t
  12   | FIRST_ELEMENT of StateSet.t
  13   | NEXT_ELEMENT of StateSet.t
  14   | TAGGED_DESCENDANT of StateSet.t * Tag.t
  15   | TAGGED_FOLLOWING of StateSet.t * Tag.t
  16   | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.tag_list
  17   | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.tag_list
  18   | TAGGED_CHILD of StateSet.t * Tag.t
  19   | TAGGED_SIBLING of StateSet.t * Tag.t
  20   | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.tag_list
  21   | SELECT_SIBLING of StateSet.t * Ptset.Int.t * Tree.tag_list
  22   | TAGGED_SUBTREE of StateSet.t * Tag.t
  23   | ELEMENT_SUBTREE of StateSet.t
  24
  25 type dir = DIR_LEFT | DIR_RIGHT
  26
  27 let _nop = NOP ()
  28 let _first_child s = FIRST_CHILD s
  29 let _next_sibling s = NEXT_SIBLING s
  30 let _first_element s = FIRST_ELEMENT s
  31 let _next_element s = NEXT_ELEMENT s
  32 let _tagged_descendant s t = TAGGED_DESCENDANT(s,t)
  33 let _tagged_following s t = TAGGED_FOLLOWING(s,t)
  34 let _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.tag_list_of_set t)
  35 let _select_following s t = SELECT_FOLLOWING(s,t, Tree.tag_list_of_set t)
  36 let _tagged_child s t = TAGGED_CHILD(s,t)
  37 let _tagged_following_sibling s t = TAGGED_SIBLING(s,t)
  38 let _select_child s t = SELECT_CHILD(s,t, Tree.tag_list_of_set t)
  39 let _select_following_sibling s t = SELECT_SIBLING(s,t, Tree.tag_list_of_set t)
  40 let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
  41 let _element_subtree s = ELEMENT_SUBTREE s
  42
  43
  44 let jump_stat_table = Hashtbl.create 17
  45 let jump_stat_init () = Hashtbl.clear jump_stat_table
  46 let jump_stat j =
  47   let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in
  48   Hashtbl.replace jump_stat_table j (i+1)
  49
  50 let print_jump fmt j =
  51   match j with
  52   | NOP _ -> fprintf fmt "nop"
  53   | FIRST_CHILD _ -> fprintf fmt "first_child"
  54   | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
  55   | FIRST_ELEMENT _ -> fprintf fmt "first_element"
  56   | NEXT_ELEMENT _ -> fprintf fmt "next_element"
  57
  58   | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag)
  59
  60   | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag)
  61
  62   | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)"
  63     TagSet.print (TagSet.inj_positive tags)
  64
  65   | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)"
  66     TagSet.print (TagSet.inj_positive tags)
  67
  68   | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
  69
  70   | TAGGED_SIBLING (_, tag) ->
  71     fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
  72
  73   | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
  74     TagSet.print (TagSet.inj_positive tags)
  75
  76   | SELECT_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
  77     TagSet.print (TagSet.inj_positive tags)
  78
  79   | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
  80   | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree"
  81
  82 let jump_stat_summary fmt =
  83   fprintf fmt "Jump function summary:\n%!";
  84   Hashtbl.iter (fun k v -> fprintf fmt "%i calls to %a\n" v print_jump k) jump_stat_table;
  85   fprintf fmt "%!"
  86
  87
  88 type opcode =
  89   | RETURN of unit
  90   | LEFT of Translist.t * jump
  91   | RIGHT of Translist.t * jump
  92   | BOTH of Translist.t * jump * jump
  93   | CACHE of unit
  94
  95 type t = opcode Cache.Lvl2.t
  96
  97 let dummy = CACHE ()
  98 let return = RETURN ()
  99 let print_opcode fmt o = match o with
 100   | CACHE _ -> fprintf fmt "CACHE"
 101   | RETURN _ -> fprintf fmt "RETURN"
 102   | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
 103   | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
 104   | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
 105 (*
 106   let print_cache fmt d =
 107   let c = Cache.Lvl2.to_array d in
 108   Array.iteri begin fun tag a ->
 109   let tagstr = Tag.to_string tag in
 110   if a != Cache.Lvl2.dummy_line d && tagstr <> "<INVALID TAG>"
 111   then begin
 112   fprintf fmt "Entry %s: \n" tagstr;
 113   Array.iter (fun o -> if o != dummy then begin
 114   print_opcode fmt o;
 115   fprintf fmt "\n%!" end) a;
 116   fprintf fmt "---------------------------\n%!"
 117   end
 118   end c
 119 *)
 120 let create () = Cache.Lvl2.create 512 dummy
 121 (*
 122   let stats fmt c =
 123   let d = Cache.Lvl2.to_array c in
 124   let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in
 125   let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
 126   let lvl2 = Array.fold_left (fun acc a ->
 127   Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1)
 128   acc a) 0 d
 129   in
 130   fprintf fmt "L2JIT Statistics:
 131   \t%i entries
 132   \t%i used L1 lines
 133   \t%i used L2 lines
 134   \ttable size: %ikb\n"
 135   len lvl1 lvl2 (Ocaml.size_kb d);
 136   fprintf fmt "%s" "L2JIT Content:\n";
 137   print_cache fmt c
 138 *)
 139
 140 let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
 141
 142 let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v
 143
 144
 145 let has_text l = Ptset.Int.mem Tag.pcdata l
 146
 147 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
 148   let child, desc, sib, fol = Tree.tags tree tag in
 149   let not_elements =
 150     Ptset.Int.add Tag.pcdata
 151       (Ptset.Int.add Tag.attribute
 152          (Ptset.Int.add Tag.attribute_data
 153             (Tree.attribute_tags tree)))
 154   in
 155   match jkind, dir with
 156   | NIL, _ -> _nop
 157   | NODE, DIR_LEFT -> FIRST_CHILD s
 158   | STAR, DIR_LEFT -> FIRST_ELEMENT s
 159   | NODE, DIR_RIGHT -> NEXT_SIBLING s
 160   | STAR, DIR_RIGHT -> NEXT_ELEMENT s
 161   | JUMP_ONE t, _ ->
 162     let l_one, l_many, tagged_one, select_one, any, any_notext =
 163       if dir = DIR_LEFT then
 164         child, desc, _tagged_child, _select_child,_first_child, _first_element
 165       else
 166         sib, fol, _tagged_following_sibling, _select_following_sibling,
 167         _next_sibling, _next_element
 168     in
 169     let labels = Ptset.Int.inter l_one t in
 170     let c = Ptset.Int.cardinal labels in
 171     if c == 0 then _nop
 172     else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
 173       translate_jump tree tag (JUMP_MANY(labels)) dir s
 174     else if c == 1 then tagged_one s (Ptset.Int.choose labels)
 175     else if c > 5 then if has_text labels then any s else any_notext s
 176     else select_one s labels
 177
 178   | JUMP_MANY t, _ ->
 179     let l_many, tagged_many, select_many, any, any_notext =
 180       if dir == DIR_LEFT then
 181         desc, _tagged_descendant, _select_descendant,_first_child, _first_element
 182       else
 183         fol, _tagged_following, _select_following, _next_sibling, _next_element
 184     in
 185     let labels = Ptset.Int.inter l_many t in
 186     let c = Ptset.Int.cardinal labels in
 187     if c == 0 then _nop
 188     else
 189       let not_t = Ptset.Int.diff l_many labels in
 190       let () =
 191         LOG(__ "level2-jit" 3 "Would jump for tag %s to labels %a, not relevant tags: %a"
 192               (Tag.to_string tag)
 193               TagSet.print (TagSet.inj_positive labels)
 194               TagSet.print (TagSet.inj_positive not_t))
 195       in
 196       if Ptset.Int.subset not_t not_elements then
 197         if has_text labels then any s else any_notext s
 198       else if c == 1 then tagged_many s (Ptset.Int.choose labels)
 199       else
 200         if c >= 5 then
 201           if has_text labels then any s else any_notext s
 202         else select_many s labels
 203
 204   | CAPTURE_MANY (t), DIR_LEFT ->
 205     if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t)
 206     else if t == Tree.element_tags tree then ELEMENT_SUBTREE s
 207     else assert false
 208   | _ -> assert false
 209
 210 let count = ref 0
 211 let () = at_exit (fun () -> Logger.verbose Format.err_formatter "Compute jump called %i times\n" !count)
 212 module Memo = Hashtbl.Make(struct
 213   type t = Tag.t * StateSet.t * dir
 214   let equal (a,b,c) (d,e,f) = a == d && b == e && c == f
 215   let hash (a, b, c) = HASHINT3(a, Uid.to_int b.StateSet.Node.id, (Obj.magic c))
 216 end)
 217
 218 let memo = Memo.create 1024
 219 let init () = Memo.clear memo
 220
 221 let compute_jump auto tree tag states dir =
 222   if !Config.no_jump then
 223     if dir == DIR_LEFT then FIRST_CHILD states
 224     else NEXT_SIBLING states
 225   else
 226     try
 227       Memo.find memo (tag, states, dir)
 228     with
 229       Not_found -> begin
 230         incr count;
 231         let jkind = Ata.top_down_approx auto states tree in
 232         let jump = translate_jump tree tag jkind dir states in
 233         LOG(__ "level2-jit" 2
 234               "Computed jumps for %s %a %s, from %a : %a%!"
 235               (Tag.to_string tag)
 236               StateSet.print states
 237               (if dir == DIR_LEFT then "left" else "right")
 238               Ata.print_kind jkind
 239               print_jump jump
 240         );
 241         Memo.add memo (tag, states, dir) jump; jump
 242       end
 243
 244 let compile cache2 auto tree tag states =
 245   let tr_list, states1, states2 =
 246     Ata.get_trans (*~attributes:(TagSet.inj_positive (Tree.attribute_tags tree))*) auto states tag
 247   in
 248   let op =
 249     let empty_s1 = StateSet.is_empty states1 in
 250     let empty_s2 = StateSet.is_empty states2 in
 251     if empty_s1 && empty_s2 then return
 252     else if empty_s1 then
 253       RIGHT (tr_list,
 254              compute_jump auto tree tag states2 DIR_RIGHT)
 255     else if empty_s2 then
 256       LEFT (tr_list,
 257             compute_jump auto tree tag states1 DIR_LEFT)
 258     else
 259       let j1 = compute_jump auto tree tag states1 DIR_LEFT in
 260       let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
 261       BOTH (tr_list, j1, j2);
 262   in
 263   let op = match op with
 264     (*BOTH(_, NOP _, NOP _) |  LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
 265     | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l)
 266     | BOTH(tr, l, NOP _) -> LEFT (tr, l)
 267     | BOTH(tr, NOP _, r) -> RIGHT (tr, r)
 268     | _ -> op
 269   in
 270   if not !Config.no_cache then add cache2 tag states op;
 271   op
 272
 273 let get_transitions = function
 274   | CACHE _ | RETURN _ -> failwith "get_transitions"
 275   | LEFT (tr, _)
 276   | RIGHT (tr, _)
 277   | BOTH (tr, _, _) -> tr
 278