patterns.ml 28.6 KB
Newer Older
1
2
3
4
5
6
  let wrap s f x =
    Printf.eprintf "%s start\n" s; flush stderr;
    let r = f x in
    Printf.eprintf "%s stop\n" s; flush stderr;
    r

7
8
9
type capture = string
type fv = capture SortedList.t

10
11
exception Error of string

12
13
14
15
16
17

(* Syntactic algebra *)

type d =
  | Constr of Types.node
  | Cup of descr * descr
18
  | Cap of descr * descr * bool
19
20
21
22
23
24
25
26
27
28
29
  | Times of node * node
  | 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

30
31
32
33
34
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
35
36
37
38
39
40
41
42

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

let constr x = (Types.descr x,[],Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
43
44
45
46
47
48
49
50
51
52
  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"))
  );
53
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
54
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e = 
55
56
57
58
59
60
61
62
63
  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
  );
64
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
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))


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


(* 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 =
  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)
100
      | Cap (d1,d2,true) ->
101
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
102
103
      | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
      | Times (p1,p2) ->
	  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 t)
      | 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))]

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



(* Normal forms for patterns and compilation *)

142
module Normal = 
143
144
145
146
147
148
149
150
151
152
153
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

154
  type 'a line = (result * 'a, Types.descr) sm
155
156
  type nf = {
    v     : fv;
157
    catchv: fv;  (* Variables catching the value *)
158
    a     : Types.descr;
159
160
161
162
163
164
165
166
167
168
169
    basic : unit line;
    prod  : (node sl * node sl) line;
    record: ((Types.label, node sl) sm) line
  }

  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `Fail
      | `Dispatch of (nf * record) list
      | `Label of Types.label * (nf * record) list * record ]
170
  type t = {
171
    nfv    : fv;
172
    ncatchv: fv;
173
    na     : Types.descr;
174
175
176
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
    nrecord: record nline
177
178
  }

179
180
181
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
		basic = []; prod = []; record = [] }
182
183
184
185
  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)


  let restrict t nf =
186
187
188
189
190
191
    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
192
    {  v = nf.v;
193
       catchv = nf.catchv;
194
       a = Types.cap t nf.a;
195
196
197
       basic = filter nf.basic;
       prod = filter nf.prod;
       record = filter nf.record;
198
199
200
201
202
203
    }

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

  let cap nf1 nf2 =
204
205
206
207
208
209
210
211
212
213
214
215
216
217
    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 () () = ()
218
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
219
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
220
    { v = SortedList.cup nf1.v nf2.v;
221
      catchv = SortedList.cup nf1.catchv nf2.catchv;
222
      a = Types.cap nf1.a nf2.a;
223
224
225
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
      record = merge merge_record nf1.record nf2.record;
226
227
228
229
230
231
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
232
    { v = nf1.v; (* = nf2.v *)
233
      catchv = SortedList.cap nf1.catchv nf2.catchv;
234
235
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
236
237
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
      record = SortedMap.union Types.cup nf1.record nf2.record;
238
239
240
241
242
243
244
245
246
    }

  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;
247
	prod = [ (src, ([p], [q])), acc ] }
248
249
250
251
252
253

  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
254
	record = [ (src, [l,[p]]), acc ] }
255
256

  let any =
257
258
    { v = []; 
      catchv = [];
259
      a = Types.any;
260
261
262
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      record = [ ([],[]), Types.Record.any ];
263
264
265
266
267
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
268
      catchv = [x];
269
      a = Types.any;
270
271
272
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
273
274
275
276
277
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
278
      catchv = [];
279
      a = Types.any;
280
281
282
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
283
284
285
286
    }

  let constr t =
    { v = [];
287
      catchv = [];
288
      a = t;
289
290
291
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
292
293
294
295
296
297
298
299
    }

(* Put a pattern in normal form *)
  let rec nf (acc,fv,d) =
    if Types.is_empty acc 
    then empty
    else match d with
      | Constr t -> constr (Types.descr t)
300
      | Cap (p,q,_) -> cap (nf p) (nf q)
301
302
303
304
305
306
307
308
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
      | 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

309
310
311
312
313
314
315
316
  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

    and prod =
      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
317
318
	let t = Types.Product.normal acc in
	List.fold_left aux accu t in
319
      List.fold_left line []
320
   
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

    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),_) ->
337
	      let aux_ab = aux ab fields in
338
	      let pr = 
339
340
341
342
343
344
		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)
345
346
347
348
349
350
351
352
353
354
      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
355
356
357
358
    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;
359
      na      = nf.a;
360
361
362
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
      nrecord = nlines (record nf.record);
363
    }
364

365
end
366
367


368
369
module Compile = 
struct
370
371
372
373
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
374
375
376
377
378
379
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
380
381
      | `Result of result
      | `Absent ]
382
      
383
384
385
386
387
388
389
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
  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
  }
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

  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

428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
  let combine_kind basic prod record =
    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
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
444
445
446
447
448
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
449
450
451
452
	| _ -> raise Exit
    )
    with Exit -> `Kind { basic = basic; prod = prod; record = record }

