patterns.ml 29.1 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 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
  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) -> 
42
	Format.fprintf ppf "{ %s =  P%i }" (LabelPool.value l) n.id;
43
44
	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
let record l x = 
106
  (Types.record l 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
let min (a:int) (b:int) = if a < b then a else b

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

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

  type nnf = node sl * Types.descr
  type 'a nline = (result *  'a) list
  type record =
190
    | RecNolabel of result option * result option
191
    | RecLabel of label * (nnf * nnf) nline 
192
193
194
195
196
197
198
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
199
    nrecord: record;
200
201
202
  }

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


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

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

  type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
  type 'a nline = (result *  'a) sl
225
  type record =
226
    | RecNolabel of result option * result option
227
    | RecLabel of label * (nnf * nnf) nline
228
  type t = {
229
    nfv    : fv;
230
    ncatchv: fv;
231
    na     : Types.descr;
232
    nbasic : Types.descr nline;
233
234
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
235
    nrecord: record
236
237
  }

238

239
  let fus = IdMap.union_disj
240
  let slcup = SortedList.cup
241

242
243
244
245
246
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
      nbasic = []; nprod = []; nxml = []; 
      nrecord = (match lab with 
247
248
		   | Some l -> RecLabel (l,[]) 
		   | None -> RecNolabel (None,None))
249
    }
250
251
252
253
254
255


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
256
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
257
258
259
260
      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;
261
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
262
263
264
265
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
		       assert (l1 = l2); RecLabel (l1, slcup r1 r2)
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
		       RecNolabel((if x1 = None then x2 else x1),
266
267
				(if y1 = None then y2 else y1))
		   | _ -> assert false)
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
    }

  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
294
    let do_record r1 r2 = match r1,r2 with
295
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
296
	  assert (l1 = l2);
297
298
	  RecLabel(l1, double_fold prod r1 r2)
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
299
300
301
302
303
304
	  let x = match x1,x2 with 
	    | Some res1, Some res2 -> Some (fus res1 res2) 
	    | _ -> None
	  and y = match y1,y2 with
	    | Some res1, Some res2 -> Some (fus res1 res2)
	    | _ -> None in
305
	  RecNolabel (x,y)
306
      | _ -> assert false
307
    in
308
309
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
310
311
312
313
      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;
314
      nrecord = do_record nf1.nrecord nf2.nrecord;
315
316
    }

317
  let nnode p = [p], Types.descr p.accept
318
  let empty_res = IdMap.empty
319

320
  let ntimes lab acc p q = 
321
322
323
    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 
324
    { nempty lab with 
325
	nfv = IdSet.cup p.fv q.fv; 
326
	na = acc;
327
328
329
	nprod = [ (src, (nnode p, nnode q)) ];
    }

330
  let nxml lab acc p q = 
331
332
333
    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 
334
    { nempty lab with 
335
	nfv = IdSet.cup p.fv q.fv; 
336
337
	na = acc;
	nxml =  [ (src, (nnode p, nnode q)) ];
338
339
    }
    
340
341
342
343
344
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
(*	  Printf.eprintf "[ l = %s; label = %s ]\n" 
345
346
	    (LabelPool.value l)
	    (LabelPool.value label); *)
347
348
349
350
351
352
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
353
		nrecord = RecLabel(label, 
354
355
356
357
358
359
360
361
362
				 [ (src,(nnode p, ([], Types.any))) ])}
	  else
	    let src = IdMap.constant SRight p.fv in
	    let p' = make p.fv in  (* optimize this ... *)
	      (* cache the results to avoid looping ... *)
	    define p' (record l p);
	    { nempty lab with
		nfv = p.fv;
		na = acc;
363
		nrecord = RecLabel(label,
364
365
366
367
368
369
370
371
372
373
				 [ (src,(([], Types.Record.any_or_absent), 
					 nnode p')) ])}
	  

  let nconstr lab t =
    let aux = List.map (fun (t1,t2) -> empty_res, (([],t1),([],t2))) in
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
374
	    RecNolabel ((if x then Some empty_res else None), 
375
376
		      (if y then Some empty_res else None))
	| Some l ->
377
	    RecLabel (l,aux (Types.Record.split_normal t l))
378
379
    in	      
    { nempty lab with
380
	na = t;
381
	nbasic = [ empty_res, Types.cap t any_basic ];
382
383
384
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
385
386
    }

387
  let nconstant lab x c = 
388
389
390
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
391
392
393
394
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
395
      nrecord = match lab with
396
	| None -> RecNolabel (Some l, Some l)
397
	| Some lab -> 
398
	    RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),
399
			       ([], Types.any))) ])
