src/resJIT.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3 INCLUDE "log.ml"
   4
   5 open Format
   6
   7 type instr =
   8   | SELF of unit
   9   | LEFT of State.t
  10   | RIGHT of State.t
  11
  12 type opcode =
  13   | OP_NOP of unit
  14   | OP_LEFT1 of State.t
  15   | OP_LEFT2 of State.t * State.t
  16   | OP_RIGHT1 of State.t
  17   | OP_RIGHT2 of State.t * State.t
  18   | OP_LEFT1_RIGHT1 of State.t * State.t
  19   | OP_LEFT2_RIGHT1 of State.t * State.t * State.t
  20   | OP_LEFT1_RIGHT2 of State.t * State.t * State.t
  21   | OP_LEFT2_RIGHT2 of State.t * State.t * State.t * State.t
  22   | OP_SELF of unit
  23   | OP_SELF_LEFT1 of State.t
  24   | OP_SELF_LEFT2 of State.t * State.t
  25   | OP_SELF_RIGHT1 of State.t
  26   | OP_SELF_RIGHT2 of State.t * State.t
  27   | OP_SELF_LEFT1_RIGHT1 of State.t * State.t
  28   | OP_SELF_LEFT2_RIGHT1 of State.t * State.t * State.t
  29   | OP_SELF_LEFT1_RIGHT2 of State.t * State.t * State.t
  30   | OP_SELF_LEFT2_RIGHT2 of State.t * State.t * State.t * State.t
  31   | OP_OTHER of instr array
  32
  33 type code = Nil | Cons of State.t * opcode * code
  34
  35 let rec length l =
  36   match l with
  37       Nil -> 0
  38     | Cons(_, _, t) -> 1 + length t
  39 let debug fmt l =
  40   fprintf fmt "length of code is %i\n%!" (length l)
  41
  42
  43 let print_instr fmt i =
  44   match i with
  45     | SELF _ -> fprintf fmt "SELF"
  46     | LEFT q -> fprintf fmt "LEFT{%a}" State.print q
  47     | RIGHT q -> fprintf fmt "RIGHT{%a}" State.print q
  48
  49 let print_opcode fmt code =
  50   match code with
  51     | OP_NOP _ -> fprintf fmt "OP_NOP"
  52
  53     | OP_LEFT1 src ->
  54         fprintf fmt "OP_LEFT1{%a}" State.print src
  55
  56     | OP_LEFT2 (src1, src2) ->
  57         fprintf fmt "OP_LEFT2{%a, %a}" State.print src1 State.print src2
  58
  59     | OP_RIGHT1 src ->
  60         fprintf fmt "OP_RIGHT1{%a}" State.print src
  61
  62     | OP_RIGHT2 (src1, src2) ->
  63         fprintf fmt "OP_RIGHT2{%a, %a}" State.print src1 State.print src2
  64
  65     | OP_LEFT1_RIGHT1 (src1, src2) ->
  66         fprintf fmt "OP_LEFT1_RIGHT1{%a}{%a}" State.print src1 State.print src2
  67
  68     | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
  69         fprintf fmt "OP_LEFT2_RIGHT1{%a, %a}{%a}"
  70           State.print src1 State.print src2 State.print src3
  71
  72     | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
  73         fprintf fmt "OP_LEFT1_RIGHT2{%a}{%a, %a}"
  74           State.print src1 State.print src2 State.print src3
  75
  76     | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
  77         fprintf fmt "OP_LEFT2_RIGHT2{%a, %a}{%a, %a}"
  78           State.print src1 State.print src2 State.print src3 State.print src4
  79
  80     | OP_SELF _ ->
  81         fprintf fmt "OP_SELF"
  82
  83     | OP_SELF_LEFT1 src ->
  84         fprintf fmt "OP_SELF_LEFT1{%a}" State.print src
  85
  86     | OP_SELF_LEFT2 (src1, src2) ->
  87         fprintf fmt "OP_SELF_LEFT2{%a, %a}" State.print src1 State.print src2
  88
  89     | OP_SELF_RIGHT1 src ->
  90         fprintf fmt "OP_SELF_RIGHT1{%a}" State.print src
  91
  92     | OP_SELF_RIGHT2 (src1, src2) ->
  93         fprintf fmt "OP_SELF_RIGHT2{%a, %a}" State.print src1 State.print src2
  94
  95     | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
  96         fprintf fmt "OP_SELF_LEFT1_RIGHT1{%a}{%a}" State.print src1 State.print src2
  97
  98     | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
  99         fprintf fmt "OP_SELF_LEFT2_RIGHT1{%a, %a}{%a}"
 100           State.print src1 State.print src2 State.print src3
 101
 102     | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
 103         fprintf fmt "OP_SELF_LEFT1_RIGHT2{%a}{%a, %a}"
 104           State.print src1 State.print src2 State.print src3
 105
 106     | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 107         fprintf fmt "OP_SELF_LEFT2_RIGHT2{%a, %a}{%a, %a}"
 108           State.print src1 State.print src2 State.print src3 State.print src4
 109     | OP_OTHER line ->
 110         fprintf fmt "OP_OTHER: ";
 111         Array.iter (fun i -> print_instr fmt i; fprintf fmt " ") line
 112
 113 let merge_rev equal choose l =
 114   match l with
 115     | [] -> l
 116     | x :: ll ->
 117         List.fold_left
 118           (fun acc i ->
 119              let j = List.hd acc in
 120                if equal i j then (choose i j)::(List.tl acc)
 121                else i::acc) [x] ll
 122
 123 let compile_instr_list l =
 124   let linstr = merge_rev (=) (fun i _ -> i) (List.sort (fun x y -> compare y x) l) in
 125     match linstr with
 126         [] -> OP_NOP()
 127       | [ LEFT q ] -> OP_LEFT1 q
 128       | [ LEFT q1; LEFT q2 ] -> OP_LEFT2(q2, q1)
 129       | [ RIGHT q ] -> OP_RIGHT1 q
 130       | [ RIGHT q1; RIGHT q2 ] -> OP_RIGHT2(q2, q1)
 131       | [ LEFT q1; RIGHT q2 ] -> OP_LEFT1_RIGHT1(q1, q2)
 132       | [ LEFT q1; LEFT q2; RIGHT q3 ] -> OP_LEFT2_RIGHT1 (q2, q1, q3)
 133       | [ LEFT q1; RIGHT q2; RIGHT q3 ] -> OP_LEFT1_RIGHT2 (q1, q3, q2)
 134       | [ LEFT q1; LEFT q2; RIGHT q3; RIGHT q4 ] -> OP_LEFT2_RIGHT2 (q2, q1, q4, q3)
 135       | [ SELF () ] -> OP_SELF()
 136
 137       | [ SELF _; LEFT q ] -> OP_SELF_LEFT1 q
 138       | [ SELF _; LEFT q1; LEFT q2 ] -> OP_SELF_LEFT2(q2, q1)
 139       | [ SELF _; RIGHT q ] -> OP_SELF_RIGHT1 q
 140       | [ SELF _; RIGHT q1; RIGHT q2 ] -> OP_SELF_RIGHT2(q2, q1)
 141       | [ SELF _; LEFT q1; RIGHT q2 ] -> OP_SELF_LEFT1_RIGHT1(q1, q2)
 142       | [ SELF _; LEFT q1; LEFT q2; RIGHT q3 ] -> OP_SELF_LEFT2_RIGHT1 (q2, q1, q3)
 143       | [ SELF _; LEFT q1; RIGHT q2; RIGHT q3 ] -> OP_SELF_LEFT1_RIGHT2 (q1, q3, q2)
 144       | [ SELF _; LEFT q1; LEFT q2; RIGHT q3; RIGHT q4 ] ->
 145           OP_SELF_LEFT2_RIGHT2 (q2, q1, q4, q3)
 146       | i -> OP_OTHER (Array.of_list i)
 147
 148
 149 let to_list l =
 150   let rec loop l acc =
 151     match l with
 152         [] -> acc
 153       | (a, b)::ll -> loop ll (Cons(a,b, acc))
 154   in loop l Nil
 155
 156
 157 let rec filter_uniq statel stater l =
 158   match l with
 159       [] -> []
 160     | (s, il)::ll ->
 161         let nil, nsl, nsr =
 162           List.fold_left
 163             (fun ((a_il, al, ar)as acc) i ->
 164                match i with
 165                  | LEFT q ->
 166                      if List.mem q al then acc
 167                      else (i :: a_il, q::al, ar)
 168                  | RIGHT q ->
 169                      if List.mem q ar then acc
 170                      else (i :: a_il, al, q :: ar)
 171                  | _ -> (i :: a_il, al, ar)) ([], statel, stater) il
 172         in
 173           (s, nil) :: (filter_uniq nsl nsr ll)
 174
 175 let compile l =
 176   let l = List.sort (fun (s1, _) (s2, _) -> compare s1 s2) l in
 177   let l = filter_uniq [] [] l in
 178   let l = merge_rev
 179     (fun (s1, _) (s2, _) -> s1 = s2)
 180     (fun (s1, i1) (_, i2) -> (s1, i1@i2)) l
 181   in
 182  let marking =
 183     List.exists
 184       (fun (_, l) -> List.exists (function SELF _ -> true | _ -> false) l)
 185       l
 186   in
 187   let l = List.map (fun (s, il) -> (s, compile_instr_list il)) l in
 188   let l = List.filter (fun (_, instr) -> instr <> OP_NOP ()) l in
 189     to_list l, not marking
 190
 191 (*
 192 let _total = ref 0
 193 let _empty = ref 0
 194 let () = at_exit (fun () -> Printf.eprintf "Dummy affectations %i/%i\n%!" !_empty !_total)
 195 ;;
 196 *)
 197
 198 DEFINE SET(a, b) = (a) <- (b)
 199
 200 DEFINE PRINT_TEMPLATE(ns) =
 201       let pr fmt (state, count) =
 202         fprintf fmt "%a: %i" State.print state (ns.length count)
 203       in
 204       Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
 205
 206 DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
 207    match inst with
 208     | SELF _ ->  ns.snoc acc t
 209     | LEFT src -> ns.concat acc slot1.(src)
 210     | RIGHT src -> ns.concat acc slot2.(src)
 211
 212
 213 DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
 214   match code with
 215     | OP_NOP _ -> ()
 216
 217     | OP_LEFT1 src ->
 218       SET(slot.(dst), slot1.(src))
 219
 220     | OP_LEFT2 (src1, src2) ->
 221       SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
 222
 223     | OP_RIGHT1 src -> SET(slot.(dst) , slot2.(src))
 224
 225     | OP_RIGHT2 (src1, src2) ->
 226       SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
 227
 228     | OP_LEFT1_RIGHT1 (src1, src2) ->
 229       SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
 230
 231     | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
 232       SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
 233
 234     | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
 235       SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3));
 236
 237     | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 238         SET (slot.(dst) , ns.concat4 slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4))
 239
 240     | OP_SELF _ ->
 241       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 242       slot.(dst) <- ns.singleton t
 243
 244     | OP_SELF_LEFT1 src ->
 245       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 246       slot.(dst) <- ns.cons t slot1.(src)
 247
 248     | OP_SELF_LEFT2 (src1, src2) ->
 249       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 250       slot.(dst) <- ns.conscat t slot1.(src1) slot1.(src2)
 251
 252     | OP_SELF_RIGHT1 src ->
 253       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 254       slot.(dst) <- ns.cons t slot2.(src)
 255
 256     | OP_SELF_RIGHT2 (src1, src2) ->
 257       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 258       slot.(dst) <- ns.conscat t slot2.(src1) slot2.(src2)
 259
 260     | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
 261       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 262       slot.(dst) <- ns.conscat t slot1.(src1) slot2.(src2)
 263
 264     | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
 265       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 266       slot.(dst) <- ns.conscat3 t slot1.(src1) slot1.(src2) slot2.(src3)
 267
 268     | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
 269       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 270       slot.(dst) <- ns.conscat3 t slot1.(src1) slot2.(src2) slot2.(src3)
 271
 272     | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 273       LOG(__ "res-jit" 1 "Putting Node %i in the result set\n" (Node.to_int t));
 274       slot.(dst) <-
 275         ns.conscat4 t slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4)
 276     | OP_OTHER line ->
 277       let acc = ref ns.empty in
 278       let len = Array.length line - 1 in
 279       for j = 0 to len do
 280         acc := exec_instr slot1 slot2 t line.(j) !acc
 281       done;
 282       slot.(dst) <- !acc
 283
 284
 285 DEFINE EXEC_REC_TEMPLATE =
 286           (match code with
 287           | Nil -> ()
 288           | Cons(dst, opcode, code1) ->
 289             LOG(__ "res-jit" 3 " %a := %a"
 290               State.print dst print_opcode opcode;
 291             );
 292             exec_code slot slot1 slot2 t dst opcode;
 293             begin
 294               match code1 with
 295             | Nil -> ()
 296             | Cons(dst, opcode, code1) ->
 297               LOG(__ "res-jit" 3 " %a := %a"
 298                 State.print dst print_opcode opcode;
 299               );
 300               exec_code slot slot1 slot2 t dst opcode;
 301               exec slot slot1 slot2 t code1
 302
 303             end)
 304
 305 DEFINE EXEC_TEMPLATE =
 306           (LOG(__ "res-jit" 3 "Node %i:@\nLEFT  : %a@\nRIGHT : %a"
 307                  (Node.to_int t) print slot1 print slot2
 308            );
 309            exec slot slot1 slot2 t code;
 310            LOG(__ "res-jit"  3  "RES   : %a" print slot))
 311
 312
 313 module type S =
 314   sig
 315     module NS : NodeSet.S
 316     type t = NS.t array
 317     val exec : t -> t -> t -> Tree.node -> code -> unit
 318     val print : Format.formatter -> t -> unit
 319     val var : int -> t -> t
 320     val close : ((int*State.t, NS.t) Hashtbl.t) -> t -> t
 321     val is_open : t -> bool
 322   end
 323
 324 module Count =
 325   struct
 326     module NS = NodeSet.Count
 327     type t = NodeSet.Count.t array
 328     let print fmt s = PRINT_TEMPLATE(NS)
 329     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
 330     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
 331     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 332     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 333     let var _ x = x
 334     let close _ x = x
 335     let is_open _ = false
 336   end
 337
 338 module Mat =
 339   struct
 340     module NS = NodeSet.Mat
 341     type t = NodeSet.Mat.t array
 342     let print fmt s = PRINT_TEMPLATE(NS)
 343     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
 344     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
 345     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 346     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 347     let var _ x = x
 348     let close _ x = x
 349     let is_open _ = false
 350   end
 351
 352
 353
 354 module Make(U : NodeSet.S) =
 355   struct
 356     module NS = U
 357     type t = U.t array
 358     let print fmt s = PRINT_TEMPLATE(NS)
 359     let exec_instr = EXEC_INSTR_TEMPLATE(U)
 360     let exec_code = EXEC_CODE_TEMPLATE(U)
 361     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 362     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 363     let var i t =
 364       Array.mapi (fun j _ -> NS.var (i,j)) t
 365     let close h t =
 366       Array.map (NS.close h) t
 367
 368     let is_open t =
 369       List.exists NS.is_open (Array.to_list t)
 370   end