run_dispatch.ml 10.4 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


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'
35
36
37
38
39
40
41
42

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


(* Old dispatchers *)
43
    
44
let make_result_prod v1 v2 v (code,r,pop) = 
45
  let n = Array.length r in
46
  if n > 0 then (
47
48
  ensure_room n;
  let buf = !buffer in
49
  let c = !cursor in
50
51
52
53
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
      | Catch -> v
      | Const c -> const c
54
55
56
57
      | Nil -> nil
      | Left -> v1
      | Right -> v2
      | Stack i -> buf.(c - i)
58
      | Recompose (i,j) -> 
59
	  Pair (
60
61
	    (match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(c - i)),
	    (match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(c - j))
62
	  )
63
    in
64
    buf.(c + a) <- x
65
  done;
66
67
68
  if pop != 0 then blit buf c buf (c - pop) n);
  cursor := !cursor - pop + n;  (* clean space for GC ? *)
  code
69

70
let make_result_basic v (code,r,_) = 
71
  let n = Array.length r in
72
  if n > 0 then (
73
74
75
76
77
78
79
80
  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
81
82
    buf.(!cursor) <- x;
    incr cursor
83
84
  done);
  code
85

86

87
let make_result_char ch (code,r,_) = 
88
  let n = Array.length r in
89
  if n > 0 then (
90
91
92
93
94
95
96
97
98
99
  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;
100
101
  cursor := !cursor + n);
  code
102

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

106
let make_result_string_latin1 i j s q (code,r,pop) = 
107
  let n = Array.length r in
108
  if n > 0 then (
109
  ensure_room n;
110
  let c = !cursor in
111
112
113
  let buf = !buffer in
  for a = 0 to n - 1 do
    let x = match Array.unsafe_get r a with
114
      | Catch -> String_latin1 (i,j,s,q)
115
      | Const c -> const c
116
117
118
119
      | Nil -> nil
      | Left -> Char (Chars.V.mk_char s.[i])
      | Right -> tail_string_latin1 i j s q
      | Stack n -> buf.(c - n)
120
      | Recompose (n,m) -> 
121
122
123
124
	  Pair (
	    (match n with 
	       | (-1) -> Char (Chars.V.mk_char s.[i]) 
	       | (-2) -> nil 
125
	       | _ -> buf.(c - n)),
126
127
128
	    (match m with 
	       | (-1) -> tail_string_latin1 i j s q 
	       | (-2) -> nil 
129
	       | _ -> buf.(c - m))
130
	  )
131
    in
132
    buf.(c + a) <- x
133
  done;
134
135
136
  if pop != 0 then blit buf c buf (c - pop) n);
  cursor := !cursor - pop + n;
  code
137

138
139
140
141
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)

142
let make_result_string_utf8 i j s q (code,r,pop) = 
143
  let n = Array.length r in
144
  if n > 0 then (
145
  ensure_room n;
146
  let c = !cursor in
147
148
149
150
151
  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
152
153
154
155
      | Nil -> nil
      | Left -> Char (Chars.V.mk_int (Utf8.get s i))
      | Right -> tail_string_utf8 i j s q 
      | Stack n -> buf.(c - n)
156
      | Recompose (n,m) -> 
157
158
159
160
	  Pair (
	    (match n with 
	       | (-1) -> Char (Chars.V.mk_int (Utf8.get s i)) 
	       | (-2) -> nil 
161
	       | _ -> buf.(c - n)),
162
163
164
	    (match m with 
	       | (-1) -> tail_string_utf8 i j s q 
	       | (-2) -> nil 
165
	       | _ -> buf.(c - m))
166
	  )
167
    in
168
    buf.(c + a) <- x
169
  done;
170
171
172
173
  if pop != 0 then blit buf c buf (c - pop) n;
  );
  cursor := !cursor - pop + n;
  code
174

175
176
177
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
178
179
180
  | _ ->  
      Format.fprintf Format.std_formatter "ERR: %a@." Value.print v;
      assert false
181

182
let rec run_dispatcher d v = 
183
184
185
(*  Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v;
  Patterns.Compile.print_dispatcher Format.std_formatter d;  *)

186
187
188
  match actions d with
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_kind k v
189

190
191
and run_disp_kind actions v =
  match v with
192
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
193
194
  | Xml (v1,v2,v3) 
  | XmlNs (v1,v2,v3,_) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
195
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
196
  | String_latin1 (i,j,s,q) -> 
197
198
(*      run_disp_kind actions (Value.normalize v)  *)
       run_disp_string_latin1 i j s q actions 
199
  | String_utf8 (i,j,s,q) -> 
200
201
(*      run_disp_kind actions (Value.normalize v)  *)
 	run_disp_string_utf8 i j s q actions  
202
203
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
204
  | Integer i ->
205
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
206
207
208
209
  | Abstraction (None,_) ->
      run_disp_basic v (fun t -> failwith "Run-time inspection of external abstraction")
        actions.basic
  | Abstraction (Some iface,_)
210
  | Abstraction2 (_,iface,_) ->
211
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
212
        actions.basic