400
401
    }

402
  let ncapture lab x = 
403
404
405
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
406
407
408
409
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
410
      nrecord = match lab with
411
	| None -> RecNolabel (Some l, Some l)
412
	| Some lab -> 
413
	    RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),([], Types.any))) ])
414
415
    }

416
  let rec nnormal lab (acc,fv,d) =
417
    if Types.is_empty acc 
418
    then nempty lab
419
    else match d with
420
421
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
422
      | Cup ((acc1,_,_) as p,q) -> 
423
424
425
426
427
428
429
430
431
432
433
434
435
	  ncup (nnormal lab p) (ncap (nnormal lab q) 
				  (nconstr lab (Types.neg acc1)))
      | Times (p,q) -> ntimes lab acc p q
      | Xml (p,q) -> nxml lab acc p q
      | Capture x -> ncapture lab x
      | Constant (x,c) -> nconstant lab x c
      | Record (l,p) -> nrecord lab acc l p

(*TODO: when an operand of Cap has its first_label > lab,
  directly shift it*)

  let rec first_label (acc,fv,d) =
    if Types.is_empty acc 
436
    then LabelPool.dummy_max
437
438
439
440
441
442
    else match d with
      | Constr t -> Types.Record.first_label t
      | Cap (p,q) -> min (first_label p) (first_label q)
      | Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
	    (* should "first_label_type acc1" ? *)
      | Record (l,p) -> l
443
      | _ -> LabelPool.dummy_max
444

445
446
447
448
   
  let remove_catchv n =
    let ncv = n.ncatchv in
    let nlines l = 
449
      let l = List.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
450
451
(*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
      l in
452
    { nfv     = IdSet.diff n.nfv ncv;
453
454
455
456
457
      ncatchv = n.ncatchv;
      na      = n.na;
      nbasic  = nlines n.nbasic;
      nprod   = nlines n.nprod;
      nxml    = nlines n.nxml;
458
      nrecord = (match n.nrecord with
459
		   | RecNolabel (x,y) ->
460
461
462
463
464
465
		       let x = match x with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
		       let y = match y with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
466
467
		       RecNolabel (x,y)
		   | RecLabel (lab,l) -> RecLabel (lab, nlines l))
468
469
    }

470
  let normal l t pl =
471
    remove_catchv
472
473
474
475
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
476
end
477
478


479
480
module Compile = 
struct
481
  type actions =
482
483
    | AIgnore of result
    | AKind of actions_kind
484
  and actions_kind = {
485
486
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
487
    xml: result dispatch dispatch;
488
489
490
    record: record option;
  }
  and record = 
491
    | RecLabel of label * result dispatch dispatch
492
    | RecNolabel of result option * result option
493
      
494
  and 'a dispatch =
495
496
497
498
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
499
500

  and result = int * source array
501
  and source = 
502
503
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
504
505
506
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
507
      (int * int id_map) list
508
509

  and interface =
510
511
    [ `Result of int
    | `Switch of interface * interface
512
513
514
515
516
517
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
518
    label : label option;
519
520
    interface : interface;
    codes : return_code array;
521
522
    mutable actions : actions option;
    mutable printed : bool
523
  }
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538

  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

539
  let combine_kind basic prod xml record =
540
541
542
543
544
545
546
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
547
548
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
549
	| _ -> raise Exit in
550
      let rs = match xml with
551
552
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
553
	| _ -> raise Exit in
554
555
      let rs = match record with
	| None -> rs
556
557
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
558
559
	| _ -> raise Exit in
      match rs with
560
561
562
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
563
564
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
565
566
	| _ -> raise Exit
    )
567
    with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }
568

569
  let combine (disp,act) =
570
    if Array.length act = 0 then Impossible
571
572
573
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
574
	   Ignore act.(0)
