src/resJIT.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3 INCLUDE "trace.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 EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
 201    match inst with
 202     | SELF _ ->  ns.snoc acc t
 203     | LEFT src -> ns.concat acc slot1.(src)
 204     | RIGHT src -> ns.concat acc slot2.(src)
 205
 206
 207 DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
 208   match code with
 209     | OP_NOP _ -> ()
 210
 211     | OP_LEFT1 src ->
 212         SET(slot.(dst), slot1.(src))
 213
 214     | OP_LEFT2 (src1, src2) ->
 215         SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
 216
 217     | OP_RIGHT1 src -> SET(slot.(dst) , slot2.(src))
 218
 219     | OP_RIGHT2 (src1, src2) ->
 220       SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
 221
 222     | OP_LEFT1_RIGHT1 (src1, src2) ->
 223         SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
 224
 225     | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
 226         SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
 227
 228     | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
 229       TRACE("res-jit", 3, __ "slot==slot1: %b, slot==slot2:%b\n" (slot==slot1) (slot==slot2));
 230       SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3));
 231
 232     | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 233         SET (slot.(dst) , ns.concat4 slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4))
 234
 235     | OP_SELF _ ->
 236         slot.(dst) <- ns.singleton t
 237
 238     | OP_SELF_LEFT1 src -> slot.(dst) <- ns.cons t slot1.(src)
 239
 240     | OP_SELF_LEFT2 (src1, src2) ->
 241         slot.(dst) <- ns.conscat t slot1.(src1) slot1.(src2)
 242
 243     | OP_SELF_RIGHT1 src -> slot.(dst) <- ns.cons t slot2.(src)
 244
 245     | OP_SELF_RIGHT2 (src1, src2) ->
 246         slot.(dst) <- ns.conscat t slot2.(src1) slot2.(src2)
 247
 248     | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
 249         slot.(dst) <- ns.conscat t slot1.(src1) slot2.(src2)
 250
 251     | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
 252         slot.(dst) <- ns.conscat3 t slot1.(src1) slot1.(src2) slot2.(src3)
 253
 254     | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
 255         slot.(dst) <- ns.conscat3 t slot1.(src1) slot2.(src2) slot2.(src3)
 256
 257     | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 258         slot.(dst) <-
 259           ns.conscat4 t slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4)
 260     | OP_OTHER line ->
 261       let acc = ref ns.empty in
 262       let len = Array.length line - 1 in
 263       for j = 0 to len do
 264         acc := exec_instr slot1 slot2 t line.(j) !acc
 265       done;
 266       slot.(dst) <- !acc
 267
 268
 269 module type S =
 270   sig
 271     module NS : NodeSet.S
 272     type t = NS.t array
 273     val exec : t -> t -> t -> Tree.node -> code -> unit
 274   end
 275
 276
 277
 278 module Count =
 279   struct
 280     module NS = NodeSet.Count
 281     type t = NodeSet.Count.t array
 282     let pr_slot fmt s =
 283       let pr fmt (state, count) =
 284         fprintf fmt "%a: %i" State.print state (NS.length count)
 285       in
 286       Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
 287
 288     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
 289     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
 290       (* inline by hand for efficiency reason *)
 291     let rec exec slot slot1 slot2 t code =
 292       match code with
 293         | Nil -> ()
 294         | Cons(dst, opcode, code1) ->
 295           TRACE("res-jit", 3, __ "  %a := %a\n%!"
 296             State.print dst print_opcode opcode;
 297           );
 298           exec_code slot slot1 slot2 t dst opcode;
 299           begin
 300             match code1 with
 301             | Nil -> ()
 302             | Cons(dst, opcode, code1) ->
 303               TRACE("res-jit", 3, __ "  %a := %a\n%!"
 304                 State.print dst print_opcode opcode;
 305               );
 306               exec_code slot slot1 slot2 t dst opcode;
 307               exec slot slot1 slot2 t code1
 308           end
 309
 310     let exec slot slot1 slot2 t code =
 311       TRACE("res-jit", 3, __ "Node %i:\n" (Node.to_int t));
 312       TRACE("res-jit", 3, __ " LEFT  : %a\n" pr_slot slot1);
 313       TRACE("res-jit", 3, __ " RIGHT : %a\n" pr_slot slot2);
 314       exec slot slot1 slot2 t code;
 315       TRACE("res-jit", 3, __ " RES   : %a\n\n%!" pr_slot slot)
 316
 317   end
 318
 319 module Mat =
 320   struct
 321     module NS = NodeSet.Mat
 322     type t = NodeSet.Mat.t array
 323     let pr_slot fmt s =
 324       let pr fmt (state, count) =
 325         fprintf fmt "%a: %i" State.print state (NS.length count)
 326       in
 327       Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
 328
 329     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
 330     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
 331       (* inline by hand for efficiency reason *)
 332     let rec exec slot slot1 slot2 t code =
 333       match code with
 334         | Nil -> ()
 335         | Cons(dst, code, code1) ->
 336             exec_code slot slot1 slot2 t dst code;
 337             begin
 338               match code1 with
 339               | Nil -> ()
 340               | Cons(dst', code', code1') ->
 341                 exec_code slot slot1 slot2 t dst' code';
 342                 exec slot slot1 slot2 t code1'
 343             end
 344   end
 345
 346
 347