run_dispatch.ml

(* Running dispatchers *)

(* Possible simple optimizations:
     - in make_result_prod, see if buffer can be simply overwritten
       (precompute this ...)
     - optimize for Xml elements (don't build the Pair (attr,content))
*)

(*
let (<) : int -> int -> bool = (<);;
*)

open Value
open Ident
open Patterns.Compile
open Encodings


let buffer = ref (Array.create 127 Absent)
let cursor = ref 0

let blit a1 ofs1 a2 ofs2 len =
  for i = 0 to len - 1 do
    Array.unsafe_set a2 (ofs2 + i) (Array.unsafe_get a1 (ofs1 + i))
  done
(* important to do this in the increasing order ... *)


let ensure_room n =
  let l = Array.length !buffer in
  if !cursor + n > l then
    let buffer' = Array.create (l * 2 + n) Absent in
    blit !buffer 0 buffer' 0 !cursor;
    buffer := buffer'

let push v =
  ensure_room 1;
  !buffer.(!cursor) <- v;
  incr cursor


(* Old dispatchers *)
    

let make_result_prod v1 r1 v2 r2 v (code,r) = 
  let n = Array.length r in
  if n == 0 then code else (
  ensure_room n;
  let buf = !buffer in
  let c = !cursor in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> v
      | Const c -> const c
      | Left i -> if (i < 0) then v1 else buf.(r1 + i)
      | Right j -> if (j < 0) then v2 else buf.(r2 + j)
      | Recompose (i,j) -> 
	  Pair ((if (i < 0) then v1 else buf.(r1 + i)),
		(if (j < 0) then v2 else buf.(r2 + j))) 
    in
    buf.(c + a) <- x
  done;
  if r1 != c then blit buf c buf r1 n;
  cursor := r1 + n;  (* clean space for GC ? *)
  code )

let make_result_basic v (code,r) = 
  let n = Array.length r in
  if n == 0 then code else (
  ensure_room n;
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> v
      | Const c -> const c 
      | _ -> assert false
    in
    buf.(!cursor) <- x;
    incr cursor
  done;
  code )


let make_result_char ch (code,r) = 
  let n = Array.length r in
  if n == 0 then code else (
  ensure_room n;
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> Char ch
      | Const c -> const c
      | _ -> assert false
    in
    buf.(!cursor + a) <- x
  done;
  cursor := !cursor + n;
  code )

let tail_string_latin1 i j s q =
  if i + 1 == j then q else String_latin1 (i + 1,j,s,q)

let make_result_string_latin1 i j s q r1 r2 (code,r) = 
  let n = Array.length r in
  if n == 0 then code else (
  ensure_room n;
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> String_latin1 (i,j,s,q)
      | Const c -> const c
      | Left n -> if (n < 0) then Char (Chars.V.mk_char s.[i]) else buf.(r1 + n)
      | Right m -> if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m)
      | Recompose (n,m) -> 
	  Pair ((if (n < 0) then Char (Chars.V.mk_char s.[i]) else buf.(r1 + n)),
		(if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m))) 
    in
    buf.(!cursor + a) <- x
  done;
  if r1 != !cursor then blit buf !cursor buf r1 n;
  cursor := r1 + n;
  code )

let tail_string_utf8 i j s q =
  let i = Utf8.advance s i in
  if Utf8.equal_index i j then q else String_utf8 (i,j,s,q)

let make_result_string_utf8 i j s q r1 r2 (code,r) = 
  let n = Array.length r in
  if n == 0 then code else (
  ensure_room n;
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> String_utf8 (i,j,s,q)
      | Const c -> const c
      | Left n -> if (n < 0) then Char (Chars.V.mk_int (Utf8.get s i)) else buf.(r1 + n)
      | Right m -> if (m < 0) then tail_string_utf8 i j s q else buf.(r2 + m)
      | Recompose (n,m) -> 
	  Pair ((if (n < 0) then Char (Chars.V.mk_int (Utf8.get s i)) else buf.(r1 + n)),
		(if (m < 0) then tail_string_utf8 i j s q else buf.(r2 + m))) 
    in
    buf.(!cursor + a) <- x
  done;
  if r1 != !cursor then blit buf !cursor buf r1 n;
  cursor := r1 + n;
  code )

let rec run_disp_basic v f =  function
  | [(_,r)] -> make_result_basic v r
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
  | _ -> assert false

let rec run_dispatcher d v = 
(*
  Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;
*)
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_kind k v

and run_disp_kind actions v =
  match v with
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
  | String_latin1 (i,j,s,q) -> 
(*      run_disp_kind actions (Value.normalize v) *)
      run_disp_string_latin1 i j s q actions
  | String_utf8 (i,j,s,q) -> 
(*      run_disp_kind actions (Value.normalize v) *)
	run_disp_string_utf8 i j s q actions 
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
  | Abstraction (iface,_)
  | Abstraction2 (_,iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
        actions.basic
  | Abstract (abs,_) -> 
      run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
	actions.basic
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
  | Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
  | Delayed _ -> assert false


and run_disp_prod v v1 v2 = function
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
  | Dispatch (d1,b1) ->
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)