575
      else
576
	Dispatch (disp, act)
577
578
579


  let detect_right_tail_call = function
580
    | Dispatch (disp,branches) 
581
582
583
584
585
586
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
587
		     function Right j when pos = j -> true | _ -> false)
588
589
590
		  ret
	       )
	    ) branches
591
	  -> TailCall disp
592
593
594
    | x -> x

  let detect_left_tail_call = function
595
    | Dispatch (disp,branches)
596
597
598
599
	when
	  array_for_all_i
	    (fun i -> 
	       function 
600
		 | Ignore (code,ret) ->
601
602
603
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
604
			   function Left j when pos = j -> true | _ -> false)
605
606
607
608
609
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
610
	 TailCall disp
611
612
    | x -> x
   
613
614
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
615
		 
616
617
  module DispMap = Map.Make(
    struct
618
      type t = Types.descr * Normal.t array
619
620
621
      let compare = compare
    end
  )
622
    
623
  let dispatchers = ref DispMap.empty
624
		      
625
  let dispatcher t pl lab : dispatcher =
626
627
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
628
      let nb = ref 0 in
629
630
      let codes = ref [] in
      let rec aux t arity i accu = 
631
632
	if Types.is_empty t then `None
	else
633
	  if i = Array.length pl 
634
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
635
636
	  else
	    let p = pl.(i) in
637
	    let tp = p.Normal.na in
638
639
640
641
	    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*)

642
(*	    let tp = Types.normalize tp in *)
643
	    let accu' = (i,IdMap.num arity v) :: accu in
644
	    `Switch 
645
	      (
646
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
647
	       aux (Types.diff t tp) arity (i+1) accu
648
649
	      )
      in
650
      let iface = aux t 0 0 [] in
651
652
      let res = { id = !cur_id; 
		  t = t;
653
		  label = lab;
654
		  pl = pl;
655
		  interface = iface;
656
		  codes = Array.of_list (List.rev !codes);
657
		  actions = None; printed = false } in
658
659
660
661
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
662
663
  let find_code d a =
    let rec aux i = function
664
665
666
667
      | `Result code -> code
      | `None -> assert false
      | `Switch (yes,_) when a.(i) <> None -> aux (i + 1) yes
      | `Switch (_,no) -> aux (i + 1) no
668
669
670
671
    in
    aux 0 d.interface

  let create_result pl =
672
673
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
674
675
676
677
678
679

  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)
    
680
  let conv_source_basic s = match s with
681
682
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
683
684
    | _ -> assert false

685
  let assoc v l =
686
    try IdMap.assoc v l with Not_found -> -1
687

688
  let conv_source_prod left right v s = match s with
689
690
691
692
693
    | 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)
694
695

  let dispatch_basic disp : (Types.descr * result) list =
696
(* TODO: try other algo, using disp.codes .... *)
697
698
699
700
701
702
703
704
    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
705
    let accu = ref [] in
706
    let rec aux (success : (int * Normal.result) list) t l = 
707
708
709
      if Types.non_empty t 
      then match l with
	| [] ->
710
711
712
713
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
714
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
715
716
717
718
	    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
719
    in
720
    aux [] t tests;
721
722
723
    !accu


724
  let get_tests pl f t d post =
725
726
727
728
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
729
      List.iter (fun ( (pl,ty), info) -> accu := (ty,pl,i,info) :: !accu
730
731
732
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
733

734
735
736
737
738
739
740
    let lab =
      List.fold_left 
	(fun l (ty,pl,_,_) ->
	   List.fold_left
	     (fun l p -> min l (Normal.first_label (descr p)))
	     (min l (Types.Record.first_label ty))
	     pl
741
742
	) LabelPool.dummy_max !accu in
    let lab = if lab= LabelPool.dummy_max then None else Some lab in
743
744
745
746
747
748
749

    let accu = 
      List.map (fun (ty,pl,i,info) -> 
		  let p = Normal.normal lab ty pl in
		  (p,[i, p.Normal.ncatchv, info])) 
	!accu in
    let sorted = Array.of_list (SortedMap.from_list SortedList.cup accu) in
750
    let infos = Array.map snd sorted in
751
    let disp = dispatcher t (Array.map fst sorted) lab in
752
    let result (t,_,m) =
753
      let selected = Array.create (Array.length pl) [] in
754
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
755
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
756
757
      d t selected unselect
    in
758
    let res = Array.map result disp.codes in
759
760
    post (disp,res)

761

762
763
764
765
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
766
	   let p' = ([p],t) in
767
768
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
769
	) (t,[]) brs in
