patterns.ml 34 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
17
18
19
20
21
and node = {
  id : int;
  mutable descr : descr option;
  accept : Types.node;
  fv : fv
} and descr = Types.descr * fv * d

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
72
73
74
75

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

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
106
let record l x = 
  (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
120
121
122
123
let times_res v1 v2 = Types.Positive.times v1 v2

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

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
161
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    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
175
(* Normal forms for patterns and compilation *)

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
    | `None ]

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

  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

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

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

  let combine_record l present absent = 
    match (present,absent) with
595
      | (Ignore r1, Some r2) when r1 = r2 -> r1
596
597
598
599
600
601
602
603
604
(*      | (`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
*)
605
      | (Impossible, Some r) -> r
606
607
608
      | _ -> `Label (l, present, absent)

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

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

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

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

  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)
    
708
  let conv_source_basic s = match s with
709
710
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
711
712
    | _ -> assert false

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

716
  let conv_source_prod left right v s = match s with
717
718
719
720
721
    | 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)
722
    | _ -> assert false
723

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


  let dispatch_basic disp : (Types.descr * result) list =
733
(* TODO: try other algo, using disp.codes .... *)
734
735
736
737
738
739
740
741
    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
742
    let accu = ref [] in
743
    let rec aux (success : (int * Normal.result) list) t l = 
744
745
746
      if Types.non_empty t 
      then match l with
	| [] ->
747
748
749
750
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
751
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
752
753
754
755
	    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
756
    in
757
    aux [] t tests;
758
759
760
    !accu


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

773
774
775
    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
776
    let result (t,_,m) =
777
      let selected = Array.create (Array.length pl) [] in
778
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
779
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
780
781
      d t selected unselect
    in
782
    let res = Array.map result disp.codes in
783
784
    post (disp,res)

785

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


814
815
816
817
818
819
820
  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
821
822
823
824
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
825
      (fun x -> detect_left_tail_call (combine x))
826
827
828
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
829
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
830
831
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
832
      (fun x -> detect_right_tail_call (combine x))
833
  and dispatch_prod2 disp t t2 pl _ =
834
    let aux_final (ret2, ncatchv, (ret1, res)) =  
835
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
836
    return disp pl aux_final
837
838


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

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

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

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

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

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

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
877
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
	   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) -> 
895
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
896
897
898
899
900
901
902
903
904
			   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

905
  let rec dispatch_record disp : record option =
906
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
907
908
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
909
    let r = dispatch_record_opt disp t pl0 [] in
910
(*    memo_dispatch_record := []; *)
911
    r
912
  and dispatch_record_opt disp t pl labs =
913
    if Types.Record.is_empty t then None 
914
    else Some (dispatch_record_label disp t pl labs)
915
916
917
918
919
920
921
922
923
924
925
(*  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 *)
926
  and dispatch_record_label disp t pl labs =
927
928
    match collect_first_label pl with
      | None -> 
929
	  let aux_final (res, catch, x) =
930
	    assert (x = `Success); 
931
	    IdMap.mapi_to_list (conv_source_record catch) res 
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
	  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 -> 
947
		 if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
948
949
950
	     | Some r1, None -> `Result r1
	     | None, Some r2 -> `Result r2
	     | _ -> assert false)
951
      | Some l ->
952
953
954
	  let (plabs,absent) = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
955
	    pl, dispatch_record_opt disp t pl labs
956
	  in
957
	  let present =
958
	    let labs = l :: labs in
959
960
	    let pl = label_found l pl in
	    let t = Types.Record.restrict_label_present t l in
961
	    if Types.Record.is_empty t then Impossible else 
962
963
964
965
966
967
968
969
	      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)
970
	  in
971
972
	  combine_record l present absent
  and dispatch_record_field l disp t plabs labs tfield pl others =
973
    let t = Types.Record.restrict_field t l tfield in
974
    let aux (ret, ncatchv, (res, catch, rem)) = 
975
      let catch = if IdMap.is_empty ret then catch else (l,ret) :: catch in
976
      (res, catch, rem) in
977
978
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
979
(*    if pl = plabs then `Absent else  *)
980
      (* TODO: Check that this is the good condition ....
981
982
983
984
985
986
987
988
989
	 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 ....
      *)
	 
990
    dispatch_record_label disp t pl labs
991
    
992
      
993
994
995
996
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
997
998
999
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
1000
		    (dispatch_prod ~kind:`XML disp)
1001
1002
		    (dispatch_record disp)
	  in
1003
1004
1005
1006
	  disp.actions <- Some a;
	  a

  let to_print = ref []
1007
1008
1009

  module DSET = Set.Make (struct type t = int let compare (x:t) (y:t) = x - y end)
  let printed = ref DSET.empty
1010
1011

  let queue d =
1012
1013
    if not d.printed then (
      d.printed <- true;
1014
1015
1016
      to_print := d :: !to_print
    )

1017
  let rec print_source ppf = function
1018
1019
1020
1021
1022
1023
1024
1025
    | Catch  -> Format.fprintf ppf "v"
    | Const c -> Types.Print.print_const ppf c
    | Left (-1) -> Format.fprintf ppf "v1"
    | Right (-1) -> Format.fprintf ppf "v2"
    | Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
    | Left i -> Format.fprintf ppf "l%i" i
    | Right j -> Format.fprintf ppf "r%i" j
    | Recompose (i,j) ->