patterns.ml 33.9 KB
Newer Older
1
exception Error of string
2
open Ident
3

4
(* Syntactic algebra *)
5
(* Constraint: any node except Constr has fv<>[] ... *)
6
type d =
7
  | Constr of Types.descr
8
  | Cup of descr * descr
9
  | Cap of descr * descr
10
  | Times of node * node
11
  | Xml of node * node
12
  | Record of Types.label * node
13
14
  | Capture of id
  | Constant of id * Types.const
15
16
and node = {
  id : int;
17
18
  mutable descr : descr option;
  accept : Types.node;
19
  fv : fv
20
} and descr = Types.descr * fv * d
21

22
23
24
25
let id x = x.id
let descr x = match x.descr with Some d -> d | None -> failwith "Patterns.descr"
let fv x = x.fv
let accept x = Types.internalize x.accept
26
27
28

let printed = ref []
let to_print = ref []
29
30
let rec print ppf (a,_,d) = 
(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
31
32
33
34
35
36
37
38
39
40
41
42
43
44
  match d with
    | Constr t -> Types.Print.print_descr ppf t
    | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
    | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
    | Times (n1,n2) -> 
	Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Xml (n1,n2) -> 
	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Record (l,n) -> 
	Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
	to_print := n :: !to_print
    | Capture x ->
45
	Format.fprintf ppf "%s" (Id.value x)
46
    | Constant (x,c) ->
47
48
	Format.fprintf ppf "(%s := %a)" (Id.value x) 
	  Types.Print.print_const c
49

50
51
52
53
54
55
56
57
58
59
60
61
62
let dump_print ppf =
  while !to_print <> [] do
    let p = List.hd !to_print in
    to_print := List.tl !to_print;
    if not (List.mem p.id !printed) then
      ( printed := p.id :: !printed;
	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
      )
  done

let print ppf d =
  Format.fprintf ppf "%a@\n" print d;
  dump_print ppf
63
64


65
66
67
68
69
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
70
71

let define x ((accept,fv,_) as d) =
72
  assert (x.fv = fv);
73
  Types.define x.accept accept;
74
  x.descr <- Some d
75

76
let constr x = (x,IdSet.empty,Constr x)
77
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
78
79
80
81
82
  if not (IdSet.equal fv1 fv2) then (
    let x = match IdSet.pick (IdSet.diff fv1 fv2) with
      | Some x -> x
      | None -> match IdSet.pick (IdSet.diff fv2 fv1) with Some x -> x 
	  | None -> assert false
83
84
85
    in
    raise 
      (Error 
86
	 ("The capture variable " ^ (Id.value x) ^ 
87
88
	  " should appear on both side of this | pattern"))
  );
89
  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
90
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
91
92
93
  if not (IdSet.disjoint fv1 fv2) then (
    match IdSet.pick (IdSet.cap fv1 fv2) with
      | Some x -> 
94
95
	  raise 
	  (Error 
96
	     ("The capture variable " ^ (Id.value x) ^ 
97
	      " cannot appear on both side of this & pattern"))
98
      | None -> assert false
99
  );
100
  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
101
let times x y =
102
  (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
103
let xml x y =
104
  (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
105
let record l x = 
106
  (Types.record l false x.accept, x.fv, Record (l,x))
107
108
let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
109

110

111

112
113
114
115

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
116
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
117
118
119
let times_res v1 v2 = Types.Positive.times v1 v2

module MemoFilter = Map.Make 
120
  (struct type t = Types.descr * node let compare = compare end)
121
122
123

let memo_filter = ref MemoFilter.empty

124
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
125
(* TODO: avoid is_empty t when t is not changing (Cap) *)
126
127
128
129
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
130
      | Constr _ -> IdMap.empty
131
      | Cup ((a,_,_) as d1,d2) ->
132
	  IdMap.merge cup_res
133
134
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
135
      | Cap (d1,d2) ->
136
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
137
138
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
139
140
141
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
142
	  IdMap.singleton c (Types.Positive.ty t)
143
      | Constant (c, cst) ->
144
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
145

146
147
148
149
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
150
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
151
       in
152
       IdMap.merge cup_res accu term
153
154
155
156
157
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


158
and filter_node t p : Types.Positive.v id_map =
159
160
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
161
    let (_,fv,_) as d = descr p in
162
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
163
164
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
165
    IdMap.collide Types.Positive.define res r;
166
167
168
169
170
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
171
  IdMap.get (IdMap.map Types.Positive.solve r)
172
173


174
(* Normal forms for patterns and compilation *)
175

176
177
178
179
180
module Normal : sig 
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
181
182
183
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
    | SField of Types.label 
184
  type result = source id_map
185
186
187
188
189

  type nnf = node sl * Types.descr
  type 'a nline = (result *  'a) list
  type record =
      [ `Success
190
191
      | `SomeField
      | `NoField
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
      | `Fail
      | `Dispatch of (nnf * record) list
      | `Label of Types.label * (nnf * record) list * record ]
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
    nrecord: record nline
  }

  val any_basic: Types.descr
  val normal: Types.descr -> node list -> t
end = 
208
struct
209
210
211
212
213
214
  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
			       [Types.Product.any_xml;
				Types.Product.any;
				Types.Record.any])