453
  let combine (disp,act) =
454
455
456
457
458
459
460
461
462
463
464
    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
465
      | (`Ignore `Absent, Some r) -> r
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
      | (`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
   
503
504
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
505
		 
506
507
  module DispMap = Map.Make(
    struct
508
      type t = Types.descr * Normal.t array
509
510
511
      let compare = compare
    end
  )
512
    
513
  let dispatchers = ref DispMap.empty
514
515
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
516

517
    
518
519
520
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
521
522
523
524
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
525
	  if i = Array.length pl 
526
	  then (incr nb; `Result (!nb - 1, t, arity))
527
528
	  else
	    let p = pl.(i) in
529
530
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
531
532
533
534
535
536
537
538
539

	    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;
*)
	    
540
(*	    let tp = Types.normalize tp in *)
541
542
543
544
545
546
547
548
549
550
551
552
553
	    `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
	| `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)
554
      in
555
      aux 0 [] iface;
556
557
558
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
559
560
		  interface = iface;
		  codes = codes;
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
		  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

576
577
578
579
580
581
582
583
584
585
  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
      | `None -> assert false
      | `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 =
586
587
588
589
590
591
592
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
593
594
595
596
597
598
599

  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
600
601
602
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

603
604
605
  let assoc v l =
    try List.assoc v l with Not_found -> -1

606
607
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
608
609
610
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
611
    | _ -> assert false
612

613
614
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
615
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
616
617
618
619
620
621
622
623
624
625
626
627
    | _ -> 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
628
    let accu = ref [] in
629
    let rec aux (success : (int * Normal.result) list) t l = 
630
631
632
      if Types.non_empty t 
      then match l with
	| [] ->
633
634
635
636
637
638
639
640
641
	    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
642
    in
643
    aux [] t tests;
644
645
646
    !accu


647
  let get_tests pl f t d post =
648
649
650
651
652
    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) ->
653
654
655
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
656
657
658
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
659

660
661
662
    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
663
    let result (t,_,m) =
664
665
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
666
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
667
668
      d t selected unselect
    in
669
    let res = Array.map result disp.codes in
670
671
    post (disp,res)

672

673
674
675
676
677
678
  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
679
	   (t, (p,(p.Normal.catchv,e)) :: brs)
680
	) (t,[]) brs in
681
	
682
683
684
685
686
687
688
689
    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 
690
691
692
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
693
694
695
696
697
698
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
699
700


701
702
  let rec dispatch_prod disp =
    let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
703
704
705
706
707
    let t = Types.Product.get disp.t in
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
708
      (fun x -> detect_left_tail_call (combine x))
709
710
711
712
713
714
  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)
715
      (fun x -> detect_right_tail_call (combine x))
716
  and dispatch_prod2 disp t t2 pl _ =
717
718
719
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
720
721


722
  let dummy_label = Types.LabelPool.dummy_max
723
724
725
726

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
727
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
728
729
      | _ -> () in
    Array.iter (List.iter aux) pl;
730
    if !m = dummy_label then None else Some !m
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750

  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)

751
(*
752
753
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
754
*)
755
756
757
758
759

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
760
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
	   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) -> 
778
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
779
780
781
782
783
784
785
786
787
			   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

