(mk_fun (Tree.next_sibling_below tree) "Tree.node_sibling_ctx")
-
- module TransCache =
- struct
- external get : 'a array -> int ->'a = "%array_unsafe_get"
- external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
- type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> Tag.t -> SList.t -> bool -> SList.t*RS.t array
+
+
+ module CodeCache =
+ struct
+ let get = Array.unsafe_get
+ let set = Array.set
+
+ type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> SList.t -> Tag.t -> bool -> SList.t*RS.t array
type t = fun_tree array array
- let dummy_cell = [||]
- let create n = Array.create n dummy_cell
- let dummy = fun _ _ _ _ _ -> assert false
- let default = ref dummy
- let find h tag slist =
- let tab = get h (Uid.to_int slist.SList.Node.id) in
- if tab == dummy_cell then !default
- else
- get tab tag
- let add (h : t) tag slist (data : fun_tree) =
+ let dummy = fun _ _ _ _ _ -> failwith "Uninitializd CodeCache"
+ let default_line = Array.create 256 dummy (* 256 = max_tag *)
+ let create n = Array.create n default_line
+ let init f =
+ for i = 0 to (Array.length default_line) - 1
+ do
+ default_line.(i) <- f
+ done
+
+ let get_fun h slist tag =
+ get (get h (Uid.to_int slist.SList.Node.id)) tag
+
+ let set_fun (h : t) slist tag (data : fun_tree) =
let tab = get h (Uid.to_int slist.SList.Node.id) in
- let tab = if tab == dummy_cell then
- let x = Array.create 10000 !default in
+ let line = if tab == default_line then
+ let x = Array.copy tab in
(set h (Uid.to_int slist.SList.Node.id) x;x)
else tab
in
- set tab tag data
- let dump t = Array.iteri (fun id t' ->
- if t' != dummy_cell then
- begin
- let sl = SList.with_id (Uid.of_int id) in
- SList.print Format.err_formatter sl;
- Format.fprintf Format.err_formatter " -> [ ";
- Array.iteri
- (fun i x -> if x != !default then
- Format.fprintf Format.err_formatter "(%s,0x%x) "
- (Tag.to_string i) (Obj.magic x)) t';
- Format.fprintf Format.err_formatter " ]\n%!"
-
- end) t
+ set line tag data
+
end
-
-
- let td_trans = TransCache.create 10000 (* should be number of tags *number of states^2
+
+ let td_trans = CodeCache.create 10000 (* should be number of tags *number of states^2
in the document *)
let empty_size n =
module Fold2Res = struct
- external get : 'a array -> int ->'a = "%array_unsafe_get"
- external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
- external field1 : 'a -> 'b = "%field1"
- type 'a t = 'a array array array array
- let dummy = [||]
- let dummy_val : 'a =
- let v = Obj.repr ((),2,()) in
- Obj.magic v
-
-
- let create n = Array.create n dummy
- let find h tag fl s1 s2 =
- let af = get h tag in
- if af == dummy then raise Not_found
- else
- let as1 = get af (Uid.to_int fl.Formlistlist.Node.id) in
- if as1 == dummy then raise Not_found
- else
- let as2 = get as1 (Uid.to_int s1.SList.Node.id) in
- if as2 == dummy then raise Not_found
- else
- let v = get as2 (Uid.to_int s2.SList.Node.id) in
- if field1 v == 2 then raise Not_found
- else
- v
+ let get = Array.unsafe_get
+ let set = Array.set
+ external field1 : Obj.t -> int = "%field1"
+ type t = Obj.t array array array array
+ let dummy_val = Obj.repr ((),2,())
+ let default_line3 = Array.create 10000 dummy_val
+ let default_line2 = Array.create 10000 default_line3
+ let default_line1 = Array.create 10000 default_line2
+
+ let create n = Array.create n default_line1
- let add h tag fl s1 s2 data =
- let af =
- let x = get h tag in
- if x == dummy then
- begin
- let y = Array.make 10000 dummy in
- set h tag y;y
- end
- else x
- in
- let as1 =
- let x = get af (Uid.to_int fl.Formlistlist.Node.id) in
- if x == dummy then
- begin
- let y = Array.make 10000 dummy in
- set af (Uid.to_int fl.Formlistlist.Node.id) y;y
- end
- else x
- in
- let as2 =
- let x = get as1 (Uid.to_int s1.SList.Node.id) in
- if x == dummy then
- begin
- let y = Array.make 10000 dummy_val in
- set as1 (Uid.to_int s1.SList.Node.id) y;y
- end
- else x
- in
- set as2 (Uid.to_int s2.SList.Node.id) data
+ let find h tag fl s1 s2 : SList.t*bool*(merge_conf array) =
+ let l1 = get h tag in
+ let l2 = get l1 (Uid.to_int fl.Formlistlist.Node.id) in
+ let l3 = get l2 (Uid.to_int s1.SList.Node.id) in
+ Obj.magic (get l3 (Uid.to_int s2.SList.Node.id))
+
+ let is_valid b = (Obj.magic b) != 2
+ let get_replace tab idx default =
+ let e = get tab idx in
+ if e == default then
+ let ne = Array.copy e in (set tab idx ne;ne)
+ else e
+
+ let add h tag fl s1 s2 (data: SList.t*bool*(merge_conf array)) =
+ let l1 = get_replace h tag default_line1 in
+ let l2 = get_replace l1 (Uid.to_int fl.Formlistlist.Node.id) default_line2 in
+ let l3 = get_replace l2 (Uid.to_int s1.SList.Node.id) default_line3 in
+ set l3 (Uid.to_int s2.SList.Node.id) (Obj.repr data)
end
-
-
- let h_fold2 = Fold2Res.create 10000
+
+ let h_fold2 = Fold2Res.create 256
let top_down ?(noright=false) a tree t slist ctx slot_size =
let pempty = empty_size slot_size in
(* evaluation starts from the right so we put sl1,res1 at the end *)
let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) =
let res = Array.copy rempty in
- try
- let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in
- if b then for i=0 to slot_size - 1 do
- res.(0) <- RS.merge btab.(0) t res1.(0) res2.(0);
- done;
- r,res
- with
- Not_found ->
- begin
- let btab = Array.make slot_size NO in
- let rec fold l1 l2 fll i aq ab =
- match fll.Formlistlist.Node.node,
- l1.SList.Node.node,
- l2.SList.Node.node
- with
- | Formlistlist.Cons(fl,fll),
- SList.Cons(s1,ll1),
- SList.Cons(s2,ll2) ->
- let r',conf = eval_formlist tag s1 s2 fl in
- let _ = btab.(i) <- conf
- in
- fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab)
- | _ -> aq,ab
- in
- let r,b = fold sl1 sl2 fll 0 SList.nil false in
- Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab);
- if b then for i=0 to slot_size - 1 do
- res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
- done;
- r,res;
- end
+ let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in
+ if Fold2Res.is_valid b then
+ begin
+ if b then for i=0 to slot_size - 1 do
+ res.(0) <- RS.merge btab.(0) t res1.(0) res2.(0);
+ done;
+ r,res
+ end
+ else
+ begin
+ let btab = Array.make slot_size NO in
+ let rec fold l1 l2 fll i aq ab =
+ match fll.Formlistlist.Node.node,
+ l1.SList.Node.node,
+ l2.SList.Node.node
+ with
+ | Formlistlist.Cons(fl,fll),
+ SList.Cons(s1,ll1),
+ SList.Cons(s2,ll2) ->
+ let r',conf = eval_formlist tag s1 s2 fl in
+ let _ = btab.(i) <- conf
+ in
+ fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab)
+ | _ -> aq,ab
+ in
+ let r,b = fold sl1 sl2 fll 0 SList.nil false in
+ Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab);
+ if b then for i=0 to slot_size - 1 do
+ res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
+ done;
+ r,res;
+ end
in
let null_result = (pempty,Array.copy rempty) in
- let rec loop t ctx _ slist =
- if t == Tree.nil then null_result else
- let tag = Tree.tag tree t in (TransCache.find td_trans tag slist) t ctx tag slist false
-
- and loop_tag t ctx tag slist =
- if t == Tree.nil then null_result else (TransCache.find td_trans tag slist) t ctx tag slist false
+ let empty_res = null_result in
- and loop_no_right t ctx _ slist =
+ let rec loop t ctx slist _ =
+ if t == Tree.nil then null_result else
+ let tag = Tree.tag tree t in
+ (CodeCache.get_fun td_trans slist tag) t ctx slist tag false
+ (* get_trans t ctx slist tag false
+ (CodeCache.get_opcode td_trans slist tag)
+ *)
+ and loop_tag t ctx slist tag =
if t == Tree.nil then null_result else
- let tag = Tree.tag tree t in (TransCache.find td_trans tag slist) t ctx tag slist true
-
- and mk_trans t ctx tag slist noright =
+ (CodeCache.get_fun td_trans slist tag) t ctx slist tag false
+ (* get_trans t ctx slist tag false
+ (CodeCache.get_opcode td_trans slist tag) *)
+
+ and loop_no_right t ctx slist _ =
+ if t == Tree.nil then null_result else
+ let tag = Tree.tag tree t in
+ (CodeCache.get_fun td_trans slist tag) t ctx slist tag true
+ (* get_trans t ctx slist tag true
+ (CodeCache.get_opcode td_trans slist tag) *)
+ (*
+ and get_trans t ctx slist tag noright opcode =
+ match opcode with
+ | OpCode.K0 fll ->
+ eval_fold2_slist fll t tag empty_res empty_res
+
+ | OpCode.K1 (fll,first,llist,tag1) ->
+ eval_fold2_slist fll t tag empty_res
+ (loop_tag (first t) t llist tag1)
+
+ | OpCode.K2 (fll,first,llist) ->
+ eval_fold2_slist fll t tag empty_res
+ (loop (first t) t llist)
+
+ | OpCode.K3 (fll,next,rlist,tag2) ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ empty_res
+ | OpCode.K4 (fll,next,rlist) ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist)
+ empty_res
+
+ | OpCode.K5 (fll,next,rlist,tag2,first,llist,tag1) ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ (loop_tag (first t) t llist tag1)
+
+ | OpCode.K6 (fll,next,rlist,first,llist,tag1) ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist)
+ (loop_tag (first t) t llist tag1)
+
+ | OpCode.K7 (fll,next,rlist,tag2,first,llist) ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ (loop (first t) t llist)
+
+ | OpCode.K8 (fll,next,rlist,first,llist) ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist)
+ (loop (first t) t llist)
+
+ | OpCode.KDefault _ ->
+ mk_trans t ctx tag slist noright
+ *)
+ and mk_trans t ctx slist tag noright =
let fl_list,llist,rlist,ca,da,sa,fa =
SList.fold
(fun set (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil )
else choose_jump_next tree d_n in
let empty_res = null_result in
+ let fll = fl_list in
let cont =
match f_kind,n_kind with
- | `NIL,`NIL ->
- (fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res empty_res)
+ | `NIL,`NIL -> (*OpCode.K0(fl_list) *)
+ fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res empty_res
+
| _,`NIL -> (
match f_kind with
- |`TAG(tag') ->
- fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res
- (loop_tag (first t) t tag' llist )
- | _ ->
- (fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res
- (loop (first t) t Tag.dummy llist ))
+ |`TAG(tag1) -> (*OpCode.K1(fl_list,first,llist,tag1) *)
+ fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res
+ (loop_tag (first t) t llist tag1)
+ | _ -> (* OpCode.K2(fl_list,first,llist) *)
+ fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res
+ (loop (first t) t llist tag)
)
| `NIL,_ -> (
match n_kind with
- |`TAG(tag') ->
- if SList.equal rlist slist && tag == tag' then
- let rec loop t ctx _ _ _ =
- if t == Tree.nil then empty_res else
- let res2 = loop (next t ctx) ctx Tag.dummy slist false in
- eval_fold2_slist fl_list t tag res2 empty_res
- in loop
- else
- (fun t ctx tag _ _ -> eval_fold2_slist fl_list t tag
- (loop_tag (next t ctx) ctx tag' rlist) empty_res)
-
- | _ ->
- (fun t ctx tag _ _ -> eval_fold2_slist fl_list t tag
- (loop (next t ctx) ctx Tag.dummy rlist ) empty_res)
+ |`TAG(tag2) -> (*OpCode.K3(fl_list,next,rlist,tag2) *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ empty_res
+
+ | _ -> (*OpCode.K4(fl_list,next,rlist) *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist tag)
+ empty_res
+
)
- | `TAG(tag1),`TAG(tag2) ->
- (fun t ctx tag _ _ ->
- eval_fold2_slist fl_list t tag
- (loop_tag (next t ctx) ctx tag2 rlist)
- (loop_tag (first t) t tag1 llist))
+ | `TAG(tag1),`TAG(tag2) -> (*OpCode.K5(fl_list,next,rlist,tag2,first,llist,tag1) *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ (loop_tag (first t) t llist tag1)
- | `TAG(tag'),`ANY ->
- (fun t ctx tag _ _ ->
- eval_fold2_slist fl_list t tag
- (loop (next t ctx) ctx Tag.dummy rlist)
- (loop_tag (first t) t tag' llist))
-
- | `ANY,`TAG(tag') ->
- (fun t ctx tag _ _ ->
- eval_fold2_slist fl_list t tag
- (loop_tag (next t ctx) ctx tag' rlist )
- (loop (first t) t Tag.dummy llist))
+ | `TAG(tag1),`ANY -> (* OpCode.K6(fl_list,next,rlist,first,llist,tag1) *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist tag)
+ (loop_tag (first t) t llist tag1)
+
+ | `ANY,`TAG(tag2) -> (* OpCode.K7(fl_list,next,rlist,tag2,first,llist) *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop_tag (next t ctx) ctx rlist tag2)
+ (loop (first t) t llist tag)
+
- | `ANY,`ANY ->
- (*if SList.equal slist rlist && SList.equal slist llist
- then
- let rec loop t ctx =
- if t == Tree.nil then empty_res else
- let r1 = loop (first t) t
- and r2 = loop (next t ctx) ctx
- in
- eval_fold2_slist fl_list t (Tree.tag tree t) r2 r1
- in loop
- else *)
- (fun t ctx tag _ _ ->
- eval_fold2_slist fl_list t tag
- (loop (next t ctx) ctx Tag.dummy rlist )
- (loop (first t) t Tag.dummy llist))
- | _,_ ->
- (fun t ctx tag _ _ ->
- eval_fold2_slist fl_list t tag
- (loop (next t ctx) ctx Tag.dummy rlist)
- (loop (first t) t Tag.dummy llist ))
-
- in
- (* let cont = D_IF_( (fun t ctx tag ->
- let a,b = cont t ctx tag in
- register_trace tree t (slist,a,fl_list,first,next,ctx);
- (a,b)
- ) ,cont)
- in *)
- (TransCache.add td_trans tag slist cont; cont t ctx tag slist noright)
+ | _,_ -> (*OpCode.K8(fl_list,next,rlist,first,llist) *)
+ (*if SList.equal slist rlist && SList.equal slist llist
+ then
+ let rec loop t ctx =
+ if t == Tree.nil then empty_res else
+ let r1 = loop (first t) t
+ and r2 = loop (next t ctx) ctx
+ in
+ eval_fold2_slist fl_list t (Tree.tag tree t) r2 r1
+ in loop
+ else *)
+ fun t ctx _ tag _ ->
+ eval_fold2_slist fll t tag
+ (loop (next t ctx) ctx rlist tag)
+ (loop (first t) t llist tag)
+
+
+
+ in
+ CodeCache.set_fun td_trans slist tag cont;
+ cont t ctx slist tag noright
in
- let _ = TransCache.default := mk_trans in
- (if noright then loop_no_right else loop) t ctx Tag.document_node slist
+ let _ = CodeCache.init mk_trans in
+ (if noright then loop_no_right else loop) t ctx slist Tag.dummy
let run_top_down a tree =
let init = SList.cons a.init SList.nil in
projects / SXSI / xpathcomp.git / commitdiff