215
216
217
218
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
219
220
221
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
    | SField of Types.label 
222
  type result = source id_map
223
224
225

  type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
  type 'a nline = (result *  'a) sl
226
227
  type record =
      [ `Success
228
229
      | `SomeField
      | `NoField
230
      | `Fail
231
232
      | `Dispatch of (nnf * record) list
      | `Label of Types.label * (nnf * record) list * record ]
233
  type t = {
234
    nfv    : fv;
235
    ncatchv: fv;
236
    na     : Types.descr;
237
    nbasic : Types.descr nline;
238
239
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
240
    nrecord: record nline
241
  }
242

243
244
245
246
247
248
249
250
251
252
253
  let rec print_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `SomeField -> Format.fprintf ppf "SomeField"
    | `NoField -> Format.fprintf ppf "NoField"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Dispatch _ -> Format.fprintf ppf "Dispatch"
    | `Label (l,pr,ab) ->
	Format.fprintf ppf "Label(%s@[" (Types.LabelPool.value l);
	List.iter (fun (_,r) -> Format.fprintf ppf ",%a" print_record r) pr;
	Format.fprintf ppf ",%a@])" print_record ab

254
  let fus = IdMap.union_disj
255
  let slcup = SortedList.cup
256

257
258
  let nempty = { nfv = IdSet.empty; ncatchv = IdSet.empty; 
		 na = Types.empty;
259
260
261
262
263
264
265
		 nbasic = []; nprod = []; nxml = []; nrecord = [] }


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
266
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
      na      = Types.cup nf1.na nf2.na;
      nbasic  = SortedList.cup nf1.nbasic nf2.nbasic;
      nprod   = SortedList.cup nf1.nprod nf2.nprod;
      nxml    = SortedList.cup nf1.nxml nf2.nxml;
      nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
    }

  let double_fold f l1 l2 =
    SortedList.from_list
      (List.fold_left 
	 (fun accu x1 ->
	    List.fold_left
	    (fun accu x2 ->
	       f accu x1 x2
	    )
	    accu l2
	 ) [] l1)
	 
  let ncap nf1 nf2 =
    let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	let s = Types.cap s1 s2  in
	if Types.is_empty s then accu else
	  (fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
    in
    let basic accu (res1,t1) (res2,t2) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	(fus res1 res2, t) :: accu
    in
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
    let record accu (res1,rec1) (res2,rec2) =
      let rec aux extra1 rec1 extra2 rec2 = 
	let rec1 =
	  if extra1 then
	    match rec1 with 
	      | `SomeField -> `Success
	      | `NoField -> `Fail
	      | x -> x
	  else rec1
	and rec2 = 
	  if extra2 then
	    match rec2 with 
	      | `SomeField -> `Success
	      | `NoField -> `Fail
	      | x -> x
	  else rec2
	in
	match (rec1,rec2) with
	| `Success, r | r, `Success -> r
	| `Fail, _ | _, `Fail -> `Fail

	| `SomeField, `Label (l, pr, ab) ->
	    (match aux false `SomeField extra2 ab with
	       | `Fail when pr = [] -> `Fail
	       | ab -> `Label (l, pr, ab))
	| `Label (l, pr, ab), `SomeField ->
	    (match aux false `SomeField extra1 ab with
	       | `Fail when pr = [] -> `Fail
	       | ab -> `Label (l, pr, ab))

	| `NoField, `Label (l,pr,ab) ->
	    (match aux false `NoField extra2 ab with 
	       | `Fail -> `Fail 
	       | ab -> `Label (l, [], ab))

	| `Label (l, pr, ab), `NoField ->
	    (match aux false `NoField extra1 ab with 
	       | `Fail -> `Fail 
	       | ab -> `Label (l, [], ab))

	| `SomeField, `NoField | `NoField,`SomeField -> 
	    `Fail
	| `NoField, `NoField -> `NoField
	| `SomeField, `SomeField -> `SomeField
	| `Label (l1,pr1,ab1), `Label (l2,pr2,ab2) ->
(*TODO: eliminate `Fail *)
	    if (l1 < l2) then
	      `Label (l1, 
		      List.map (fun (d,r) -> (d, aux extra1 r true rec2)) pr1,
		      aux extra1 ab1 extra2 rec2)
	    else if (l2 < l1) then
	      `Label (l2, 
		      List.map (fun (d,r) -> (d, aux extra2 r true rec1)) pr2,
		      aux extra2 ab2 extra1 rec1)
	    else
	      let pr = 
		double_fold
		  (fun accu ((d1,t1),r1) ((d2,t2),r2) ->
		     let r = aux extra1 r1 extra2 r2 in
		     match r with 
		       | `Fail -> accu 
		       | x -> ((slcup d1 d2, Types.cap t1 t2),x)::accu)
		  pr1 pr2 in
	      `Label (l1, pr, aux extra1 ab1 extra2 ab2)
	| `Dispatch _, _ | _, `Dispatch _ -> assert false in
      let res = aux false rec1 false rec2 in
(*      Format.fprintf Format.std_formatter 
	"ncap; @\nrecord1=%a; @\nrecord2=%a;@\n result=%a@\n"
	print_record rec1
	print_record rec2
	print_record res; *)
      match res with
	| `Fail -> accu
	| r -> (fus res1 res2, r) :: accu
    in
373
374
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
375
376
377
378
      na = Types.cap nf1.na nf2.na;
      nbasic = double_fold basic nf1.nbasic nf2.nbasic;
      nprod = double_fold prod nf1.nprod nf2.nprod;
      nxml = double_fold prod nf1.nxml nf2.nxml;
379
      nrecord = double_fold record nf1.nrecord nf2.nrecord;
380
381
    }

382
  let nnode p = [p], Types.descr p.accept
383
  let empty_res = IdMap.empty
384

385
  let ntimes acc p q = 
386
387
388
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
389
    { nempty with 
390
	nfv = IdSet.cup p.fv q.fv; 
391
	na = acc;
392
393
394
395
	nprod = [ (src, (nnode p, nnode q)) ];
    }

  let nxml acc p q = 
396
397
398
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
399
    { nempty with 
400
	nfv = IdSet.cup p.fv q.fv; 
401
402
	na = acc;
	nxml =  [ (src, (nnode p, nnode q)) ];
403
404
    }
    
405
  let nrecord acc l p =
406
    let src = IdMap.constant (SField l) p.fv in
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
    let r = Types.Record.normal acc in
    { nempty with
	nfv = p.fv;
	na = acc;
	nrecord = [ src, `Label (l,[nnode p, `Success],`Fail) ] }

  let nconstr t =
    let rec aux_record = function
      | `Success -> `Success
      | `Fail -> `Fail
      | `NoField -> `NoField
      | `SomeField -> `SomeField
      | `Label (l, pr, ab) ->
	  `Label (l, 
		  List.map (fun (t,r) -> ([],t), aux_record r) pr,
		  aux_record ab) in
    { nempty with
	na = t;
425
	nbasic = [ empty_res, Types.cap t any_basic ];
426
427
	nprod = 
	  List.map 
428
	    (fun (t1,t2) -> empty_res, (([],t1),([],t2)))
429
430
431
	    (Types.Product.normal t);
	nxml= 
	  List.map 
432
	    (fun (t1,t2) -> empty_res, (([],t1),([],t2)))
433
	    (Types.Product.normal ~kind:`XML t);
434
	nrecord = [ empty_res, aux_record (Types.Record.normal t) ]
435
436
437
    }

  let nconstant x c = 
438
439
440
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
441
442
443
444
445
446
447
448
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
      nrecord = [ (l,`Success) ];
    }

  let ncapture x = 
