patterns.ml 35.9 KB
Newer Older
1
2
3
type capture = string
type fv = capture SortedList.t

4
5
exception Error of string

6
7

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

25
26
27
28
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
29
30
31

let printed = ref []
let to_print = ref []
32
33
let rec print ppf (a,_,d) = 
(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
  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 ->
	Format.fprintf ppf "%s" x
    | Constant (x,c) ->
	Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c

52
53
54
55
56
57
58
59
60
61
62
63
64
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
65
66


67
68
69
70
71
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
72
73
74
75
76
77

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

78
let constr x = (x,[],Constr x)
79
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
80
81
82
83
84
85
86
87
88
89
  if fv1 <> fv2 then (
    let x = match SortedList.diff fv1 fv2 with
      | x::_ -> x
      | [] -> match SortedList.diff fv2 fv1 with x::_ -> x | _ -> assert false
    in
    raise 
      (Error 
	 ("The capture variable " ^ x ^ 
	  " should appear on both side of this | pattern"))
  );
90
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
91
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
92
93
94
95
96
97
98
99
100
  if not (SortedList.disjoint fv1 fv2) then (
    match SortedList.cap fv1 fv2 with
      | x::_ -> 
	  raise 
	  (Error 
	     ("The capture variable " ^ x ^ 
	      " cannot appear on both side of this & pattern"))
      | _ -> assert false
  );
101
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
102
103
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
104
105
let xml x y =
  (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
let record l x = 
  (Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, [x], Capture x)
let constant x c = (Types.any, [x], Constant (x,c))




(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
let empty_res fv = List.map (fun v -> (v, Types.Positive.ty Types.empty)) fv
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

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

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


159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
  List.map (fun (c,v) -> (c,Types.Positive.solve v)) r



176
177
178
(* Returns a pattern q equivalent to p when applied to a
   value of type t *)

179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
module Compiler = 
struct

  type disp = {
    did   : int;
    results : (int *
	       (capture, int) SortedMap.t option array * bool array) array
  }

  module DispMap = Map.Make(
    struct
      type t = (node * Types.descr) array * (Types.descr * Types.descr) array
      let compare = compare
    end
  )
    
  let dispatchers = ref DispMap.empty
  let nb_disp = ref 0		  
    
  let dispatcher pats typs : disp =
    try DispMap.find (pats,typs) !dispatchers
    with Not_found ->
      incr nb_disp;
      let d = { did = !nb_disp; results = [| |] } in
      dispatchers := DispMap.add (pats,typs) d !dispatchers;
      d

  let sort_list l =
    Array.of_list (SortedList.from_list l)

type 'a pat =
210
211
  | One
  | Zero
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
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
264
265
266
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
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
  | Capt of capture
  | Const of capture * Types.const
  | Alt of 'a pat * 'a pat
  | And of 'a pat * 'a pat
  | Type of Types.descr * Types.descr
  | Atom of Types.descr * 'a

let rec print f ppf = function
  | One -> Format.fprintf ppf "One"
  | Zero -> Format.fprintf ppf "Zero"
  | Capt x -> Format.fprintf ppf "%s" x
  | Const (x,c) -> Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c
  | Alt (p1,p2) -> Format.fprintf ppf "(%a | %a)" (print f) p1 (print f) p2
  | And (p1,p2) -> Format.fprintf ppf "(%a & %a)" (print f) p1 (print f) p2
  | Atom (d, a) -> Format.fprintf ppf "[%a]%a" Types.Print.print_descr d f a
  | Type (d, a) -> Format.fprintf ppf "[%a]%a" Types.Print.print_descr d Types.Print.print_descr a

let alt = function
  | (Zero,p) | (p,Zero) -> p
  | (p1,p2) -> Alt (p1,p2)

let and_ = function
  | (Zero,_) | (_,Zero) -> Zero
  | (One,p) | (p,One) -> p
  | (p1,p2) -> And (p1,p2)

let atom s a p =
  if Types.is_empty (Types.cap s a) then Zero else
    Atom (s, p)

let rec get f (a,_,d) s =
  if Types.is_empty (Types.cap s a) then Zero else
  match d with
    | Constr t -> 
	if Types.subtype s t then One else Type (s, Types.cap s t)
    | Cup ((a1,_,_) as d1,d2) ->
	let p1 = get f d1 s in
	let p2 = get f d2 (Types.diff s a1) in
	alt (p1,p2)
    | Cap ((a1,_,_) as d1,d2) ->
(* could swap the two to optimize ? ... *)
	let p1 = get f d1 s in
	let p2 = get f d2 (Types.cap s a1) in
	and_ (p1,p2)
    | Capture x ->
	Capt x
    | Constant (x,c) ->
	Const (x,c)
    | d -> (match f d with None -> Zero | Some x -> Atom (s, x))

let rec collect typ f (a,_,d) s =
  if Types.is_empty (Types.cap s a) then () else
  match d with
    | Constr t -> if not (Types.subtype s a) then typ s (Types.cap s t)
    | Cup ((a1,_,_) as d1,d2) -> 
	collect typ f d1 s; collect typ f d2 (Types.diff s a1)
    | Cap ((a1,_,_) as d1,d2) ->
	collect typ f d1 s;
	collect typ f d2 (Types.cap s a1)
    | Capture _ | Constant (_,_) -> ()
    | d -> f s d

let get_prod =
  get (function Times (n1,n2) -> Some n1 | _ -> None)
let get_record =
  get (function Record (l,n) -> Some (l,n) | _ -> None)

let print_prod =
  print (fun ppf p1 ->
	   Format.fprintf ppf "(P%i)" p1.id
	)
let print_record =
  print (fun ppf (l,p) ->
	   Format.fprintf ppf "{ %s = P%i }" (Types.LabelPool.value l) p.id
	)

let demo ppf p t =
  collect 
    (fun w t -> 
       Format.fprintf ppf "TYP1:%a // %a@\n"
         Types.Print.print_descr t
         Types.Print.print_descr w;
       let n = Types.Product.normal t in
       let pi1 = Types.Product.pi1 (Types.Product.get w) in
       List.iter (fun (d1,d2) ->
		    Format.fprintf ppf "=> %a // %a@\n"
		    Types.Print.print_descr d1
		    Types.Print.print_descr pi1
		 ) n
    )
    (fun w -> function
       | Times (n1,n2) -> 
	   let pi1 = Types.Product.pi1 (Types.Product.get w) in
	   Format.fprintf ppf "PAT1:%i // %a@\n" n1.id 
	     Types.Print.print_descr pi1; 
	   to_print := n1 :: !to_print
       | _ -> ()) p t

end

let demo ppf p t =
(*
  Compiler.demo ppf p t;
  dump_print ppf
*)
  Format.fprintf ppf "PROD:%a@\n" Compiler.print_prod (Compiler.get_prod p (Types.cap Types.Product.any t));
  Format.fprintf ppf "REC :%a@\n" Compiler.print_record (Compiler.get_record p (Types.cap Types.Record.any t))

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340

let rec restrict ((a,fv,d) as p) t =
  (* TODO OPT: Don't call cup,cap .... *)
  match d with
    | Constr s ->
	constr (Types.cap t a)
	(* Could return any type  (t&s)|u  with u&t=0 *)
    | Cup (((a1,_,_) as p1),((a2,_,_) as p2)) ->
	let p1 = 
	  if Types.is_empty (Types.cap t a1) then None 
	  else Some (restrict p1 t) in
	let p2 =
	  let t' = Types.diff t a1 in
	  if Types.is_empty (Types.cap t' a2) then None 
	  else Some (restrict p2 t') in
	(match (p1,p2) with
	   | Some p1, Some p2 -> cup p1 p2
	   | Some p1, None -> p1
	   | None, Some p2 -> p2
	   | _ -> assert false)
    | Cap (p1,p2) -> cap (restrict p1 t) (restrict p2 t)
341
342
(*    | Capture _ | Constant (_,_) -> p *)
    | _ -> p (* (Types.cap a t, fv, d) *)
343
344
345
346
347
348
349
  
let restrict ((a,fv,_) as p) t =
  if Types.is_empty (Types.cap a t) then `Reject
  else if (fv = []) && (Types.subtype t a) then `Accept
  else `Pat (restrict p t)


350
351
(* Normal forms for patterns and compilation *)

352
module Normal = 
353
354
355
356
357
358
359
360
361
362
363
struct
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
      [ `Catch | `Const of Types.const 
      | `Left | `Right | `Recompose 
      | `Field of Types.label 
      ]
  type result = (capture, source) sm

364
  type 'a line = (result * 'a, Types.descr) sm
365
366
  type nf = {
    v     : fv;
367
    catchv: fv;  (* Variables catching the value *)
368
    a     : Types.descr;
369
370
    basic : unit line;
    prod  : (node sl * node sl) line;
371
372
373
    xml   : (node sl * node sl) line;
    record: ((Types.label, node sl) sm) line;

374
375
376
377
378
379
380
381
  }

  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `Fail
      | `Dispatch of (nf * record) list
      | `Label of Types.label * (nf * record) list * record ]
382
  type t = {
383
    nfv    : fv;
384
    ncatchv: fv;
385
    na     : Types.descr;
386
387
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
388
    nxml   : (nf * nf) nline;
389
    nrecord: record nline
390
391
  }

392
393
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
394
395
396
397
398
		basic = []; prod = []; xml = []; record = [] }
  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
			       [Types.Product.any_xml;
				Types.Product.any;
				Types.Record.any])
399
  let restrict t nf =
400
401
402
403
404
405
    let rec filter = function
      | (key,acc) :: rem -> 
	  let acc = Types.cap t acc in
	  if Types.is_empty acc then filter rem else (key,acc) :: (filter rem)
      | [] -> []
    in
406
    {  v = nf.v;
407
       catchv = nf.catchv;
408
       a = Types.cap t nf.a;
409
410
       basic = filter nf.basic;
       prod = filter nf.prod;
411
       xml = filter nf.xml;
412
       record = filter nf.record;
413
414
415
416
417
418
    }

  let fus = SortedMap.union_disj
  let slcup = SortedList.cup

  let cap nf1 nf2 =
419
420
421
422
423
424
425
426
427
428
429
430
431
432
    let merge f lines1 lines2 =
      let m =
	List.fold_left 
	  (fun accu ((res1,x1),acc1) ->
	     List.fold_left
	     (fun accu ((res2,x2),acc2) ->
		let acc = Types.cap acc1 acc2 in
		if Types.is_empty acc then accu
		else ((fus res1 res2, f x1 x2),acc) :: accu
	     ) accu lines2
	  ) [] lines1 in
      SortedMap.from_list Types.cup m
    in
    let merge_basic () () = ()
433
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
434
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
435
    { v = SortedList.cup nf1.v nf2.v;
436
      catchv = SortedList.cup nf1.catchv nf2.catchv;
437
      a = Types.cap nf1.a nf2.a;
438
439
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
440
      xml = merge merge_prod nf1.xml nf2.xml;
441
      record = merge merge_record nf1.record nf2.record;
442
443
444
445
446
447
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
448
    { v = nf1.v; (* = nf2.v *)
449
      catchv = SortedList.cap nf1.catchv nf2.catchv;
450
451
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
452
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
453
      xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
454
      record = SortedMap.union Types.cup nf1.record nf2.record;
455
456
457
458
459
460
461
462
463
    }

  let times acc p q = 
    let src_p = List.map (fun v -> (v,`Left)) p.fv
    and src_q = List.map (fun v -> (v,`Right)) q.fv in
    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
    { empty with 
	v = SortedList.cup p.fv q.fv; 
	a = acc;
464
	prod = [ (src, ([p], [q])), acc ] }
465

466
467
468
469
470
471
472
473
474
  let xml acc p q = 
    let src_p = List.map (fun v -> (v,`Left)) p.fv
    and src_q = List.map (fun v -> (v,`Right)) q.fv in
    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
    { empty with 
	v = SortedList.cup p.fv q.fv; 
	a = acc;
	xml = [ (src, ([p], [q])), acc ] }

475
476
477
478
479
  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
480
	record = [ (src, [l,[p]]), acc ] }
481
482

  let any =
483
484
    { v = []; 
      catchv = [];
485
      a = Types.any;
486
487
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
488
      xml   = [ ([],([],[])), Types.Product.any_xml ];
489
      record = [ ([],[]), Types.Record.any ];
490
491
492
493
494
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
495
      catchv = [x];
496
      a = Types.any;
497
498
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
499
      xml  = [ (l,([],[])), Types.Product.any_xml  ];
500
      record = [ (l,[]), Types.Record.any ];
501
502
503
504
505
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
506
      catchv = [];
507
      a = Types.any;
508
509
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
510
      xml   = [ (l,([],[])), Types.Product.any_xml  ];
511
      record = [ (l,[]), Types.Record.any ];
512
513
514
515
    }

  let constr t =
    { v = [];
516
      catchv = [];
517
      a = t;
518
519
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
520
      xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
521
      record = [ ([],[]), Types.cap t Types.Record.any ];
522
523
524
525
526
527
528
    }

(* Put a pattern in normal form *)
  let rec nf (acc,fv,d) =
    if Types.is_empty acc 
    then empty
    else match d with
529
530
      | Constr t -> constr t
      | Cap (p,q) -> cap (nf p) (nf q)
531
532
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
533
      | Xml (p,q) -> xml acc p q
534
535
536
537
538
539
      | Capture x -> capture x
      | Constant (x,c) -> constant x c
      | Record (l,p) -> record acc l p

  let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any

540
541
542
543
  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

544
    and prod ?kind l =
545
546
547
      let line accu (((res,(pl,ql)),acc)) =
	let p = bigcap pl and q = bigcap ql in
	let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
548
	let t = Types.Product.normal ?kind acc in
549
	List.fold_left aux accu t in
550
      List.fold_left line [] l
551
   
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567

    and record =
      let rec aux nr fields = 
	match (nr,fields) with
	  | (`Success, []) -> `Success
	  | (`Fail,_) -> `Fail
	  | (`Success, (l2,pl)::fields) ->
	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
	  | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
	  | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
	      let p = bigcap pl in
	      let pr = 
		List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
	      `Label (l1, pr, `Fail)
	  | (`Label (l1, pr, ab),_) ->
568
	      let aux_ab = aux ab fields in
569
	      let pr = 
570
571
572
573
574
575
		List.map (fun (t,x) -> (constr t, 
(* Types.Record.normal enforce physical equility
   in case of a ? field *)
					if x==ab then aux_ab else
					aux x fields)) pr in
	      `Label (l1, pr, aux_ab)
576
577
578
579
580
581
582
583
584
585
      in

      let line accu ((res,fields),acc) =
	let nr = Types.Record.normal acc in
	let x = aux nr fields in
	match x with 
	  | `Fail -> accu 
	  | x -> (res,x) :: accu in
      List.fold_left line []
    in
586
587
588
589
    let nlines l = 
      List.map (fun (res,x) -> (SortedMap.diff res nf.catchv,x)) l in
    { nfv     = SortedList.diff nf.v nf.catchv; 
      ncatchv = nf.catchv;
590
      na      = nf.a;
591
592
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
593
      nxml    = nlines (prod ~kind:`XML nf.xml);
594
      nrecord = nlines (record nf.record);
595
    }
596

597
end
598
599


600
601
module Compile = 
struct
602
603
604
605
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
606
607
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
608
    xml: result dispatch dispatch;
609
610
611
612
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
613
614
      | `Result of result
      | `Absent ]
615
      
616
617
618
619
620
621
622
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
  and source = 
      [ `Catch | `Const of Types.const 
      | `Left of int | `Right of int | `Recompose of int * int
      | `Field of Types.label * int
      ]
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
      (int * (capture, int) SortedMap.t) list

  and interface =
    [ `Result of int * Types.descr * int  (* code, accepted type, arity *)
    | `Switch of (capture, int) SortedMap.t * interface * interface
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
    interface : interface;
    codes : return_code array;
    mutable actions : actions option
  }
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660

  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

661
  let combine_kind basic prod xml record =
662
663
664
665
666
667
668
669
670
671
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
672
673
674
675
      let rs = match xml with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
676
677
678
679
680
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
681
682
683
684
685
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
686
687
	| _ -> raise Exit
    )
688
    with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
689

690
  let combine (disp,act) =
691
692
693
694
695
696
697
698
699
700
701
    if Array.length act = 0 then `None
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
	   `Ignore act.(0)
      else
	`Dispatch (disp, act)

  let combine_record l present absent = 
    match (present,absent) with
      | (`Ignore r1, Some r2) when r1 = r2 -> r1
702
      | (`Ignore `Absent, Some r) -> r
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
      | (`Ignore r, None) -> r
      | _ -> `Label (l, present, absent)

  let detect_right_tail_call = function
    | `Dispatch (disp,branches) 
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
		     function `Right j when pos = j -> true | _ -> false)
		  ret
	       )
	    ) branches
	  -> `TailCall disp
    | x -> x

  let detect_left_tail_call = function
    | `Dispatch (disp,branches)
	when
	  array_for_all_i
	    (fun i -> 
	       function 
		 | `Ignore (code,ret) ->
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
			   function `Left j when pos = j -> true | _ -> false)
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
	 `TailCall disp
    | x -> x
   
740
741
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
742
		 
743
744
  module DispMap = Map.Make(
    struct
745
      type t = Types.descr * Normal.t array
746
747
748
      let compare = compare
    end
  )
749
    
750
  let dispatchers = ref DispMap.empty
751
752
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
753

754
    
755
756
757
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
758
759
760
761
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
762
	  if i = Array.length pl 
763
	  then (incr nb; `Result (!nb - 1, t, arity))
764
765
	  else
	    let p = pl.(i) in
766
767
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
768
769
770
771
772
773
774
775
776

	    let v = SortedList.diff v p.Normal.ncatchv in
(*
	    Printf.eprintf "ncatchv = (";
	    List.iter (fun s -> Printf.eprintf "%s;" s) p.Normal.ncatchv;
	    Printf.eprintf ")\n";
	    flush stderr;
*)
	    
777
(*	    let tp = Types.normalize tp in *)
778
779
780
781
782
783
784
785
786
787
788
789
	    `Switch 
	      (num arity v,
	       aux (Types.cap t tp) (arity + (List.length v)) (i+1),
	       aux (Types.diff t tp) arity (i+1)
	      )
      in
      let iface = aux t 0 0 in
      let codes = Array.create !nb (Types.empty,0,[]) in
      let rec aux i accu = function
	| `None -> ()
	| `Switch (pos, yes, no) -> 
	    aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
790
791
	| `Result (code,t,arity) -> 
	    codes.(code) <- (t,arity, accu)
792
      in
793
      aux 0 [] iface;
794
795
796
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
797
798
		  interface = iface;
		  codes = codes;
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
		  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
  let compare_masks a1 a2 =
    try
      for i = 0 to Array.length a1 - 1 do
	match a1.(i),a2.(i) with   
	  | None,Some _| Some _, None -> raise Exit
	  | _ -> ()
      done;
      true
    with Exit -> false

814
815
816
  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
817
818
      | `None -> 
	  assert false
819
820
821
822
823
824
      | `Switch (_,yes,no) ->
	  match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
    in
    aux 0 d.interface

  let create_result pl =
825
826
827
828
829
830
831
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
832
833
834
835
836
837
838

  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)
    
  let conv_source_basic (v,s) = match s with
839
840
841
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

842
843
844
  let assoc v l =
    try List.assoc v l with Not_found -> -1

845
846
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
847
848
849
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
850
    | _ -> assert false
851

852
853
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
854
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
855
856
857
858
859
860
861
862
863
864
865
866
    | _ -> assert false


  let dispatch_basic disp : (Types.descr * result) list =
    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
867
    let accu = ref [] in
868
    let rec aux (success : (int * Normal.result) list) t l = 
869
870
871
      if Types.non_empty t 
      then match l with
	| [] ->
872
873
874
875
876
877
878
879
880
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
	    let aux_final res = List.map conv_source_basic res in
	    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
881
    in
882
    aux [] t tests;
883
884
885
    !accu


886
  let get_tests pl f t d post =
887
888
889
890
891
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
      List.iter (fun (p,info) ->
892
893
894
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
895
896
897
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
898

899
900
901
    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
902
    let result (t,_,m) =
903
904
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
905
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
906
907
      d t selected unselect
    in
908
    let res = Array.map result disp.codes in
909
910
    post (disp,res)

911

912
913
914
915
916
917
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
	   let p = Normal.restrict t (Normal.nf p) in
	   let t = Types.diff t (p.Normal.a) in
918
	   (t, (p,(p.Normal.catchv,e)) :: brs)
919
	) (t,[]) brs in
920
	
921
922
923
924
925
926
927
928
    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 
929
930
931
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
932
933
934
935
936
937
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
938
939


940
941
942
943
944
945
946
  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
947
948
949
950
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
951
      (fun x -> detect_left_tail_call (combine x))
952
953
954
955
956
957
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
      (fun (ret1, (res,q)) -> [q, (ret1,res)], [] ) 
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
958
      (fun x -> detect_right_tail_call (combine x))
959
  and dispatch_prod2 disp t t2 pl _ =
960
961
962
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
963
964


965
  let dummy_label = Types.LabelPool.dummy_max
966
967
968
969

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
970
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
971
972
      | _ -> () in
    Array.iter (List.iter aux) pl;
973
    if !m = dummy_label then None else Some !m
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993

  let map_record f = 
    let rec aux = function
      | [] -> []
      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
    Array.map aux

  let label_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, pr, _)) when l1 = l -> 
	     (res, catch, `Dispatch pr)
	 | x -> x)

  let label_not_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
	 | x -> x)

994
(*
995
996
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
997
*)
998
999
1000
1001
1002

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
1003
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
	   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) -> 
1021
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
1022
1023
1024
1025
1026
1027
1028
1029
1030
			   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

1031
  let rec dispatch_record disp : record option =
1032
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
1033
1034
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
1035
    let r = dispatch_record_opt disp t pl0 in
1036
(*    memo_dispatch_record := []; *)
1037
    r
1038
1039
1040
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
(*  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 *)
1052
1053
1054
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
1055
1056
1057
1058
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
1059
      | Some l ->
1060
1061
1062
1063
1064
	  let (plabs,absent) = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    pl, dispatch_record_opt disp t pl
	  in
1065
1066
1067
1068
1069
1070
1071
1072
1073
	  let present =
	    let pl = label_found l pl in
	    let t = Types.Record.restrict_label_present t l in
	    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)
1074
	      (dispatch_record_field l disp t plabs)
1075
	      (fun x -> combine x)
1076
	  in
1077
	  combine_record l present absent
1078
  and dispatch_record_field l disp t plabs tfield pl others =
1079
    let t = Types.Record.restrict_field t l tfield in
1080
1081
1082
    let aux (ret, (res, catch, rem)) = 
      let catch = if ret = [] then catch else (l,ret) :: catch in
      (res, catch, rem) in
1083
1084
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
1085
(*    if pl = plabs then `Absent else  *)
1086
      (* TODO: Check that this is the good condition ....
1087
1088
1089
1090
1091
1092
1093
1094
1095
	 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 ....
      *)
	 
1096
1097
    dispatch_record_label disp t pl
    
1098
      
1099
1100
1101
1102
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
1103
1104
1105
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
1106
		    (dispatch_prod ~kind:`XML disp)
1107
1108
		    (dispatch_record disp)
	  in
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
	  disp.actions <- Some a;
	  a

  let to_print = ref []
  let printed = ref []

  let queue d =
    if not (List.mem d.id !printed) then (
      printed := d.id :: !printed;
      to_print := d :: !to_print
    )

1121
  let rec print_source ppf = function
1122
1123
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
1124
1125
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
1126
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
1127
1128
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
1129
1130
1131
1132
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
1133
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147

  let print_result ppf =
    Array.iteri 
      (fun i s ->
	 if i > 0 then Format.fprintf ppf ",";
	 print_source ppf s; 
      )

  let print_ret ppf (code,ret) = 
    Format.fprintf ppf "$%i" code;
    if Array.length ret <> 0 then 
      Format.fprintf ppf "(%a)" print_result ret

  let print_kind ppf actions =
1148
    let print_lhs ppf (code,prefix,d) =
1149
      let arity = match d.codes.(code) with (_,a,_) -> a in
1150
1151
1152
1153
1154
1155
1156
      Format.fprintf ppf "$%i(" code;
      for i = 0 to arity - 1 do
	if i > 0 then Format.fprintf ppf ",";
	Format.fprintf ppf "%s%i" prefix i;
      done;
      Format.fprintf ppf ")" in
    let print_basic (t,ret) =
1157
      Format.fprintf ppf " | %a -> %a@\n"
1158
1159
1160
	Types.Print.print_descr t
	print_ret ret
    in
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
    let print_prod2 = function
      | `None -> assert false
      | `Ignore r ->
	  Format.fprintf ppf "        %a\n" 
	    print_ret r
      | `TailCall d ->
	  queue d;
	  Format.fprintf ppf "        disp_%i v2@\n" d.id
      | `Dispatch (d, branches) ->
	  queue d;
	  Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;
	  Array.iteri 
	    (fun code r ->
	       Format.fprintf ppf "        | %a -> %a\n" 
	         print_lhs (code, "r", d)
	         print_ret r;
   	    )
	    branches
1179
    in
1180
    let print_prod prefix = function
1181
1182
      | `None -> ()
      | `Ignore d2 ->
1183
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1184
1185
1186
	  print_prod2 d2
      | `TailCall d ->
	  queue d;
1187
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1188
1189
1190
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
      | `Dispatch (d,branches) ->
	  queue d;
1191
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1192
1193
1194
1195
1196
1197
1198
1199
	  Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
	  Array.iteri 
	    (fun code d2 ->
               Format.fprintf ppf "      | %a -> @\n"
	       print_lhs (code, "l", d);
	       print_prod2 d2;
   	    )
	    branches
1200
1201
1202
1203
1204
1205
1206
1207
    in
    let rec print_record_opt ppf = function
      | None -> ()
      | Some r -> 
	  Format.fprintf ppf " | Record -> @\n";
	  Format.fprintf ppf "     @[%a@]@\n"  print_record r
    and print_record ppf = function
      | `Result r -> print_ret ppf r
1208
      | `Absent -> Format.fprintf ppf "Jump to Absent"
1209
      | `Label (l, present, absent) ->
1210
	  let l = Types.LabelPool.value l in
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
	  Format.fprintf ppf "check label %s:@\n" l;
	  Format.fprintf ppf "Present => @[%a@]@\n" (print_present l) present;
	  match absent with
	    | Some r ->
		Format.fprintf ppf "Absent => @[%a@]@\n"
		   print_record r
	    | None -> ()
    and print_present l ppf = function
      | `None -> assert false
      | `TailCall d ->
1221
	  queue d;
1222
1223
1224
1225
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
1226
1227
	  Array.iteri
	    (fun code r ->
1228
	       Format.fprintf ppf "| %a -> @\n"
1229
	         print_lhs (code, l, d);
1230
	       Format.fprintf ppf "   @[%a@]@\n"
1231
	         print_record r
1232
1233
1234
1235
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf