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

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

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

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

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

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


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

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

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

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

110

111

112
113
114
115

(* Static semantics *)

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

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

let memo_filter = ref MemoFilter.empty

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

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


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

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


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

176
177
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
191
      [ `Nolabel of result option * result option
      | `Label of Types.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 -> Types.label
  val normal: Types.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
227
      [ `Nolabel of result option * result option
      | `Label of Types.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
240
241
242
243
244
  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"
245
    | `Label (l,pr) ->
246
	Format.fprintf ppf "Label(%s@[" (Types.LabelPool.value l);
247
	List.iter (fun (_,(_,r)) -> Format.fprintf ppf ",%a" print_record r) pr;
248
	Format.fprintf ppf ",%a@])" print_record ab
249
*)
250

251
  let fus = IdMap.union_disj
252
  let slcup = SortedList.cup
253

254
255
256
257
258
259
260
261
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
      nbasic = []; nprod = []; nxml = []; 
      nrecord = (match lab with 
		   | Some l -> `Label (l,[]) 
		   | None -> `Nolabel (None,None))
    }
262
263
264
265
266
267


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
268
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
269
270
271
272
      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;
273
274
275
276
277
278
279
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
		   | `Label (l1,r1), `Label (l2,r2) -> 
		       assert (l1 = l2); `Label (l1, slcup r1 r2)
		   | `Nolabel (x1,y1), `Nolabel (x2,y2) -> 
		       `Nolabel((if x1 = None then x2 else x1),
				(if y1 = None then y2 else y1))
		   | _ -> assert false)
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
    }

  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
306
307
308
309
310
311
312
313
314
315
316
317
318
    let do_record r1 r2 = match r1,r2 with
      | `Label (l1,r1), `Label (l2,r2) ->
	  assert (l1 = l2);
	  `Label(l1, double_fold prod r1 r2)
      | `Nolabel (x1,y1), `Nolabel (x2,y2) ->
	  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
	  `Nolabel (x,y)
      | _ -> assert false
319
    in
320
321
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
322
323
324
325
      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;
326
      nrecord = do_record nf1.nrecord nf2.nrecord;
327
328
    }

329
  let nnode p = [p], Types.descr p.accept
330
  let empty_res = IdMap.empty
331

332
  let ntimes lab acc p q = 
333
334
335
    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 
336
    { nempty lab with 
337
	nfv = IdSet.cup p.fv q.fv; 
338
	na = acc;
339
340
341
	nprod = [ (src, (nnode p, nnode q)) ];
    }

342
  let nxml lab acc p q = 
343
344
345
    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 
346
    { nempty lab with 
347
	nfv = IdSet.cup p.fv q.fv; 
348
349
	na = acc;
	nxml =  [ (src, (nnode p, nnode q)) ];
350
351
    }
    
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
(*	  Printf.eprintf "[ l = %s; label = %s ]\n" 
	    (Types.LabelPool.value l)
	    (Types.LabelPool.value label); *)
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
		nrecord = `Label(label, 
				 [ (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;
		nrecord = `Label(label,
				 [ (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 ->
	    (* Should check that r has only empty_cases *)
	    let (x,y) = Types.Record.empty_cases t in
	    `Nolabel ((if x then Some empty_res else None), 
		      (if y then Some empty_res else None))
	| Some l ->
	    `Label (l,aux (Types.Record.split_normal t l))
    in	      
    { nempty lab with
393
	na = t;
394
	nbasic = [ empty_res, Types.cap t any_basic ];
395
396
397
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
398
399
    }

400
  let nconstant lab x c = 
401
402
403
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
404
405
406
407
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
408
409
410
411
412
      nrecord = match lab with
	| None -> `Nolabel (Some l, Some l)
	| Some lab -> 
	    `Label (lab, [ (l,(([], Types.Record.any_or_absent),
			       ([], Types.any))) ])
413
414
    }

415
  let ncapture lab x = 
416
417
418
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
419
420
421
422
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
423
424
425
426
      nrecord = match lab with
	| None -> `Nolabel (Some l, Some l)
	| Some lab -> 
	    `Label (lab, [ (l,(([], Types.Record.any_or_absent),([], Types.any))) ])
427
428
    }

429
  let rec nnormal lab (acc,fv,d) =
430
    if Types.is_empty acc 
431
    then nempty lab
432
    else match d with
433
434
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
435
      | Cup ((acc1,_,_) as p,q) -> 
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
	  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 
    then Types.LabelPool.dummy_max
    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
      | _ -> Types.LabelPool.dummy_max

458
459
460
461
   
  let remove_catchv n =
    let ncv = n.ncatchv in
    let nlines l = 
462
      let l = List.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
463
464
(*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
      l in
465
    { nfv     = IdSet.diff n.nfv ncv;
466
467
468
469
470
      ncatchv = n.ncatchv;
      na      = n.na;
      nbasic  = nlines n.nbasic;
      nprod   = nlines n.nprod;
      nxml    = nlines n.nxml;
471
472
473
474
475
476
477
478
479
480
      nrecord = (match n.nrecord with
		   | `Nolabel (x,y) ->
		       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
		       `Nolabel (x,y)
		   | `Label (lab,l) -> `Label (lab, nlines l))
481
482
    }

483
  let normal l t pl =
484
    remove_catchv
485
486
487
488
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
489
end
490
491


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

  and result = int * source array
514
  and source = 
515
516
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
517
518
519
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
520
      (int * int id_map) list
521
522

  and interface =
523
524
    [ `Result of int
    | `Switch of interface * interface
525
526
527
528
529
530
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
531
    label : Types.label option;
532
533
    interface : interface;
    codes : return_code array;
534
535
    mutable actions : actions option;
    mutable printed : bool
536
  }
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551

  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

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

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


  let detect_right_tail_call = function
593
    | Dispatch (disp,branches) 
594
595
596
597
598
599
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
600
		     function Right j when pos = j -> true | _ -> false)
601
602
603
		  ret
	       )
	    ) branches
604
	  -> TailCall disp
605
606
607
    | x -> x

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

655
(*	    let tp = Types.normalize tp in *)
656
	    let accu' = (i,IdMap.num arity v) :: accu in
657
	    `Switch 
658
	      (
659
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
660
	       aux (Types.diff t tp) arity (i+1) accu
661
662
	      )
      in
663
      let iface = aux t 0 0 [] in
664
665
      let res = { id = !cur_id; 
		  t = t;
666
		  label = lab;
667
		  pl = pl;
668
		  interface = iface;
669
		  codes = Array.of_list (List.rev !codes);
670
		  actions = None; printed = false } in
671
672
673
674
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
675
676
  let find_code d a =
    let rec aux i = function
677
678
679
680
      | `Result code -> code
      | `None -> assert false
      | `Switch (yes,_) when a.(i) <> None -> aux (i + 1) yes
      | `Switch (_,no) -> aux (i + 1) no
681
682
683
684
    in
    aux 0 d.interface

  let create_result pl =
685
686
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
687
688
689
690
691
692

  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)
    
693
  let conv_source_basic s = match s with
694
695
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
696
697
    | _ -> assert false

698
  let assoc v l =
699
    try IdMap.assoc v l with Not_found -> -1
700

701
  let conv_source_prod left right v s = match s with
702
703
704
705
706
    | 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)
707
708

  let dispatch_basic disp : (Types.descr * result) list =
709
(* TODO: try other algo, using disp.codes .... *)
710
711
712
713
714
715
716
717
    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
718
    let accu = ref [] in
719
    let rec aux (success : (int * Normal.result) list) t l = 
720
721
722
      if Types.non_empty t 
      then match l with
	| [] ->
723
724
725
726
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
727
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
728
729
730
731
	    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
732
    in
733
    aux [] t tests;
734
735
736
    !accu


737
  let get_tests pl f t d post =
738
739
740
741
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
742
      List.iter (fun ( (pl,ty), info) -> accu := (ty,pl,i,info) :: !accu
743
744
745
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
746

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
    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
	) Types.LabelPool.dummy_max !accu in
    let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in

    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
763
    let infos = Array.map snd sorted in
764
    let disp = dispatcher t (Array.map fst sorted) lab in
765
    let result (t,_,m) =
766
      let selected = Array.create (Array.length pl) [] in
767
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
768
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
769
770
      d t selected unselect
    in
771
    let res = Array.map result disp.codes in
772
773
    post (disp,res)

774

775
776
777
778
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
779
	   let p' = ([p],t) in
780
781
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
782
	) (t,[]) brs in
783
	
784
785
786
787
788
789
790
791
    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 
792
	   | [(res,catchv,e)] -> assert (!r = None); 
793
794
	       let catchv = IdMap.constant (-1) catchv in
	       r := Some (IdMap.union_disj catchv res,e)
795
796
797
798
799
800
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
801
802


803
804
805
806
807
808
809
  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
810
811
    dispatch_prod0 disp t pl
  and dispatch_prod0 disp t pl =
812
813
814
815
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
816
      (fun x -> detect_left_tail_call (combine x))
817
818
  and dispatch_prod1 disp t t1 pl _ =
    get_tests pl
819
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
820
821
      (Types.Product.pi2_restricted t1 t)
      (dispatch_prod2 disp)
822
      (fun x -> detect_right_tail_call (combine x))
823
  and dispatch_prod2 disp t2 pl _ =
824
    let aux_final (ret2, ncatchv, (ret1, res)) =  
825
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
826
    return disp pl aux_final
827
828
829


  let rec dispatch_record disp : record option =
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
    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
				      | `Nolabel (Some x,_) -> [x]
				      | `Nolabel (None,_) -> []
				      | _ -> 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
				      | `Nolabel (_,Some x) -> [x]
				      | `Nolabel (_,None) -> []
				      | _ -> assert false) disp.pl in
		Some (return disp pl (IdMap.map_to_list conv_source_basic))
	      else None
	    in	      
	    Some (`Nolabel (some,none))
	| Some lab ->
	    let t = Types.Record.split t lab in
	    let pl = Array.map (fun p -> match p.Normal.nrecord with
				  | `Label (_,l) -> l
				  | _ -> assert false) disp.pl in
	    Some (`Label (lab,dispatch_prod0 disp t pl))
(* soucis avec les ncatchv ?? *)

863
      
864
865
866
867
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
868
869
870
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
871
		    (dispatch_prod ~kind:`XML disp)
872
873
		    (dispatch_record disp)
	  in
874
875
876
877
	  disp.actions <- Some a;
	  a

  let to_print = ref []
878
879
880

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

  let queue d =
883
884
    if not d.printed then (
      d.printed <- true;
885
886
887
      to_print := d :: !to_print
    )

888
  let rec print_source ppf = function
889
890
891
892
893
894
895
    | 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) -> 