and run_disp_prod2 v1 r1 v v2 = function
  | Impossible -> assert false
  | Ignore r -> make_result_prod v1 r1 v2 !cursor v r
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_dispatcher d2 v2 in
      make_result_prod v1 r1 v2 r2 v b2.(code2)

and run_disp_record other v fields = function
  | None -> assert false
  | Some (RecLabel (l,d)) ->
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
	| (l1,vl) :: rem when l1 == l ->
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
      in
      aux other fields
  | Some (RecNolabel (some,none)) ->
      let other = other || (fields != []) in
      let r = if other then some else none in
      match r with
	| Some r -> make_result_basic v r
	| None -> assert false
      
and run_disp_record1 other v1 rem = function
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 ->  run_disp_record2 other v1 !cursor rem d2
  | Dispatch (d1,b1) ->
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
      run_disp_record2 other v1 r1 rem b1.(code1)

and run_disp_record2 other v1 r1 rem = function
  | Impossible -> assert false
  | Ignore r -> make_result_prod v1 r1 Absent 0 Absent r
  | TailCall d2 -> run_disp_record_loop other rem d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_record_loop other rem d2 in
      make_result_prod v1 r1 Absent r2 Absent b2.(code2)

and run_disp_record_loop other rem d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_record other Absent rem k.record
  

and run_disp_string_latin1 i j s q actions = 
  if i == j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
    | TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
    | Ignore d2 -> run_disp_string_latin1_2 !cursor i j s q d2
    | Dispatch (d1,b1) ->
	let r1 = !cursor in
	let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
	run_disp_string_latin1_2 r1 i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
  match actions d with
    | AIgnore r -> make_result_char ch r
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
and run_disp_string_latin1_2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
      make_result_string_latin1 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_latin1_loop i j s q d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_string_latin1_loop i j s q d2 in
      make_result_string_latin1 i j s q r1 r2 b2.(code2)
and run_disp_string_latin1_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string_latin1 (succ i) j s q k

and run_disp_string_utf8 i j s q actions = 
  if Utf8.equal_index i j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
    | TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
    | Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
    | Dispatch (d1,b1) ->
	let r1 = !cursor in
	let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
	run_disp_string_utf8_2 r1 i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
  match actions d with
    | AIgnore r -> make_result_char ch r
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
and run_disp_string_utf8_2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
      make_result_string_utf8 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_utf8_loop i j s q d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_string_utf8_loop i j s q d2 in
      make_result_string_utf8 i j s q r1 r2 b2.(code2)
and run_disp_string_utf8_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k

let run_dispatcher d v =
  let code = run_dispatcher d v in
  cursor := 0;
  (code,!buffer) 

let old_dispatcher = run_dispatcher    

  
(*
let rec check_overwrite_aux r i =
  if i < 0 then true
  else match r.(i) with
    | Right j | Recompose (_,j) -> 
	if (j < 0) || (j >=i ) then check_overwrite_aux r (i - 1) else false
    | _ -> check_overwrite_aux r (i - 1)


let check_overwrite r2 r =
  (Array.length r2 = Array.length r) && (check_overwrite_aux r (Array.length r - 1))


*)




(* New dispatcher *)

open Patterns.Compile2

let make_result_basic v (code,r) = 
  let n = Array.length r in
  if n > 0 then (
    ensure_room n;
    let buf = !buffer in
    for a = 0 to n - 1 do
      buf.(!cursor) <- begin match Array.unsafe_get r a with
	| SrcCapture -> v
	| SrcCst c -> const c
	| _ -> assert false
      end;
      incr cursor
    done);
  code


let make_result_prod v1 r1 v2 r2 v (code,r) = 
  let n = Array.length r in
  if n > 0 then (
    ensure_room n;
    let buf = !buffer in
    let c = !cursor in
    for a = 0 to n - 1 do
       buf.(c + a) <- match Array.unsafe_get r a with
	 | SrcCapture -> v
	 | SrcLeft -> v1
	 | SrcRight -> v2
	 | SrcCst c -> const c
	 | SrcFetchLeft i -> buf.(r1+i)
	 | SrcFetchRight i -> buf.(r2+i)
	 | SrcPair (l,r) ->
	     Pair (
	       (match l with 
		  | SrcLeft -> v1 | SrcRight -> v2 
		  | SrcFetchLeft i -> buf.(r1+i) 
		  | SrcFetchRight i -> buf.(r2+i) | _ -> assert false),
	       (match r with 
		  | SrcLeft -> v1 | SrcRight -> v2 
		  | SrcFetchLeft i -> buf.(r1+i) 
		  | SrcFetchRight i -> buf.(r2+i) | _ -> assert false))
	 | _ -> assert false
    done;
    if r1 != c then blit buf c buf r1 n;
    cursor := r1 + n);
  code

let make_result_record sp v (code,r) = 
  let n = Array.length r in
  if n > 0 then (
    ensure_room n;
    let buf = !buffer in
    let c = !cursor in
    for a = 0 to n - 1 do
       buf.(c + a) <- match Array.unsafe_get r a with
	 | SrcLocal i -> buf.(sp+i)
	 | _ -> assert false
    done;
    if sp != c then blit buf c buf sp n;
    cursor := sp + n);
  code