449
450
451
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
      nrecord = [ (l,`Success) ];
    }

  let rec nnormal (acc,fv,d) =
    if Types.is_empty acc 
    then nempty
    else match d with
      | Constr t -> nconstr t
      | Cap (p,q) -> ncap (nnormal p) (nnormal q)
      | Cup ((acc1,_,_) as p,q) -> 
	  ncup (nnormal p) (ncap (nnormal q) (nconstr (Types.neg acc1)))
      | Times (p,q) -> ntimes acc p q
      | Xml (p,q) -> nxml acc p q
      | Capture x -> ncapture x
      | Constant (x,c) -> nconstant x c
      | Record (l,p) -> nrecord acc l p
   
  let remove_catchv n =
    let ncv = n.ncatchv in
    let nlines l = 
476
      let l = List.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
477
478
(*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
      l in
479
    { nfv     = IdSet.diff n.nfv ncv;
480
481
482
483
484
485
486
487
488
489
490
      ncatchv = n.ncatchv;
      na      = n.na;
      nbasic  = nlines n.nbasic;
      nprod   = nlines n.nprod;
      nxml    = nlines n.nxml;
      nrecord = nlines n.nrecord;
    }

  let normal t pl =
    remove_catchv
      (List.fold_left (fun a p -> ncap a (nnormal (descr p))) (nconstr t) pl)
491
end
492
493


494
495
module Compile = 
struct
496
  type actions =
497
498
    | AIgnore of result
    | AKind of actions_kind
499
  and actions_kind = {
500
501
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
502
    xml: result dispatch dispatch;
503
504
505
506
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
507
      | `Result of result
508
      | `Result_other of Types.label list * result * result ]
509
      
510
  and 'a dispatch =
511
512
513
514
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
515
516

  and result = int * source array
517
  and source = 
518
519
520
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
    | Field of Types.label * int
521
522
523
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
524
      (int * int id_map) list
525
526

  and interface =
527
528
    [ `Result of int
    | `Switch of interface * interface
529
530
531
532
533
534
535
536
537
538
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
    interface : interface;
    codes : return_code array;
    mutable actions : actions option
  }
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553

  let array_for_all f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f a.(i) && (aux f a (succ i))
    in
    aux f a 0

  let array_for_all_i f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

554
  let combine_kind basic prod xml record =
555
556
557
558
559
560
561
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
562
563
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
564
	| _ -> raise Exit in
565
      let rs = match xml with
566
567
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
568
	| _ -> raise Exit in
569
570
571
572
573
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
574
575
576
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
577
578
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
579
580
	| _ -> raise Exit
    )
581
    with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }
582

583
  let combine (disp,act) =
584
    if Array.length act = 0 then Impossible
585
586
587
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
588
	   Ignore act.(0)
589
      else
590
	Dispatch (disp, act)
591
592
593

  let combine_record l present absent = 
    match (present,absent) with
594
      | (Ignore r1, Some r2) when r1 = r2 -> r1
595
596
597
598
599
600
601
602
603
(*      | (`Ignore r, None) -> r  *)
(* Could allow this when r has no `Result_other ... *)
(* Otherwise:
debug compile {| x = Int; y =? Int |} {| x = Any |};;
[DEBUG:compile]
let disp_0 = function
 | Record -> 
     [x ]SomeField:$0;NoField:$1
*)
604
      | (Impossible, Some r) -> r
605
606
607
      | _ -> `Label (l, present, absent)

  let detect_right_tail_call = function
608
    | Dispatch (disp,branches) 
609
610
611
612
613
614
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
615
		     function Right j when pos = j -> true | _ -> false)
