viewcvs.cgi/runtime/run_dispatch.ml

(* Running dispatchers *)

(* Possible simple optimizations:
     - in make_result_prod, see if buffer can be simply overwritten
       (precompute this ...)
*)

open Value
open Ident
open Patterns.Compile


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


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 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
  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.(!cursor + a) <- x
  done;
  if r1 <> !cursor then blit buf !cursor 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 + a) <- x
  done;
  cursor := !cursor + n;
  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 i j s q =
  if i + 1 = j then q else String (i + 1,j,s,q)

let make_result_string 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 (i,j,s,q)
      | Const c -> const c
      | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)
      | Right m -> if (m < 0) then tail_string i j s q else buf.(r2 + m)
      | Recompose (n,m) -> 
          Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)),
                (if (m < 0) then tail_string 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) -> run_disp_prod v v1 v2 actions.xml
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
  | String (i,j,s,q) -> run_disp_string 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,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
        actions.basic
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
(*  | v ->
      run_disp_kind actions (normalize v) 
*)


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 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 !cursor 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 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_char d1 (Chars.mk_char s.[i])
    | Ignore d2 -> run_disp_string2 !cursor i j s q d2
    | Dispatch (d1,b1) ->
        let r1 = !cursor in
        let code1 = run_disp_string_char d1 (Chars.mk_char s.[i]) in
        run_disp_string2 r1 i j s q b1.(code1)
and run_disp_string_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_string2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
      make_result_string i j s q r1 !cursor r
  | TailCall d2 -> run_disp_string_loop i j s q d2
  | Dispatch (d2,b2) ->
      let r2 = !cursor in
      let code2 = run_disp_string_loop i j s q d2 in
      make_result_string i j s q r1 r2 b2.(code2)
and run_disp_string_loop i j s q d =
  match actions d with
    | AIgnore r -> make_result_basic Absent r
    | AKind k -> run_disp_string (succ i) j s q k

let run_dispatcher d v =
  let code = run_dispatcher d v in
(* for unknown reasons, it seems to be faster to copy the interesting prefix... *)
(*  cursor := 0;
  (code,!buffer) *)
  let r = Array.create !cursor Absent in
  blit !buffer 0 r 0 !cursor;
  cursor := 0;
  (code,r)
    

(*
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))