let rec run_disp_basic v f =  function
  | [(_,r)] -> make_result_basic v r
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
  | _ -> assert false

let count = ref 0
let rec run_dispatcher d v = 
(*  Format.fprintf Format.std_formatter "Matching (%a)@." Value.print v; *)
(*   Patterns.Compile.print_dispatcher Format.std_formatter d; *)
(*  print_string "."; flush stdout; *)
(*  incr count;
  print_int !count;
  print_string "X"; flush stdout;
  if !count = 9685 then
    Format.fprintf Format.std_formatter "Matching (%a)@\n with:@\n%a@." 
      Value.print v
      Patterns.Compile2.print_dispatcher d;*)

  let res = 
    match actions d with
      | AResult r -> make_result_basic v r
      | AKind k -> run_disp_kind k v
  in 
(*  print_string "Y"; flush stdout;*)
  res

and run_disp_kind actions v =
  match v with
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
  | Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
  | String_latin1 (i,j,s,q) ->
      run_disp_kind actions (Value.normalize v)
      (* run_disp_string_latin1 i j s q actions *)
  | String_utf8 (i,j,s,q) as v ->
      run_disp_kind actions (Value.normalize v)
      (* run_disp_string_utf8 i j s q actions *)
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
  | Abstraction (iface,_)
  | Abstraction2 (_,iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
        actions.basic
  | Abstract (abs,_) -> 
      run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
	actions.basic
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
  | Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
  | Delayed _ -> assert false


and run_disp_prod v v1 v2 = function
  | Impossible -> assert false
  | LeftRight rdd -> run_disp_prod' v v1 v2 rdd
  | RightLeft rdd -> run_disp_prod' v v2 v1 rdd
  
and run_disp_prod' v v1 v2 = function
  | Dispatch (d1,b1) ->
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
      run_disp_prod2 v1 r1 v v2 b1.(code1)
  | TailCall d1 -> run_dispatcher d1 v1
  | Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2

and run_disp_prod2 v1 r1 v v2 = function
  | Ignore r -> make_result_prod v1 r1 v2 !cursor v r
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_dispatcher d2 v2 in
      make_result_prod v1 r1 v2 r2 v b2.(code2)

and do_pushes v vl = function
  | [] -> ()
  | PushConst c :: rem -> push (const c); do_pushes v vl rem
  | PushField   :: rem -> push vl; do_pushes v vl rem
  | PushCapture :: rem -> push v; do_pushes v vl rem

and do_record_tr sp other v vl fields tr =
  let (pushes,ct) = Lazy.force tr in
(*   print_string "*"; flush stdout; *)
  do_pushes v vl pushes;
  run_disp_record sp other v fields ct

and run_disp_record sp other v fields = function
  | RecordLabel (l,d,cts) ->
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
	| (l1,vl) :: rem when l1 == l ->
	    do_record_tr sp other v vl rem cts.(run_dispatcher d vl)
	| rem -> 
	    do_record_tr sp other v Absent rem cts.(run_dispatcher d Absent)
      in
      aux other fields
  | RecordLabelSkip (l,pr) ->
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
	| (l1,vl) :: rem when l1 == l -> do_record_tr sp other v vl rem pr
	| rem -> do_record_tr sp other v Absent rem pr
      in
      aux other fields
  | RecordResult r ->
      make_result_record sp v r
  | RecordMore (nomore,more) ->
      let other = other || (fields != []) in
      make_result_record sp v (if other then more else nomore)
  | RecordImpossible -> assert false
      
(*  

and run_disp_string_latin1 i j s q actions = 
  if i == j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
    | TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
    | Ignore d2 -> run_disp_string_latin1_2 !cursor i j s q d2
    | Dispatch (d1,b1) ->
	let r1 = !cursor in
	let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
	run_disp_string_latin1_2 r1 i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
  match actions d with
    | AIgnore r -> make_result_char ch r
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
and run_disp_string_latin1_2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
      make_result_string_latin1 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_latin1_loop i j s q d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_string_latin1_loop i j s q d2 in
      make_result_string_latin1 i j s q r1 r2 b2.(code2)
and run_disp_string_latin1_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string_latin1 (succ i) j s q k

and run_disp_string_utf8 i j s q actions = 
  if Utf8.equal_index i j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
    | TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
    | Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
    | Dispatch (d1,b1) ->
	let r1 = !cursor in
	let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
	run_disp_string_utf8_2 r1 i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
  match actions d with
    | AIgnore r -> make_result_char ch r
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
and run_disp_string_utf8_2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
      make_result_string_utf8 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_utf8_loop i j s q d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_string_utf8_loop i j s q d2 in
      make_result_string_utf8 i j s q r1 r2 b2.(code2)
and run_disp_string_utf8_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
*)

let run_dispatcher2 d v =
(*   print_string "+"; flush stdout; *)
  let code = run_dispatcher d v in
  cursor := 0;
(*   print_string "-\n"; flush stdout; *)
  (code,!buffer) 



let run_dispatcher = old_dispatcher