--- /dev/null
+INCLUDE "debug.ml"
+INCLUDE "utils.ml"
+open Format
+
+type instr =
+ | SELF of unit
+ | LEFT of State.t
+ | RIGHT of State.t
+
+type opcode =
+ | OP_NOP of unit
+ | OP_LEFT1 of State.t
+ | OP_LEFT2 of State.t * State.t
+ | OP_RIGHT1 of State.t
+ | OP_RIGHT2 of State.t * State.t
+ | OP_LEFT1_RIGHT1 of State.t * State.t
+ | OP_LEFT2_RIGHT1 of State.t * State.t * State.t
+ | OP_LEFT1_RIGHT2 of State.t * State.t * State.t
+ | OP_LEFT2_RIGHT2 of State.t * State.t * State.t * State.t
+ | OP_SELF of unit
+ | OP_SELF_LEFT1 of State.t
+ | OP_SELF_LEFT2 of State.t * State.t
+ | OP_SELF_RIGHT1 of State.t
+ | OP_SELF_RIGHT2 of State.t * State.t
+ | OP_SELF_LEFT1_RIGHT1 of State.t * State.t
+ | OP_SELF_LEFT2_RIGHT1 of State.t * State.t * State.t
+ | OP_SELF_LEFT1_RIGHT2 of State.t * State.t * State.t
+ | OP_SELF_LEFT2_RIGHT2 of State.t * State.t * State.t * State.t
+ | OP_OTHER of instr array
+
+type code = Nil | Cons of State.t * opcode * code
+
+let rec length l =
+ match l with
+ Nil -> 0
+ | Cons(_, _, t) -> 1 + length t
+let debug fmt l =
+ fprintf fmt "length of code is %i\n%!" (length l)
+
+
+let print_instr fmt i =
+ match i with
+ | SELF _ -> fprintf fmt "SELF"
+ | LEFT q -> fprintf fmt "LEFT{%a}" State.print q
+ | RIGHT q -> fprintf fmt "RIGHT{%a}" State.print q
+
+let print_opcode fmt code =
+ match code with
+ | OP_NOP _ -> fprintf fmt "OP_NOP"
+
+ | OP_LEFT1 src ->
+ fprintf fmt "OP_LEFT1{%a}" State.print src
+
+ | OP_LEFT2 (src1, src2) ->
+ fprintf fmt "OP_LEFT2{%a, %a}" State.print src1 State.print src2
+
+ | OP_RIGHT1 src ->
+ fprintf fmt "OP_RIGHT1{%a}" State.print src
+
+ | OP_RIGHT2 (src1, src2) ->
+ fprintf fmt "OP_RIGHT2{%a, %a}" State.print src1 State.print src2
+
+ | OP_LEFT1_RIGHT1 (src1, src2) ->
+ fprintf fmt "OP_LEFT1_RIGHT1{%a}{%a}" State.print src1 State.print src2
+
+ | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
+ fprintf fmt "OP_LEFT2_RIGHT1{%a, %a}{%a}"
+ State.print src1 State.print src2 State.print src3
+
+ | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
+ fprintf fmt "OP_LEFT1_RIGHT2{%a}{%a, %a}"
+ State.print src1 State.print src2 State.print src3
+
+ | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
+ fprintf fmt "OP_LEFT2_RIGHT2{%a, %a}{%a, %a}"
+ State.print src1 State.print src2 State.print src3 State.print src4
+
+ | OP_SELF _ ->
+ fprintf fmt "OP_SELF"
+
+ | OP_SELF_LEFT1 src ->
+ fprintf fmt "OP_SELF_LEFT1{%a}" State.print src
+
+ | OP_SELF_LEFT2 (src1, src2) ->
+ fprintf fmt "OP_SELF_LEFT2{%a, %a}" State.print src1 State.print src2
+
+ | OP_SELF_RIGHT1 src ->
+ fprintf fmt "OP_SELF_RIGHT1{%a}" State.print src
+
+ | OP_SELF_RIGHT2 (src1, src2) ->
+ fprintf fmt "OP_SELF_RIGHT2{%a, %a}" State.print src1 State.print src2
+
+ | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
+ fprintf fmt "OP_SELF_LEFT1_RIGHT1{%a}{%a}" State.print src1 State.print src2
+
+ | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
+ fprintf fmt "OP_SELF_LEFT2_RIGHT1{%a, %a}{%a}"
+ State.print src1 State.print src2 State.print src3
+
+ | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
+ fprintf fmt "OP_SELF_LEFT1_RIGHT2{%a}{%a, %a}"
+ State.print src1 State.print src2 State.print src3
+
+ | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
+ fprintf fmt "OP_SELF_LEFT2_RIGHT2{%a, %a}{%a, %a}"
+ State.print src1 State.print src2 State.print src3 State.print src4
+ | OP_OTHER line ->
+ fprintf fmt "OP_OTHER: ";
+ Array.iter (fun i -> print_instr fmt i; fprintf fmt " ") line
+
+let merge_rev equal choose l =
+ match l with
+ | [] -> l
+ | x :: ll ->
+ List.fold_left
+ (fun acc i ->
+ let j = List.hd acc in
+ if equal i j then (choose i j)::(List.tl acc)
+ else i::acc) [x] ll
+
+let compile_instr_list l =
+ let linstr = merge_rev (=) (fun i _ -> i) (List.sort (fun x y -> compare y x) l) in
+ match linstr with
+ [] -> OP_NOP()
+ | [ LEFT q ] -> OP_LEFT1 q
+ | [ LEFT q1; LEFT q2 ] -> OP_LEFT2(q2, q1)
+ | [ RIGHT q ] -> OP_RIGHT1 q
+ | [ RIGHT q1; RIGHT q2 ] -> OP_RIGHT2(q2, q1)
+ | [ LEFT q1; RIGHT q2 ] -> OP_LEFT1_RIGHT1(q1, q2)
+ | [ LEFT q1; LEFT q2; RIGHT q3 ] -> OP_LEFT2_RIGHT1 (q2, q1, q3)
+ | [ LEFT q1; RIGHT q2; RIGHT q3 ] -> OP_LEFT1_RIGHT2 (q1, q3, q2)
+ | [ LEFT q1; LEFT q2; RIGHT q3; RIGHT q4 ] -> OP_LEFT2_RIGHT2 (q2, q1, q4, q3)
+ | [ SELF () ] -> OP_SELF()
+
+ | [ SELF _; LEFT q ] -> OP_SELF_LEFT1 q
+ | [ SELF _; LEFT q1; LEFT q2 ] -> OP_SELF_LEFT2(q2, q1)
+ | [ SELF _; RIGHT q ] -> OP_SELF_RIGHT1 q
+ | [ SELF _; RIGHT q1; RIGHT q2 ] -> OP_SELF_RIGHT2(q2, q1)
+ | [ SELF _; LEFT q1; RIGHT q2 ] -> OP_SELF_LEFT1_RIGHT1(q1, q2)
+ | [ SELF _; LEFT q1; LEFT q2; RIGHT q3 ] -> OP_SELF_LEFT2_RIGHT1 (q2, q1, q3)
+ | [ SELF _; LEFT q1; RIGHT q2; RIGHT q3 ] -> OP_SELF_LEFT1_RIGHT2 (q1, q3, q2)
+ | [ SELF _; LEFT q1; LEFT q2; RIGHT q3; RIGHT q4 ] ->
+ OP_SELF_LEFT2_RIGHT2 (q2, q1, q4, q3)
+ | i -> OP_OTHER (Array.of_list i)
+
+
+let to_list l =
+ let rec loop l acc =
+ match l with
+ [] -> acc
+ | (a, b)::ll -> loop ll (Cons(a,b, acc))
+ in loop l Nil
+
+
+let rec filter_uniq statel stater l =
+ match l with
+ [] -> []
+ | (s, il)::ll ->
+ let nil, nsl, nsr =
+ List.fold_left
+ (fun ((a_il, al, ar)as acc) i ->
+ match i with
+ | LEFT q ->
+ if List.mem q al then acc
+ else (i :: a_il, q::al, ar)
+ | RIGHT q ->
+ if List.mem q ar then acc
+ else (i :: a_il, al, q :: ar)
+ | _ -> (i :: a_il, al, ar)) ([], statel, stater) il
+ in
+ (s, nil) :: (filter_uniq nsl nsr ll)
+
+let compile l =
+ let l = List.sort (fun (s1, _) (s2, _) -> compare s1 s2) l in
+ let l = filter_uniq [] [] l in
+ let l = merge_rev
+ (fun (s1, _) (s2, _) -> s1 = s2)
+ (fun (s1, i1) (_, i2) -> (s1, i1@i2)) l
+ in
+ let marking =
+ List.exists
+ (fun (_, l) -> List.exists (function SELF _ -> true | _ -> false) l)
+ l
+ in
+ let l = List.map (fun (s, il) -> (s, compile_instr_list il)) l in
+ let l = List.filter (fun (_, instr) -> instr <> OP_NOP ()) l in
+ to_list l, not marking
+
+(*
+let _total = ref 0
+let _empty = ref 0
+let () = at_exit (fun () -> Printf.eprintf "Dummy affectations %i/%i\n%!" !_empty !_total)
+;;
+*)
+
+DEFINE SET(a, b) = a <- b
+
+DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
+ match inst with
+ | SELF _ -> ns.snoc acc t
+ | LEFT src -> ns.concat acc slot1.(src)
+ | RIGHT src -> ns.concat acc slot2.(src)
+
+
+DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
+ match code with
+ | OP_NOP _ -> ()
+
+ | OP_LEFT1 src ->
+ if slot != slot1 then SET(slot.(dst), slot1.(src))
+
+ | OP_LEFT2 (src1, src2) ->
+ SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
+
+ | OP_RIGHT1 src -> if slot != slot2 then SET(slot.(dst) , slot2.(src))
+
+ | OP_RIGHT2 (src1, src2) ->
+ SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
+
+ | OP_LEFT1_RIGHT1 (src1, src2) ->
+ SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
+
+ | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
+ SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
+
+ | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
+ SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3))
+
+ | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
+ SET (slot.(dst) , ns.concat4 slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4))
+
+ | OP_SELF _ ->
+ slot.(dst) <- ns.singleton t
+
+ | OP_SELF_LEFT1 src -> slot.(dst) <- ns.cons t slot1.(src)
+
+ | OP_SELF_LEFT2 (src1, src2) ->
+ slot.(dst) <- ns.conscat t slot1.(src1) slot1.(src2)
+
+ | OP_SELF_RIGHT1 src -> slot.(dst) <- ns.cons t slot2.(src)
+
+ | OP_SELF_RIGHT2 (src1, src2) ->
+ slot.(dst) <- ns.conscat t slot2.(src1) slot2.(src2)
+
+ | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
+ slot.(dst) <- ns.conscat t slot1.(src1) slot2.(src2)
+
+ | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
+ slot.(dst) <- ns.conscat3 t slot1.(src1) slot1.(src2) slot2.(src3)
+
+ | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
+ slot.(dst) <- ns.conscat3 t slot1.(src1) slot2.(src2) slot2.(src3)
+
+ | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
+ slot.(dst) <-
+ ns.conscat4 t slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4)
+ | OP_OTHER line ->
+ let acc = ref ns.empty in
+ let len = Array.length line - 1 in
+ for j = 0 to len do
+ acc := exec_instr slot1 slot2 t line.(j) !acc
+ done;
+ slot.(dst) <- !acc
+
+
+module type S =
+ sig
+ module NS : NodeSet.S
+ type t = NS.t array
+ val exec : t -> t -> t -> Tree.node -> code -> unit
+ end
+
+
+
+module Count =
+ struct
+ module NS = NodeSet.Count
+ type t = NodeSet.Count.t array
+
+ let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
+ let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
+ (* inline by hand for efficiency reason *)
+ let rec exec slot slot1 slot2 t code =
+ match code with
+ | Nil -> ()
+ | Cons(dst, code, code1) ->
+ exec_code slot slot1 slot2 t dst code;
+ begin
+ match code1 with
+ | Nil -> ()
+ | Cons(dst, code, code1) ->
+ exec_code slot slot1 slot2 t dst code;
+ exec slot slot1 slot2 t code1
+ end
+ end
+
+module Mat =
+ struct
+ module NS = NodeSet.Mat
+ type t = NodeSet.Mat.t array
+
+ let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
+ let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
+ (* inline by hand for efficiency reason *)
+ let rec exec slot slot1 slot2 t code =
+ match code with
+ | Nil -> ()
+ | Cons(dst, code, code1) ->
+ exec_code slot slot1 slot2 t dst code;
+ begin
+ match code1 with
+ | Nil -> ()
+ | Cons(dst, code, code1) ->
+ exec_code slot slot1 slot2 t dst code;
+ exec slot slot1 slot2 t code1
+ end
+ end
+
+
+
projects / SXSI / xpathcomp.git / blobdiff