770
	
771
772
773
774
775
776
777
778
    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 
779
	   | [(res,catchv,e)] -> assert (!r = None); 
780
781
	       let catchv = IdMap.constant (-1) catchv in
	       r := Some (IdMap.union_disj catchv res,e)
782
783
784
785
786
787
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
788
789


790
791
792
793
794
795
796
  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
797
798
    dispatch_prod0 disp t pl
  and dispatch_prod0 disp t pl =
799
800
801
802
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
803
      (fun x -> detect_left_tail_call (combine x))
804
805
  and dispatch_prod1 disp t t1 pl _ =
    get_tests pl
806
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
807
808
      (Types.Product.pi2_restricted t1 t)
      (dispatch_prod2 disp)
809
      (fun x -> detect_right_tail_call (combine x))
810
  and dispatch_prod2 disp t2 pl _ =
811
    let aux_final (ret2, ncatchv, (ret1, res)) =  
812
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
813
    return disp pl aux_final
814
815
816


  let rec dispatch_record disp : record option =
817
818
819
820
821
822
823
824
825
    let t = disp.t in
    if not (Types.Record.has_record t) then None 
    else
      match disp.label with
	| None -> 
	    let (some,none) = Types.Record.empty_cases t in
	    let some =
	      if some then 
		let pl = Array.map (fun p -> match p.Normal.nrecord with
826
827
				      | Normal.RecNolabel (Some x,_) -> [x]
				      | Normal.RecNolabel (None,_) -> []
828
829
830
831
832
833
834
				      | _ -> assert false) disp.pl in
		Some (return disp pl (IdMap.map_to_list conv_source_basic))
	      else None
	    in
	    let none =
	      if none then 
		let pl = Array.map (fun p -> match p.Normal.nrecord with
835
836
				      | Normal.RecNolabel (_,Some x) -> [x]
				      | Normal.RecNolabel (_,None) -> []
837
838
839
840
				      | _ -> assert false) disp.pl in
		Some (return disp pl (IdMap.map_to_list conv_source_basic))
	      else None
	    in	      
841
	    Some (RecNolabel (some,none))
842
843
844
	| Some lab ->
	    let t = Types.Record.split t lab in
	    let pl = Array.map (fun p -> match p.Normal.nrecord with
845
				  | Normal.RecLabel (_,l) -> l
846
				  | _ -> assert false) disp.pl in
847
	    Some (RecLabel (lab,dispatch_prod0 disp t pl))
848
849
(* soucis avec les ncatchv ?? *)

850
      
851
852
853
854
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
855
856
857
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
858
		    (dispatch_prod ~kind:`XML disp)
859
860
		    (dispatch_record disp)
	  in
861
862
863
864
	  disp.actions <- Some a;
	  a

  let to_print = ref []
865
866
867

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

  let queue d =
870
871
    if not d.printed then (
      d.printed <- true;
872
873
874
      to_print := d :: !to_print
    )

875
  let rec print_source ppf = function
876
877
878
879
880
881
882
    | 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"
    | Left i -> Format.fprintf ppf "l%i" i
    | Right j -> Format.fprintf ppf "r%i" j
    | Recompose (i,j) -> 
883
	Format.fprintf ppf "(%a,%a)" 
884
885
	  print_source (Left i)
	  print_source (Right j)
886
887
888
889
890
891
892
893
894
895
896
897
898

  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

899
900
901
902
  let print_ret_opt ppf = function
    | None -> Format.fprintf ppf "*"
    | Some r -> print_ret ppf r

903
  let print_kind ppf actions =
904
    let print_lhs ppf (code,prefix,d) =
905
      let arity = match d.codes.(code) with (_,a,_) -> a in
906
907
908
909
910
911
912
      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) =
913
      Format.fprintf ppf " | %a -> %a@\n"
914
915
916