616
617
618
		  ret
	       )
	    ) branches
619
	  -> TailCall disp
620
621
622
    | x -> x

  let detect_left_tail_call = function
623
    | Dispatch (disp,branches)
624
625
626
627
	when
	  array_for_all_i
	    (fun i -> 
	       function 
628
		 | Ignore (code,ret) ->
629
630
631
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
632
			   function Left j when pos = j -> true | _ -> false)
633
634
635
636
637
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
638
	 TailCall disp
639
640
    | x -> x
   
641
642
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
643
		 
644
645
  module DispMap = Map.Make(
    struct
646
      type t = Types.descr * Normal.t array
647
648
649
      let compare = compare
    end
  )
650
    
651
  let dispatchers = ref DispMap.empty
652
		      
653
654
655
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
656
      let nb = ref 0 in
657
658
      let codes = ref [] in
      let rec aux t arity i accu = 
659
660
	if Types.is_empty t then `None
	else
661
	  if i = Array.length pl 
662
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
663
664
	  else
	    let p = pl.(i) in
665
	    let tp = p.Normal.na in
666
667
668
669
	    assert(IdSet.disjoint p.Normal.nfv p.Normal.ncatchv);
	    let v = p.Normal.nfv in
(*	    let v = IdSet.diff p.Normal.nfv p.Normal.ncatchv in*)

670
(*	    let tp = Types.normalize tp in *)
671
	    let accu' = (i,IdMap.num arity v) :: accu in
672
	    `Switch 