*)
1	abate	70	(* Running dispatchers *)
2
3	abate	245	(* Possible simple optimizations:
4			- in make_result_prod, see if buffer can be simply overwritten
5			(precompute this ...)
6			*)
7
8	abate	70	open Value
9	abate	233	open Ident
10	abate	172	open Patterns.Compile
11	abate	70
12	abate	237
13	abate	245	let buffer = ref (Array.create 127 Absent)
14			let cursor = ref 0
15
16			let blit a1 ofs1 a2 ofs2 len =
17			for i = 0 to len - 1 do
18			Array.unsafe_set a2 (ofs2 + i) (Array.unsafe_get a1 (ofs1 + i))
19			done
20
21
22			let ensure_room n =
23			let l = Array.length !buffer in
24			if !cursor + n > l then
25			let buffer' = Array.create (l * 2 + n) Absent in
26			blit !buffer 0 buffer' 0 !cursor;
27			buffer := buffer'
28
29
30	abate	70	let make_result_prod v1 r1 v2 r2 v (code,r) =
31	abate	245	let n = Array.length r in
32			if n = 0 then code else (
33			ensure_room n;
34			let buf = !buffer in
35			for a = 0 to n - 1 do
36			let x = match Array.unsafe_get r a with
37			\| Catch -> v
38			\| Const c -> const c
39			\| Left i -> if (i < 0) then v1 else buf.(r1 + i)
40			\| Right j -> if (j < 0) then v2 else buf.(r2 + j)
41			\| Recompose (i,j) ->
42			Pair ((if (i < 0) then v1 else buf.(r1 + i)),
43			(if (j < 0) then v2 else buf.(r2 + j)))
44			in
45			buf.(!cursor + a) <- x
46			done;
47	abate	247	if r1 <> !cursor then blit buf !cursor buf r1 n;
48	abate	245	cursor := r1 + n; (* clean space for GC ? *)
49			code )
50	abate	70
51			let make_result_basic v (code,r) =
52	abate	245	let n = Array.length r in
53			if n = 0 then code else (
54			ensure_room n;
55			let buf = !buffer in
56			for a = 0 to n - 1 do
57			let x = match Array.unsafe_get r a with
58			\| Catch -> v
59			\| Const c -> const c
60			\| _ -> assert false
61			in
62			buf.(!cursor + a) <- x
63			done;
64	abate	246	cursor := !cursor + n;
65	abate	245	code )
66	abate	70
67	abate	245
68	abate	231	let make_result_char ch (code,r) =
69	abate	245	let n = Array.length r in
70			if n = 0 then code else (
71			ensure_room n;
72			let buf = !buffer in
73			for a = 0 to n - 1 do
74			let x = match Array.unsafe_get r a with
75			\| Catch -> Char ch
76			\| Const c -> const c
77			\| _ -> assert false
78			in
79			buf.(!cursor + a) <- x
80			done;
81	abate	246	cursor := !cursor + n;
82	abate	245	code )
83	abate	231
84	abate	232	let tail_string i j s q =
85			if i + 1 = j then q else String (i + 1,j,s,q)
86	abate	243
87	abate	232	let make_result_string i j s q r1 r2 (code,r) =
88	abate	245	let n = Array.length r in
89			if n = 0 then code else (
90			ensure_room n;
91			let buf = !buffer in
92			for a = 0 to n - 1 do
93			let x = match Array.unsafe_get r a with
94			\| Catch -> String (i,j,s,q)
95			\| Const c -> const c
96			\| Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)
97			\| Right m -> if (m < 0) then tail_string i j s q else buf.(r2 + m)
98			\| Recompose (n,m) ->
99			Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)),
100			(if (m < 0) then tail_string i j s q else buf.(r2 + m)))
101			in
102			buf.(!cursor + a) <- x
103			done;
104	abate	247	if r1 <> !cursor then blit buf !cursor buf r1 n;
105	abate	245	cursor := r1 + n;
106			code )
107	abate	232
108
109	abate	230	let rec run_disp_basic v f = function
110			\| [(_,r)] -> make_result_basic v r
111			\| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
112	abate	243	\| _ -> assert false
113	abate	230
114	abate	70	let rec run_dispatcher d v =
115	abate	229	(*
116			Format.fprintf Format.std_formatter "Matching (%a) with:@\n" Value.print v;
117			Patterns.Compile.print_dispatcher Format.std_formatter d;
118			*)
119	abate	172	match actions d with
120			\| AIgnore r -> make_result_basic v r
121			\| AKind k -> run_disp_kind k v
122	abate	70
123	abate	71	and run_disp_kind actions v =
124			match v with
125	abate	172	\| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
126			\| Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
127	abate	233	\| Record r -> run_disp_record false v (LabelMap.get r) actions.record
128	abate	231	\| String (i,j,s,q) -> run_disp_string i j s q actions
129	abate	243	\| Atom a -> make_result_basic v (Atoms.get_map a actions.atoms)
130			\| Char c -> make_result_basic v (Chars.get_map c actions.chars)
131	abate	70	\| Integer i ->
132	abate	172	run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
133	abate	70	\| Abstraction (iface,_) ->
134			run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
135	abate	172	actions.basic
136	abate	229	\| Absent ->
137			run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
138	abate	245	(* \| v ->
139	abate	70	run_disp_kind actions (normalize v)
140	abate	245	*)
141	abate	70
142
143	abate	229	and run_disp_prod v v1 v2 = function
144	abate	172	\| Impossible -> assert false
145			\| TailCall d1 -> run_dispatcher d1 v1
146	abate	246	\| Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
147	abate	172	\| Dispatch (d1,b1) ->
148	abate	245	let r1 = !cursor in
149			let code1 = run_dispatcher d1 v1 in
150	abate	70	run_disp_prod2 v1 r1 v v2 b1.(code1)
151
152	abate	229	and run_disp_prod2 v1 r1 v v2 = function
153	abate	172	\| Impossible -> assert false
154	abate	246	\| Ignore r -> make_result_prod v1 r1 v2 !cursor v r
155	abate	172	\| TailCall d2 -> run_dispatcher d2 v2
156			\| Dispatch (d2,b2) ->
157	abate	245	let r2 = !cursor in
158			let code2 = run_dispatcher d2 v2 in
159	abate	70	make_result_prod v1 r1 v2 r2 v b2.(code2)
160
161	abate	229	and run_disp_record other v fields = function
162	abate	70	\| None -> assert false
163	abate	230	\| Some (RecLabel (l,d)) ->
164	abate	165	let rec aux other = function
165			\| (l1,_) :: rem when l1 < l -> aux true rem
166	abate	229	\| (l1,vl) :: rem when l1 = l ->
167			run_disp_record1 other vl rem d
168			\| rem ->
169			run_disp_record1 other Absent rem d
170	abate	70	in
171	abate	165	aux other fields
172	abate	230	\| Some (RecNolabel (some,none)) ->
173	abate	229	let r = if other then some else none in
174			match r with
175			\| Some r -> make_result_basic v r
176			\| None -> assert false
177
178			and run_disp_record1 other v1 rem = function
179			\| Impossible -> assert false
180			\| TailCall d1 -> run_dispatcher d1 v1
181	abate	246	\| Ignore d2 -> run_disp_record2 other v1 !cursor rem d2
182	abate	229	\| Dispatch (d1,b1) ->
183	abate	245	let r1 = !cursor in
184			let code1 = run_dispatcher d1 v1 in
185	abate	229	run_disp_record2 other v1 r1 rem b1.(code1)
186	abate	70
187	abate	229	and run_disp_record2 other v1 r1 rem = function
188	abate	172	\| Impossible -> assert false
189	abate	246	\| Ignore r -> make_result_prod v1 r1 Absent !cursor Absent r
190	abate	229	\| TailCall d2 -> run_disp_record_loop other rem d2
191			\| Dispatch (d2,b2) ->
192	abate	245	let r2 = !cursor in
193			let code2 = run_disp_record_loop other rem d2 in
194	abate	229	make_result_prod v1 r1 Absent r2 Absent b2.(code2)
195
196			and run_disp_record_loop other rem d =
197			match actions d with
198			\| AIgnore r -> make_result_basic Absent r
199	abate	231	\| AKind k -> run_disp_record other Absent rem k.record
200	abate	229
201	abate	231
202			and run_disp_string i j s q actions =
203			if i = j then run_disp_kind actions q
204			else match actions.prod with
205			\| Impossible -> assert false
206			\| TailCall d1 -> run_disp_string_char d1 (Chars.mk_char s.[i])
207	abate	246	\| Ignore d2 -> run_disp_string2 !cursor i j s q d2
208	abate	231	\| Dispatch (d1,b1) ->
209	abate	245	let r1 = !cursor in
210			let code1 = run_disp_string_char d1 (Chars.mk_char s.[i]) in
211	abate	231	run_disp_string2 r1 i j s q b1.(code1)
212			and run_disp_string_char d ch =
213			match actions d with
214			\| AIgnore r -> make_result_char ch r
215	abate	243	\| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
216	abate	231	and run_disp_string2 r1 i j s q = function
217			\| Impossible -> assert false
218			\| Ignore r ->
219	abate	246	make_result_string i j s q r1 !cursor r
220	abate	231	\| TailCall d2 -> run_disp_string_loop i j s q d2
221			\| Dispatch (d2,b2) ->
222	abate	245	let r2 = !cursor in
223			let code2 = run_disp_string_loop i j s q d2 in
224	abate	232	make_result_string i j s q r1 r2 b2.(code2)
225	abate	231	and run_disp_string_loop i j s q d =
226			match actions d with
227			\| AIgnore r -> make_result_basic Absent r
228			\| AKind k -> run_disp_string (succ i) j s q k
229	abate	245
230			let run_dispatcher d v =
231			let code = run_dispatcher d v in
232	abate	247	(* for unknown reasons, it seems to be faster to copy the interesting prefix... *)
233	abate	245	(* cursor := 0;
234			(code,!buffer) *)
235			let r = Array.create !cursor Absent in
236			blit !buffer 0 r 0 !cursor;
237			cursor := 0;
238			(code,r)
239
240
241	abate	231
242	abate	245	(*
243			let rec check_overwrite_aux r i =
244			if i < 0 then true
245			else match r.(i) with
246			\| Right j \| Recompose (_,j) ->
247			if (j < 0) \|\| (j >=i ) then check_overwrite_aux r (i - 1) else false
248			\| _ -> check_overwrite_aux r (i - 1)
249	abate	231
250	abate	245
251			let check_overwrite r2 r =
252			(Array.length r2 = Array.length r) && (check_overwrite_aux r (Array.length r - 1))
253
254
255			*)