788
  let rec dispatch_record disp : record option =
789
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
790
791
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
792
    let r = dispatch_record_opt disp t pl0 in
793
(*    memo_dispatch_record := []; *)
794
    r
795
796
797
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
798
799
800
801
802
803
804
805
806
807
808
(*  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 *)
809
810
811
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
812
813
814
815
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
816
      | Some l ->
817
818
819
820
821
	  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
822
823
824
825
826
827
828
829
830
	  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)
831
	      (dispatch_record_field l disp t plabs)
832
	      (fun x -> combine x)
833
	  in
834
	  combine_record l present absent
835
  and dispatch_record_field l disp t plabs tfield pl others =
836
    let t = Types.Record.restrict_field t l tfield in
837
838
839
    let aux (ret, (res, catch, rem)) = 
      let catch = if ret = [] then catch else (l,ret) :: catch in
      (res, catch, rem) in
840
841
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
842
843
844
    if pl = plabs then `Absent else
      (* TODO: Check that this is the good condition ....
	 Need condition on t ? *)
845
846
    dispatch_record_label disp t pl
    
847
      
848
849
850
851
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
852
853
854
855
856
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
		    (dispatch_record disp)
	  in
857
858
859
860
861
862
863
864
865
866
867
868
	  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
    )

869
  let rec print_source ppf = function
870
871
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
872
873
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
874
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
875
876
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
877
878
879
880
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
881
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
882
883
884
885
886
887
888
889
890
891
892
893
894
895

  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 =
896
    let print_lhs ppf (code,prefix,d) =
897
      let arity = match d.codes.(code) with (_,a,_) -> a in
898
899
900
901
902
903
904
      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) =
905
      Format.fprintf ppf " | %a -> %a@\n"
906
907
908
	Types.Print.print_descr t
	print_ret ret
    in
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
    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
927
    in
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
    let print_prod  = function
      | `None -> ()
      | `Ignore d2 ->
	  Format.fprintf ppf " | (v1,v2) -> @\n";
	  print_prod2 d2
      | `TailCall d ->
	  queue d;
	  Format.fprintf ppf " | (v1,v2) -> @\n";
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf " | (v1,v2) -> @\n";
	  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
948
949
950
951
952
953
954
955
    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
956
      | `Absent -> Format.fprintf ppf "Jump to Absent"
957
      | `Label (l, present, absent) ->
958
	  let l = Types.LabelPool.value l in
959
960
961
962
963
964
965
966
967
968
	  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 ->
969
	  queue d;
970
971
972
973
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
974
975
	  Array.iteri
	    (fun code r ->
976
	       Format.fprintf ppf "| %a -> @\n"
977
	         print_lhs (code, l, d);
978
	       Format.fprintf ppf "   @[%a@]@\n"
979
	         print_record r
980
981
982
983
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf "@[%a@]@\n"
	    print_record r
984
985
986
987
988
989
    in
    
    List.iter print_basic actions.basic;
    print_prod actions.prod;
    print_record_opt ppf actions.record

990
991
992
993
  let print_actions ppf = function
    | `Kind k -> print_kind ppf k
    | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r

994
995
996
997
998
  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
	  to_print := rem;
999
1000
(*	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
	    d.id Types.Print.print_descr (Types.normalize d.t); *)
1001
1002
1003
	  let print_code code (t, arity, m) =
	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
	      code arity
1004
	      Types.Print.print_descr (Types.normalize t);
1005

1006
1007
1008
	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
1009
1010
1011
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
1012
		      Format.fprintf ppf "]"
1013
	       ) m; 
1014

1015
1016
	       Format.fprintf ppf "@\n";
	  in
1017
(*	  Array.iteri print_code d.codes;  *)
1018
	  Format.fprintf ppf "let disp_%i = function@\n" d.id;
1019
	  print_actions ppf (actions d);
1020
	  Format.fprintf ppf "====================================@\n";
1021
1022
1023
1024
1025
1026
1027
	  print_dispatchers ppf

  let show ppf t pl =
    let disp = dispatcher t pl in
    queue disp;
    print_dispatchers ppf

1028
1029
  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)
1030

1031
end
1032
1033