673
	      (
674
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
675
	       aux (Types.diff t tp) arity (i+1) accu
676
677
	      )
      in
678
      let iface = aux t 0 0 [] in
679
680
681
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
682
		  interface = iface;
683
		  codes = Array.of_list (List.rev !codes);
684
685
686
687
688
		  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
689
690
  let find_code d a =
    let rec aux i = function
691
692
693
694
      | `Result code -> code
      | `None -> assert false
      | `Switch (yes,_) when a.(i) <> None -> aux (i + 1) yes
      | `Switch (_,no) -> aux (i + 1) no
695
696
697
698
    in
    aux 0 d.interface

  let create_result pl =
699
700
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
701
702
703
704
705
706

  let return disp pl f =
    let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
    let final = Array.map aux pl in
    (find_code disp final, create_result final)
    
707
  let conv_source_basic s = match s with
708
709
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
710
711
    | _ -> assert false

712
  let assoc v l =
713
    try IdMap.assoc v l with Not_found -> -1
714

715
  let conv_source_prod left right v s = match s with
716
717
718
719
720
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | Normal.SLeft -> Left (assoc v left)
    | Normal.SRight -> Right (assoc v right)
    | Normal.SRecompose -> Recompose (assoc v left, assoc v right)
721
    | _ -> assert false
722

723
  let conv_source_record catch v s = match s with
724
725
726
727
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | Normal.SField l -> 
	Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
728
729
730
731
    | _ -> assert false


  let dispatch_basic disp : (Types.descr * result) list =
732
(* TODO: try other algo, using disp.codes .... *)
733
734
735
736
737
738
739
740
    let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in
    let tests =
      let accu = ref [] in
      let aux i (res,x) = accu := (x, [i,res]) :: !accu in
      Array.iteri (fun i -> List.iter (aux i)) pl;
      SortedMap.from_list SortedList.cup !accu in

    let t = Types.cap Normal.any_basic disp.t in
