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 type 'a update = 'a -> 'a -> 'a -> Tree.t -> Tree.node -> StateSet.t * 'a
 193 type 'a cache = 'a update Cache.Lvl3.t
 194
 195 let dummy_update = fun _ _ _ _ _ -> failwith "Uninitialized L3JIT"
 196 let show_stats (a : 'a cache) =
 197   let count = ref 0 in
 198   Cache.Lvl3.iteri (fun _ _ _ _ b -> if not b then incr count) a;
 199   eprintf "%!L3JIT: %i used entries\n%!" !count
 200
 201 let create () =
 202   let v = Cache.Lvl3.create 1024 dummy_update in
 203   if !Options.verbose then at_exit (fun () -> show_stats v);
 204   v
 205
 206 let find (t : 'a cache) tlist s1 s2 =
 207   Cache.Lvl3.find t
 208     (Uid.to_int s2.StateSet.Node.id)
 209     (Uid.to_int s1.StateSet.Node.id)
 210     (Uid.to_int tlist.Translist.Node.id)
 211
 212 let add (t : 'a cache) tlist s1 s2 v =
 213   Cache.Lvl3.add t
 214     (Uid.to_int s2.StateSet.Node.id)
 215     (Uid.to_int s1.StateSet.Node.id)
 216     (Uid.to_int tlist.Translist.Node.id)
 217     v
 218
 219 let eval_form auto s1 s2 f =
 220   let rec loop f =
 221     match Formula.expr f with
 222     | Formula.False | Formula.True | Formula.Pred _ -> f, []
 223     | Formula.Atom(`Left, b, q) ->
 224       Formula.of_bool (b == (StateSet.mem q s1)),
 225       if b && StateSet.mem q auto.Ata.topdown_marking_states then [LEFT q] else []
 226     | Formula.Atom (`Right, b, q) ->
 227       Formula.of_bool(b == (StateSet.mem q s2)),
 228       if b && StateSet.mem q auto.Ata.topdown_marking_states then [RIGHT q] else []
 229     | Formula.Atom (`Epsilon, _, _) -> assert false
 230
 231     | Formula.Or(f1, f2) ->
 232       let b1, i1 = loop f1 in
 233       let b2, i2 = loop f2 in
 234       Formula.or_pred b1 b2, i1 @ i2
 235     | Formula.And(f1, f2) ->
 236       let b1, i1 = loop f1 in
 237       let b2, i2 = loop f2 in
 238       Formula.and_pred b1 b2, i1 @ i2
 239   in
 240   loop f
 241
 242 let eval_trans auto s1 s2 trans =
 243   Translist.fold
 244     (fun t ((a_st, a_op, a_todo) as acc)->
 245       let q, _, m, f = Transition.node t in
 246       let form, ops = eval_form auto s1 s2 f in
 247       match Formula.expr form with
 248       | Formula.True ->
 249         StateSet.add q a_st,
 250         (q, (if m then (SELF() :: ops) else ops)):: a_op,
 251         a_todo
 252       | Formula.False -> acc
 253       | Formula.Pred p -> a_st, a_op,
 254         (p.Tree.Predicate.node, q, [(q,(if m then (SELF() :: ops) else ops))]) :: a_todo
 255       | _ -> assert false
 256     ) trans (StateSet.empty, [], [])
 257
 258 let compile_update auto trl s1 s2 =
 259   let orig_s1, orig_s2 =
 260     Translist.fold (fun t (a1, a2) ->
 261       let _, _, _, f = Transition.node t in
 262       let  fs1, fs2 = Formula.st f in
 263       (StateSet.union a1 fs1, StateSet.union a2 fs2)
 264     ) trl (StateSet.empty, StateSet.empty)
 265   in
 266   let ns1 = StateSet.inter s1 orig_s1
 267   and ns2 = StateSet.inter s2 orig_s2 in
 268   let res, ops, todo = eval_trans auto ns1 ns2 trl in
 269   let code, not_marking = compile ops in
 270   let todo_code, todo_notmarking =
 271     List.fold_left (fun (l, b) (p, q, o) -> let c, b' = compile o in
 272                                             (p, q, c)::l, b && b')
 273               ([], not_marking) todo
 274   in
 275   let opcode = res, code, todo_notmarking, todo_code in
 276   opcode
 277
 278 let gen_code exec auto tlist s1 s2 =
 279   let res, code, not_marking, todo_code = compile_update auto tlist s1 s2 in
 280   let f =
 281     if todo_code == [] then
 282       if not_marking then begin fun empty_slot sl1 sl2 _ node ->
 283         let slot1_empty = sl1 == empty_slot
 284         and slot2_empty = sl2 == empty_slot in
 285         if slot1_empty && slot2_empty then res,sl2
 286         else
 287           let sl =
 288             if slot2_empty then
 289               if slot1_empty then
 290                 Array.copy empty_slot
 291               else sl1
 292             else sl2
 293           in
 294           exec sl sl1 sl2 node code;
 295           res, sl
 296       end
 297       else (* marking *) begin fun empty_slot sl1 sl2 _ node ->
 298         let sl =
 299           if sl2 == empty_slot  then
 300             if sl1 == empty_slot then
 301               Array.copy empty_slot
 302             else sl1
 303           else sl2
 304         in
 305         exec sl sl1 sl2 node code;
 306         res, sl
 307       end
 308     else (* todo != [] *)
 309       begin fun empty_slot sl1 sl2 tree node ->
 310         let sl =
 311           if sl2 == empty_slot  then
 312             if sl1 == empty_slot then
 313               Array.copy empty_slot
 314             else sl1
 315           else sl2
 316         in
 317         exec sl sl1 sl2 node code;
 318         List.fold_left
 319           (fun ares (p, q, code) ->
 320             if !p tree node then begin
 321               if code != Nil then exec sl sl1 sl2 node code;
 322               StateSet.add q ares
 323             end
 324             else ares) res todo_code, sl
 325
 326       end
 327   in
 328   f
 329
 330
 331
 332
 333
 334 DEFINE SET(a, b) = (a) <- (b)
 335
 336 DEFINE PRINT_TEMPLATE(ns) =
 337       let pr fmt (state, count) =
 338         fprintf fmt "%a: %i" State.print state (ns.length count)
 339       in
 340       Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
 341
 342 DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
 343    match inst with
 344     | SELF _ ->  ns.snoc acc t
 345     | LEFT src -> ns.concat acc slot1.(src)
 346     | RIGHT src -> ns.concat acc slot2.(src)
 347
 348
 349 DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
 350   match code with
 351     | OP_NOP _ -> ()
 352
 353     | OP_LEFT1 src ->
 354       SET(slot.(dst), slot1.(src))
 355
 356     | OP_LEFT2 (src1, src2) ->
 357       SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
 358
 359     | OP_RIGHT1 src -> SET(slot.(dst) , slot2.(src))
 360
 361     | OP_RIGHT2 (src1, src2) ->
 362       SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
 363
 364     | OP_LEFT1_RIGHT1 (src1, src2) ->
 365       SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
 366
 367     | OP_LEFT2_RIGHT1 (src1, src2, src3) ->
 368       SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
 369
 370     | OP_LEFT1_RIGHT2 (src1, src2, src3) ->
 371       SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3));
 372
 373     | OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 374         SET (slot.(dst) , ns.concat4 slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4))
 375
 376     | OP_SELF _ ->
 377         slot.(dst) <- ns.singleton t
 378
 379     | OP_SELF_LEFT1 src -> slot.(dst) <- ns.cons t slot1.(src)
 380
 381     | OP_SELF_LEFT2 (src1, src2) ->
 382         slot.(dst) <- ns.conscat t slot1.(src1) slot1.(src2)
 383
 384     | OP_SELF_RIGHT1 src -> slot.(dst) <- ns.cons t slot2.(src)
 385
 386     | OP_SELF_RIGHT2 (src1, src2) ->
 387         slot.(dst) <- ns.conscat t slot2.(src1) slot2.(src2)
 388
 389     | OP_SELF_LEFT1_RIGHT1 (src1, src2) ->
 390         slot.(dst) <- ns.conscat t slot1.(src1) slot2.(src2)
 391
 392     | OP_SELF_LEFT2_RIGHT1 (src1, src2, src3) ->
 393         slot.(dst) <- ns.conscat3 t slot1.(src1) slot1.(src2) slot2.(src3)
 394
 395     | OP_SELF_LEFT1_RIGHT2 (src1, src2, src3) ->
 396         slot.(dst) <- ns.conscat3 t slot1.(src1) slot2.(src2) slot2.(src3)
 397
 398     | OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
 399         slot.(dst) <-
 400           ns.conscat4 t slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4)
 401     | OP_OTHER line ->
 402       let acc = ref ns.empty in
 403       let len = Array.length line - 1 in
 404       for j = 0 to len do
 405         acc := exec_instr slot1 slot2 t line.(j) !acc
 406       done;
 407       slot.(dst) <- !acc
 408
 409
 410 DEFINE EXEC_REC_TEMPLATE =
 411           (match code with
 412           | Nil -> ()
 413           | Cons(dst, opcode, code1) ->
 414             TRACE("res-jit", 3, __ "  %a := %a\n%!"
 415               State.print dst print_opcode opcode;
 416             );
 417             exec_code slot slot1 slot2 t dst opcode;
 418             begin
 419               match code1 with
 420             | Nil -> ()
 421             | Cons(dst, opcode, code1) ->
 422               TRACE("res-jit", 3, __ "  %a := %a\n%!"
 423                 State.print dst print_opcode opcode;
 424               );
 425               exec_code slot slot1 slot2 t dst opcode;
 426               exec slot slot1 slot2 t code1
 427
 428             end)
 429
 430 DEFINE EXEC_TEMPLATE =
 431           (TRACE("res-jit", 3, __ "Node %i:\n" (Node.to_int t));
 432            TRACE("res-jit", 3, __ " LEFT  : %a\n" pr_slot slot1);
 433            TRACE("res-jit", 3, __ " RIGHT : %a\n" pr_slot slot2);
 434            exec slot slot1 slot2 t code;
 435            TRACE("res-jit", 3, __ " RES   : %a\n\n%!" pr_slot slot))
 436
 437
 438 DEFINE UPDATE_TEMPLATE =
 439           let f = find cache tlist s1 s2 in
 440           if f == dummy_update then
 441             let f = gen_code exec auto tlist s1 s2 in
 442             add cache tlist s1 s2 f;
 443             f empty_res sl1 sl2 tree node
 444           else
 445             f empty_res sl1 sl2 tree node
 446
 447
 448 module type S =
 449   sig
 450     module NS : NodeSet.S
 451     type t = NS.t array
 452     val exec : t -> t -> t -> Tree.node -> code -> unit
 453     val update : t cache -> Ata.t -> Translist.t -> StateSet.t -> StateSet.t ->
 454       t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t
 455     val print : Format.formatter -> t -> unit
 456     val var : int -> t -> t
 457     val close : ((int*State.t, NS.t) Hashtbl.t) -> t -> t
 458     val is_open : t -> bool
 459   end
 460
 461 module Count =
 462   struct
 463     module NS = NodeSet.Count
 464     type t = NodeSet.Count.t array
 465     let print fmt s = PRINT_TEMPLATE(NS)
 466     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
 467     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
 468     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 469     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 470     let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
 471     let var _ x = x
 472     let close _ x = x
 473     let is_open _ = false
 474   end
 475
 476 module Mat =
 477   struct
 478     module NS = NodeSet.Mat
 479     type t = NodeSet.Mat.t array
 480     let print fmt s = PRINT_TEMPLATE(NS)
 481     let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
 482     let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
 483     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 484     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 485     let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
 486     let var _ x = x
 487     let close _ x = x
 488     let is_open _ = false
 489   end
 490
 491
 492
 493 module Make(U : NodeSet.S) =
 494   struct
 495     module NS = U
 496     type t = U.t array
 497     let print fmt s = PRINT_TEMPLATE(NS)
 498     let exec_instr = EXEC_INSTR_TEMPLATE(U)
 499     let exec_code = EXEC_CODE_TEMPLATE(U)
 500     let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE
 501     let exec slot slot1 slot2 t code = EXEC_TEMPLATE
 502     let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
 503     let var i t =
 504       Array.mapi (fun j _ -> NS.var (i,j)) t
 505     let close h t =
 506       Array.map (NS.close h) t
 507
 508     let is_open t =
 509       List.exists NS.is_open (Array.to_list t)
 510   end