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

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

8
open Value
9
open Ident
10
open Patterns.Compile
11
open Encodings
12

13
14
15
16
17
18
19
20

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
21
(* important to do this in the increasing order ... *)
22
23
24
25
26
27
28
29
30


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

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

let make_result_basic v (code,r) = 
55
56
57
58
59
60
61
62
63
64
65
66
  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;
67
  cursor := !cursor + n;
68
69
  code )

70

71
let make_result_char ch (code,r) = 
72
73
74
75
76
77
78
79
80
81
82
83
  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;
84
  cursor := !cursor + n;
85
  code )
86

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

90
let make_result_string_latin1 i j s q r1 r2 (code,r) = 
91
92
93
94
95
96
  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
97
      | Catch -> String_latin1 (i,j,s,q)
98
99
      | Const c -> const c
      | Left n -> if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)
100
      | Right m -> if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m)
101
102
      | Recompose (n,m) -> 
	  Pair ((if (n < 0) then Char (Chars.mk_char s.[i]) else buf.(r1 + n)),
103
		(if (m < 0) then tail_string_latin1 i j s q else buf.(r2 + m))) 
104
105
106
    in
    buf.(!cursor + a) <- x
  done;
107
  if r1 <> !cursor then blit buf !cursor buf r1 n;
108
109
  cursor := r1 + n;
  code )
110

111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
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.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;
  if r1 <> !cursor then blit buf !cursor buf r1 n;
  cursor := r1 + n;
  code )
135

136
137
138
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
139
  | _ -> assert false
140

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

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


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

180
and run_disp_prod2 v1 r1 v v2 = function
181
  | Impossible -> assert false
182
  | Ignore r -> make_result_prod v1 r1 v2 !cursor v r
183
184
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
185
186
      let r2 = !cursor in
      let code2 = run_dispatcher d2 v2 in
187
188
      make_result_prod v1 r1 v2 r2 v b2.(code2)
	    
189
and run_disp_record other v fields = function
190
  | None -> assert false
191
  | Some (RecLabel (l,d)) ->
192
193
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
194
195
196
197
	| (l1,vl) :: rem when l1 = l ->
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
198
      in
199
      aux other fields
200
  | Some (RecNolabel (some,none)) ->
201
202
203
204
205
206
207
208
      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
209
  | Ignore d2 ->  run_disp_record2 other v1 !cursor rem d2
210
  | Dispatch (d1,b1) ->
211
212
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
213
      run_disp_record2 other v1 r1 rem b1.(code1)
214

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

230
and run_disp_string_latin1 i j s q actions = 
231
232
233
  if i = j then run_disp_kind actions q 
  else match actions.prod with
    | Impossible -> assert false
234
235
236
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
    | 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
264
    | Dispatch (d1,b1) ->
265
	let r1 = !cursor in
266
267
268
	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 =
269
270
  match actions d with
    | AIgnore r -> make_result_char ch r
271
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
272
and run_disp_string_utf8_2 r1 i j s q = function
273
274
  | Impossible -> assert false
  | Ignore r -> 
275
276
      make_result_string_utf8 i j s q r1 0 r
  | TailCall d2 -> run_disp_string_utf8_loop i j s q d2
277
  | Dispatch (d2,b2) ->
278
      let r2 = !cursor in
279
280
281
      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 =
282
283
  match actions d with
    | AIgnore r -> make_result_basic Absent r
284
    | AKind k -> run_disp_string_utf8 (Utf8.advance s i) j s q k
285
286
287

let run_dispatcher d v =
  let code = run_dispatcher d v in
288
(* for unknown reasons, it seems to be faster to copy the interesting prefix... *)
289
290
291
292
293
294
295
296
(*  cursor := 0;
  (code,!buffer) *)
  let r = Array.create !cursor Absent in
  blit !buffer 0 r 0 !cursor;
  cursor := 0;
  (code,r)
    

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

306
307
308
309
310
311

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


*)