741
    let accu = ref [] in
742
    let rec aux (success : (int * Normal.result) list) t l = 
743
744
745
      if Types.non_empty t 
      then match l with
	| [] ->
746
747
748
749
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
750
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
751
752
753
754
	    accu := (t, return disp selected aux_final) :: !accu
	| (ty,i) :: rem -> 
	    aux (i @ success) (Types.cap t ty) rem; 
	    aux success (Types.diff t ty) rem
755
    in
756
    aux [] t tests;
757
758
759
    !accu


760
  let get_tests pl f t d post =
761
762
763
764
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
765
766
      List.iter (fun ( (pl,ty), info) ->
		   let p = Normal.normal ty pl in
767
		   accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
768
769
770
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
771

772
773
774
    let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
    let infos = Array.map snd sorted in
    let disp = dispatcher t (Array.map fst sorted) in
775
    let result (t,_,m) =
776
      let selected = Array.create (Array.length pl) [] in
777
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
778
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
779
780
      d t selected unselect
    in
781
    let res = Array.map result disp.codes in
782
783
    post (disp,res)

784

785
786
787
788
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
789
	   let p' = ([p],t) in
790
791
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
792
	) (t,[]) brs in
793
	
794
795
796
797
798
799
800
801
    let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
    get_tests 
      pl 
      (fun x -> [x],[])
      t
      (fun _ pl _ ->
	 let r = ref None in
	 let aux = function 
802
	   | [(res,catchv,e)] -> assert (!r = None); 
803
804
	       let catchv = IdMap.constant (-1) catchv in
	       r := Some (IdMap.union_disj catchv res,e)
805
806
807
808
809
810
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
811
812


813
814
815
816
817
818
819
  let rec dispatch_prod ?(kind=`Normal) disp =
    let pl = 
      match kind with
	| `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
	| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
    in
    let t = Types.Product.get ~kind disp.t in
820
821
822
823
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
824
      (fun x -> detect_left_tail_call (combine x))
825
826
827
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
828
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
829
830
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
831
      (fun x -> detect_right_tail_call (combine x))
832
  and dispatch_prod2 disp t t2 pl _ =
833
    let aux_final (ret2, ncatchv, (ret1, res)) =  
834
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
835
    return disp pl aux_final
836
837


838
  let dummy_label = Types.LabelPool.dummy_max
839
840
841
842

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
843
      | (_, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
844
845
      | _ -> () in
    Array.iter (List.iter aux) pl;
846
    if !m = dummy_label then None else Some !m
847
848
849
850

  let map_record f = 
    let rec aux = function
      | [] -> []
851
852
      | (res,catch,h)::t -> 
	  (match f h with `Fail -> aux t | x -> (res,catch,x) :: (aux t)) in
853
854
855
856
857
    Array.map aux

  let label_found l = 
    map_record 
      (function
858
	 | `Label (l1, pr, _) when l1 = l -> `Dispatch pr
859
860
861
862
863
	 | x -> x)

  let label_not_found l = 
    map_record 
      (function
864
	 | `Label (l1, _, ab) when l1 = l -> ab
865
866
	 | x -> x)

867
(*
868
869
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
870
*)
871
872
873
874
875

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
876
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
	   print_normal_record_pr pr
	   print_normal_record ab
    | _ -> assert false
  and print_normal_record_pr ppf =
    List.iter (fun (nf,r) ->
		 Format.fprintf ppf "[_,%a]"
		  print_normal_record r) 
  let dump_dr ppf pl =
    Array.iteri
      (fun i x ->
	 Format.fprintf ppf "[%i:]" i;
	 List.iter
	   (fun (res,catch,nr) ->
	      Format.fprintf ppf "Result:";
	      List.iter (fun (x,s) -> Format.fprintf ppf "%s," x) res;
    	      Format.fprintf ppf "Catch:";
	      List.iter (fun (l,r) -> 
894
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
895
896
897
898
899
900
901
902
903
			   List.iter (fun (x,i) -> 
					Format.fprintf ppf "%s->%i" x i) r;
			   Format.fprintf ppf "]"
			) catch;
    	      Format.fprintf ppf "NR:%a" print_normal_record nr
	   ) x;
	 Format.fprintf ppf "@\n"
      ) pl

904
  let rec dispatch_record disp : record option =
905
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
906
907
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
908
    let r = dispatch_record_opt disp t pl0 [] in
909
(*    memo_dispatch_record := []; *)
910
    r
911
  and dispatch_record_opt disp t pl labs =
912
    if Types.Record.is_empty t then None 
913
    else Some (dispatch_record_label disp t pl labs)
914
915
916
917
918
919
920
921
922
923
924
(*  and dispatch_record_label disp t pl =
    try List.assoc (t,pl) !memo_dispatch_record
    with Not_found ->
      (*       Format.fprintf Format.std_formatter "%a@\n" 
	       Types.Print.print_descr (Types.Record.descr t);
	       dump_dr Format.std_formatter pl; *)
      let r = dispatch_record_label' disp t pl in 
      incr memo_dr_count;
      let r = !memo_dr_count, r in 
      memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
      r *)
925
  and dispatch_record_label disp t pl labs =
926
927
    match collect_first_label pl with
      | None -> 
928
	  let aux_final (res, catch, x) =
929
	    assert (x = `Success); 
930
	    IdMap.mapi_to_list (conv_source_record catch) res 
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
	  in
	  let somefield = 
	    if Types.Record.somefield_possible t then
	      let aux = function `Success | `SomeField -> `Success | _ -> `Fail in
	      Some (return disp (map_record aux pl) aux_final)
	    else None
	  in
	  let nofield = 
	    if Types.Record.nofield_possible t then 
	      let aux = function `Success | `NoField -> `Success | _ -> `Fail in
	      Some (return disp (map_record aux pl) aux_final)
	    else None
	  in
	  (match (somefield,nofield) with
	     | Some r1, Some r2 -> 
946
		 if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
947
948
949
	     | Some r1, None -> `Result r1
	     | None, Some r2 -> `Result r2
	     | _ -> assert false)
950
      | Some l ->
951
952
953
	  let (plabs,absent) = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
954
	    pl, dispatch_record_opt disp t pl labs
955
	  in
956
	  let present =
957
	    let labs = l :: labs in
958
959
	    let pl = label_found l pl in
	    let t = Types.Record.restrict_label_present t l in
960
	    if Types.Record.is_empty t then Impossible else 
961
962
963
964
965
966
967
968
	      get_tests pl
		(function 
		   | (res,catch, `Dispatch d) -> 
		       List.map (fun (p, r) -> p, (res, catch, r)) d, []
		   | x -> [],[x])
		(Types.Record.project_field t l)
		(dispatch_record_field l disp t plabs labs)
		(fun x -> combine x)
969
	  in
970
971
	  combine_record l present absent
  and dispatch_record_field l disp t plabs labs tfield pl others =
972
    let t = Types.Record.restrict_field t l tfield in
973
    let aux (ret, ncatchv, (res, catch, rem)) = 
974
      let catch = if IdMap.is_empty ret then catch else (l,ret) :: catch in
975
      (res, catch, rem) in
976
977
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
978
(*    if pl = plabs then `Absent else  *)
979
      (* TODO: Check that this is the good condition ....
980
981
982
983
984
985
986
987
988
	 Need condition on t ?

	 No, it isn't a good condition:
	 match { x = "a" } : { x =? "a"|"b" } with
	 | { x = "b" } -> 1
	 | _  -> 0;;
	 Need to investigate ....
      *)
	 
989
    dispatch_record_label disp t pl labs
990
    
991
      
992
993
994
995
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
996
997
998
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
999
		    (dispatch_prod ~kind:`XML disp)