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

12
13
14
15
16
17
18
19

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


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

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

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

69

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

86
87
let tail_string i j s q =
  if i + 1 = j then q else String (i + 1,j,s,q)
88

89
let make_result_string i j s q r1 r2 (code,r) = 
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
  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;
106
  if r1 <> !cursor then blit buf !cursor buf r1 n;
107
108
  cursor := r1 + n;
  code )
109
110


111
112
113
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
114
  | _ -> assert false
115

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

125
126
and run_disp_kind actions v =
  match v with
127
128
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
129
  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
130
  | String (i,j,s,q) -> run_disp_string i j s q actions
131
132
  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
133
  | Integer i ->
134
      run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
135
136
  | Abstraction (iface,_) ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
137
        actions.basic
138
139
  | Absent ->
      run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
140
(*  | v ->
141
      run_disp_kind actions (normalize v) 
142
*)
143
144


145
and run_disp_prod v v1 v2 = function
146
147
  | Impossible -> assert false
  | TailCall d1 -> run_dispatcher d1 v1
148
  | Ignore d2 -> run_disp_prod2 v1 !cursor v v2 d2
149
  | Dispatch (d1,b1) ->
150
151
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
152
153
      run_disp_prod2 v1 r1 v v2 b1.(code1)

154
and run_disp_prod2 v1 r1 v v2 = function
155
  | Impossible -> assert false
156
  | Ignore r -> make_result_prod v1 r1 v2 !cursor v r
157
158
  | TailCall d2 -> run_dispatcher d2 v2
  | Dispatch (d2,b2) ->
159
160
      let r2 = !cursor in
      let code2 = run_dispatcher d2 v2 in
161
162
      make_result_prod v1 r1 v2 r2 v b2.(code2)
	    
163
and run_disp_record other v fields = function
164
  | None -> assert false
165
  | Some (RecLabel (l,d)) ->
166
167
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
168
169
170
171
	| (l1,vl) :: rem when l1 = l ->
	    run_disp_record1 other vl rem d
	| rem -> 
	    run_disp_record1 other Absent rem d
172
      in
173
      aux other fields
174
  | Some (RecNolabel (some,none)) ->
175
176
177
178
179
180
181
182
      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
183
  | Ignore d2 ->  run_disp_record2 other v1 !cursor rem d2
184
  | Dispatch (d1,b1) ->
185
186
      let r1 = !cursor in
      let code1 = run_dispatcher d1 v1 in
187
      run_disp_record2 other v1 r1 rem b1.(code1)
188

189
and run_disp_record2 other v1 r1 rem = function
190
  | Impossible -> assert false
191
  | Ignore r -> make_result_prod v1 r1 Absent 0 Absent r
192
193
  | TailCall d2 -> run_disp_record_loop other rem d2
  | Dispatch (d2,b2) ->
194
195
      let r2 = !cursor in
      let code2 = run_disp_record_loop other rem d2 in
196
197
198
199
200
      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
201
    | AKind k -> run_disp_record other Absent rem k.record
202
  
203
204
205
206
207
208

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])
209
    | Ignore d2 -> run_disp_string2 !cursor i j s q d2
210
    | Dispatch (d1,b1) ->
211
212
	let r1 = !cursor in
	let code1 = run_disp_string_char d1 (Chars.mk_char s.[i]) in
213
214
215
216
	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
217
    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
218
219
220
and run_disp_string2 r1 i j s q = function
  | Impossible -> assert false
  | Ignore r -> 
221
      make_result_string i j s q r1 0 r
222
223
  | TailCall d2 -> run_disp_string_loop i j s q d2
  | Dispatch (d2,b2) ->
224
225
      let r2 = !cursor in
      let code2 = run_disp_string_loop i j s q d2 in
226
      make_result_string i j s q r1 r2 b2.(code2)
227
228
229
230
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
231
232
233

let run_dispatcher d v =
  let code = run_dispatcher d v in
234
(* for unknown reasons, it seems to be faster to copy the interesting prefix... *)
235
236
237
238
239
240
241
242
(*  cursor := 0;
  (code,!buffer) *)
  let r = Array.create !cursor Absent in
  blit !buffer 0 r 0 !cursor;
  cursor := 0;
  (code,r)
    

243
  
244
245
246
247
248
249
250
(*
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)
251

252
253
254
255
256
257

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


*)