213
214
215
  | Abstract (abs,_) -> 
      run_disp_basic v (fun t -> Types.Abstract.contains abs (Types.get_abstract t))
	actions.basic
216
217
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
218
  | Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
219

220
and run_disp_prod v v1 v2 = function
221
222
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
223
  | Ignore d2 -> run_disp_prod2 v1 v v2 d2
224
  | Dispatch (d1,b1) ->
225
      let code1 = run_dispatcher d1 v1 in
226
      run_disp_prod2 v1 v v2 b1.(code1)
227

228
and run_disp_prod2 v1 v v2 = function
229
  | Impossible -> assert false
230
  | Ignore r -> make_result_prod v1 v2 v r
231
232
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
233
      let code2 = run_dispatcher d2 v2 in
234
      make_result_prod v1 v2 v b2.(code2)
235

236
and run_disp_record other v fields = function
237
  | None -> assert false
238
  | Some (RecLabel (l,d)) ->
239
240
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
241
	| (l1,vl) :: rem when l1 == l ->
242
	    run_disp_record1 v other vl rem d
243
	| rem -> 
244
	    run_disp_record1 v other Absent rem d
245
      in
246
      aux other fields
247
  | Some (RecNolabel (some,none)) ->
248
      let other = other || (fields != []) in
249
250
251
252
253
      let r = if other then some else none in
      match r with
	| Some r -> make_result_basic v r
	| None -> assert false
      
254
and run_disp_record1 v other v1 rem = function
255
256
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
257
  | Ignore d2 ->  run_disp_record2 v other v1 rem d2
258
  | Dispatch (d1,b1) ->
259
      let code1 = run_dispatcher d1 v1 in
260
      run_disp_record2 v other v1 rem b1.(code1)
261

262
and run_disp_record2 v other v1 rem = function
263
  | Impossible -> assert false
264
  | Ignore r -> make_result_prod v1 Absent v r
265
  | TailCall d2 -> run_disp_record_loop v other rem d2
266
  | Dispatch (d2,b2) ->
267
      let code2 = run_disp_record_loop v other rem d2 in
268
      make_result_prod v1 Absent v b2.(code2)
269

270
and run_disp_record_loop v other rem d =
271
  match actions d with
272
273
    | AIgnore r -> make_result_basic v r
    | AKind k -> run_disp_record other v rem k.record
274
  
275

276
and run_disp_string_latin1 i j s q actions = 
277
  if i == j then run_disp_kind actions q 
278
279
  else match actions.prod with
    | Impossible -> assert false
280
    | TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
281
    | Ignore d2 -> run_disp_string_latin1_2 i j s q d2
282
    | Dispatch (d1,b1) ->
283
	let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
284
	run_disp_string_latin1_2 i j s q b1.(code1)
285
286
287
288
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) 
289
and run_disp_string_latin1_2 i j s q = function
290
291
  | Impossible -> assert false
  | Ignore r -> 
292
      make_result_string_latin1 i j s q r
293
294
295
  | TailCall d2 -> run_disp_string_latin1_loop i j s q d2
  | Dispatch (d2,b2) ->
      let code2 = run_disp_string_latin1_loop i j s q d2 in
296
      make_result_string_latin1 i j s q b2.(code2)
297
and run_disp_string_latin1_loop i j s q d =
298
299
  let i = succ i in
  if i == j then run_dispatcher d q else
300
  match actions d with
301
302
    | AIgnore r -> make_result_basic (Value.String_latin1 (i,j,s,q)) r
    | AKind k -> run_disp_string_latin1 i j s q k
303
304

and run_disp_string_utf8 i j s q actions = 
305
306
307
  if Utf8.equal_index i j then run_disp_kind actions q
  else
  match actions.prod with
308
    | Impossible -> assert false
309
    | TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
310
    | Ignore d2 -> run_disp_string_utf8_2 i j s q d2
311
    | Dispatch (d1,b1) ->
312
	let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
313
	run_disp_string_utf8_2 i j s q b1.(code1)
314
and run_disp_string_utf8_char d ch =
315
316
  match actions d with
    | AIgnore r -> make_result_char ch r
317
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
318
and run_disp_string_utf8_2 i j s q = function
319
320
  | Impossible -> assert false
  | Ignore r -> 
321
      make_result_string_utf8 i j s q r
322
  | TailCall d2 -> run_disp_string_utf8_loop i j s q d2
323
  | Dispatch (d2,b2) ->
324
      let code2 = run_disp_string_utf8_loop i j s q d2 in
325
      make_result_string_utf8 i j s q b2.(code2)
326
and run_disp_string_utf8_loop i j s q d =
327
328
  let i = Utf8.advance s i in
  if Utf8.equal_index i j then run_dispatcher d q else
329
  match actions d with
330
331
    | AIgnore r -> make_result_basic (Value.String_utf8 (i,j,s,q)) r
    | AKind k -> run_disp_string_utf8 i j s q k
332
333
334

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

338
339
340
341
342
343
344
(*
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)
345

346
347
348
349
350
351

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


*)