run_dispatch.ml 9.72 KB
Newer Older
1
2
(* Running dispatchers *)

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

9
10
11
12
(*
let (<) : int -> int -> bool = (<);;
*)

13
open Value
14
open Ident
15
open Patterns.Compile
16
open Encodings
17

18
19
20
21
22
23
24
25

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
26
(* important to do this in the increasing order ... *)
27
28
29
30
31
32
33
34
35


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'
    
36

37
let make_result_prod v1 r1 v2 r2 v (code,r) = 
38
  let n = Array.length r in
39
  if n == 0 then code else (
40
41
  ensure_room n;
  let buf = !buffer in
42
  let c = !cursor in
43
44
45
46
47
48
49
50
51
52
  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
53
    buf.(c + a) <- x
54
  done;
55
  if r1 != c then blit buf c buf r1 n;
56
57
  cursor := r1 + n;  (* clean space for GC ? *)
  code )
58
59

let make_result_basic v (code,r) = 
60
  let n = Array.length r in
61
  if n == 0 then code else (
62
63
64
65
66
67
68
69
  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
70
71
    buf.(!cursor) <- x;
    incr cursor
72
73
74
  done;
  code )

75

76
let make_result_char ch (code,r) = 
77
  let n = Array.length r in
78
  if n == 0 then code else (
79
80
81
82
83
84
85
86
87
88
  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;
89
  cursor := !cursor + n;
90
  code )
91

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

95
let make_result_string_latin1 i j s q r1 r2 (code,r) = 
96
  let n = Array.length r in
97
  if n == 0 then code else (
98
99
100
101
  ensure_room n;
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
102
      | Catch -> String_latin1 (i,j,s,q)
103
104
      | Const c -> const c
      | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)
105
      | Right m -> if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m)
106
107
      | Recompose (n,m) -> 
	  Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)),
108
		(if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m))) 
109
110
111
    in
    buf.(!cursor + a) <- x
  done;
112
  if r1 != !cursor then blit buf !cursor buf r1 n;
113
114
  cursor := r1 + n;
  code )
115

116
117
118
119
120
121
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
122
  if n == 0 then code else (
123
124
125
126
127
128
129
130
131
132
133
134
135
136
  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.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.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;
137
  if r1 != !cursor then blit buf !cursor buf r1 n;
138
139
  cursor := r1 + n;
  code )
140

141
142
143
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
144
  | _ -> assert false
145

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

155
156
and run_disp_kind actions v =
  match v with
157
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
158
  | Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
159
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
160
  | String_latin1 (i,j,s,q) -> run_disp_string_latin1 i j s q actions
161
  | String_utf8 (i,j,s,q) -> run_disp_string_utf8 i j s q actions
162
163
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
164
  | Integer i ->
165
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
166
167
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
168
        actions.basic
169
170
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
171
  | Delayed _ -> assert false
172
173


174
and run_disp_prod v v1 v2 = function
175
176
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
177
  | Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
178
  | Dispatch (d1,b1) ->
179
180
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
181
182
      run_disp_prod2 v1 r1 v v2 b1.(code1)

183
and run_disp_prod2 v1 r1 v v2 = function
184
  | Impossible -> assert false
185
  | Ignore r -> make_result_prod v1 r1 v2 !cursor v r
186
187
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
188
189
      let r2 = !cursor in
      let code2 = run_dispatcher d2 v2 in
190
      make_result_prod v1 r1 v2 r2 v b2.(code2)
191

192
and run_disp_record other v fields = function
193
  | None -> assert false
194
  | Some (RecLabel (l,d)) ->
195
196
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
197
	| (l1,vl) :: rem when l1 == l ->
198
199
200
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
201
      in
202
      aux other fields
203
  | Some (RecNolabel (some,none)) ->
204
205
206
207
208
209
210
211
      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
212
  | Ignore d2 ->  run_disp_record2 other v1 !cursor rem d2
213
  | Dispatch (d1,b1) ->
214
215
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
216
      run_disp_record2 other v1 r1 rem b1.(code1)
217

218
and run_disp_record2 other v1 r1 rem = function
219
  | Impossible -> assert false
220
  | Ignore r -> make_result_prod v1 r1 Absent 0 Absent r
221
222
  | TailCall d2 -> run_disp_record_loop other rem d2
  | Dispatch (d2,b2) ->
223
224
      let r2 = !cursor in
      let code2 = run_disp_record_loop other rem d2 in
225
226
227
228
229
      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
230
    | AKind k -> run_disp_record other Absent rem k.record
231
  
232

233
and run_disp_string_latin1 i j s q actions = 
234
  if i == j then run_disp_kind actions q 
235
236
  else match actions.prod with
    | Impossible -> assert false
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
    | TailCall d1 -> run_disp_string_latin1_char d1 (Chars.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.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.mk_int (Utf8.get s i))
    | Ignore d2 -> run_disp_string_utf8_2 !cursor i j s q d2
267
    | Dispatch (d1,b1) ->
268
	let r1 = !cursor in
269
270
271
	let code1 = run_disp_string_utf8_char d1 (Chars.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 =
272
273
  match actions d with
    | AIgnore r -> make_result_char ch r
274
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
275
and run_disp_string_utf8_2 r1 i j s q = function
276
277
  | Impossible -> assert false
  | Ignore r -> 
278
279
      make_result_string_utf8 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_utf8_loop i j s q d2
280
  | Dispatch (d2,b2) ->
281
      let r2 = !cursor in
282
283
284
      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 =
285
286
  match actions d with
    | AIgnore r -> make_result_basic Absent r
287
    | AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
288
289
290

let run_dispatcher d v =
  let code = run_dispatcher d v in
291
292
293
  cursor := 0;
  (code,!buffer) 
(*  let r = Array.create !cursor Absent in
294
295
  blit !buffer 0 r 0 !cursor;
  cursor := 0;
296
  (code,r) *)
297
298
    

299
  
300
301
302
303
304
305
306
(*
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)
307

308
309
310
311
312
313

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


*)