896
	Format.fprintf ppf "(%a,%a)" 
897
898
	  print_source (Left i)
	  print_source (Right j)
899
900
901
902
903
904
905
906
907
908
909
910
911

  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

912
913
914
915
  let print_ret_opt ppf = function
    | None -> Format.fprintf ppf "*"
    | Some r -> print_ret ppf r

916
  let print_kind ppf actions =
917
    let print_lhs ppf (code,prefix,d) =
918
      let arity = match d.codes.(code) with (_,a,_) -> a in
919
920
921
922
923
924
925
      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) =
926
      Format.fprintf ppf " | %a -> %a@\n"
927
928
929
	Types.Print.print_descr t
	print_ret ret
    in
930
    let print_prod2 = function
931
932
      | Impossible -> assert false
      | Ignore r ->
933
934
	  Format.fprintf ppf "        %a\n" 
	    print_ret r
935
      | TailCall d ->
936
937
	  queue d;
	  Format.fprintf ppf "        disp_%i v2@\n" d.id
938
      | Dispatch (d, branches) ->
939
940
941
942
943
944
945
946
947
	  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
948
    in
949
    let print_prod prefix ppf = function
950
951
      | Impossible -> ()
      | Ignore d2 ->
952
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
953
	  print_prod2 d2
954
      | TailCall d ->
955
	  queue d;
956
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
957
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
958
      | Dispatch (d,branches) ->