src/resJIT.ml

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