patterns.ml 25.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
type capture = string
type fv = capture SortedList.t

exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv

(* Syntactic algebra *)

type d =
  | Constr of Types.node
  | Cup of descr * descr
12
  | Cap of descr * descr * bool
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
  | 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

let make =
  let counter = ref 0 in
  fun fv ->
    incr counter;
    { id = !counter; descr = None; accept = Types.make (); fv = fv }

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) = 
  if fv1 <> fv2 then raise (IllFormedCup (fv1,fv2));
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
39
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e = 
40
  if not (SortedList.disjoint fv1 fv2) then raise (IllFormedCap (fv1,fv2));
41
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
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)
77
      | Cap (d1,d2,true) ->
78
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
79
80
      | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
      | 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 *)

119
module Normal = 
120
121
122
123
124
125
126
127
128
129
130
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

131
  type 'a line = (result * 'a, Types.descr) sm
132
133
  type nf = {
    v     : fv;
134
    catchv: fv;  (* Variables catching the value *)
135
    a     : Types.descr;
136
137
138
139
140
141
142
143
144
145
146
    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 ]
147
  type t = {
148
    nfv    : fv;
149
    ncatchv: fv;
150
    na     : Types.descr;
151
152
153
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
    nrecord: record nline
154
155
  }

156
157
158
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
		basic = []; prod = []; record = [] }
159
160
161
162
  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)


  let restrict t nf =
163
164
165
166
167
168
    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
169
    {  v = nf.v;
170
       catchv = nf.catchv;
171
       a = Types.cap t nf.a;
172
173
174
       basic = filter nf.basic;
       prod = filter nf.prod;
       record = filter nf.record;
175
176
177
178
179
180
    }

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

  let cap nf1 nf2 =
181
182
183
184
185
186
187
188
189
190
191
192
193
194
    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 () () = ()
195
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
196
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
197
    { v = SortedList.cup nf1.v nf2.v;
198
      catchv = SortedList.cup nf1.catchv nf2.catchv;
199
      a = Types.cap nf1.a nf2.a;
200
201
202
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
      record = merge merge_record nf1.record nf2.record;
203
204
205
206
207
208
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
209
    { v = nf1.v; (* = nf2.v *)
210
      catchv = SortedList.cap nf1.catchv nf2.catchv;
211
212
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
213
214
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
      record = SortedMap.union Types.cup nf1.record nf2.record;
215
216
217
218
219
220
221
222
223
    }

  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;
224
	prod = [ (src, ([p], [q])), acc ] }
225
226
227
228
229
230

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

  let any =
234
235
    { v = []; 
      catchv = [];
236
      a = Types.any;
237
238
239
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      record = [ ([],[]), Types.Record.any ];
240
241
242
243
244
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
245
      catchv = [x];
246
      a = Types.any;
247
248
249
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
250
251
252
253
254
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
255
      catchv = [];
256
      a = Types.any;
257
258
259
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
260
261
262
263
    }

  let constr t =
    { v = [];
264
      catchv = [];
265
      a = t;
266
267
268
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
269
270
271
272
273
274
275
276
    }

(* 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)
277
      | Cap (p,q,_) -> cap (nf p) (nf q)
278
279
280
281
282
283
284
285
286
      | 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


287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
  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
	List.fold_left aux accu (Types.Product.normal acc) in
      List.fold_left line []

    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),_) ->
	      let pr = 
		List.map (fun (t,x) -> (constr t, aux x fields)) pr in
	      `Label (l1, pr, aux ab fields)
      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
326
327
328
329
    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;
330
      na      = nf.a;
331
332
333
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
      nrecord = nlines (record nf.record);
334
    }
335
end
336
337


338
339
module Compile = 
struct
340
341
342
343
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
344
345
346
347
348
349
350
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
      | `Result of result ]
351
      
352
353
354
355
356
357
358
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
  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
  }
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396

  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

397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
  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
413
414
415
416
417
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
418
419
420
421
	| _ -> raise Exit
    )
    with Exit -> `Kind { basic = basic; prod = prod; record = record }

422
  let combine (disp,act) =
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
    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
      | (`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
   
471
472
  let cur_id = ref 0
		 
473
474
  module DispMap = Map.Make(
    struct
475
      type t = Types.descr * Normal.t array
476
477
478
      let compare = compare
    end
  )
479
    
480
  let dispatchers = ref DispMap.empty
481
482
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
483

484
    
485
486
487
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
488
489
490
491
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
492
	  if i = Array.length pl 
493
	  then (incr nb; `Result (!nb - 1, t, arity))
494
495
	  else
	    let p = pl.(i) in
496
497
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
498
499
500
501
502
503
504
505
506

	    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;
*)
	    
507
(*	    let tp = Types.normalize tp in *)
508
509
510
511
512
513
514
515
516
517
518
519
520
	    `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)
521
      in
522
      aux 0 [] iface;
523
524
525
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
526
527
		  interface = iface;
		  codes = codes;
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
		  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

543
544
545
546
547
548
549
550
551
552
  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 =
553
554
555
556
557
558
559
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
560
561
562
563
564
565
566

  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
567
568
569
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

570
571
572
  let assoc v l =
    try List.assoc v l with Not_found -> -1

573
574
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
575
576
577
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
578
    | _ -> assert false
579

580
581
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
582
    | `Field l -> `Field (l, assoc v (List.assoc l catch))
583
584
585
586
587
588
589
590
591
592
593
594
    | _ -> 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
595
    let accu = ref [] in
596
    let rec aux (success : (int * Normal.result) list) t l = 
597
598
599
      if Types.non_empty t 
      then match l with
	| [] ->
600
601
602
603
604
605
606
607
608
	    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
609
    in
610
    aux [] t tests;
611
612
613
    !accu


614
  let get_tests pl f t d post =
615
616
617
618
619
    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) ->
620
		   let p = Normal.normal (Normal.restrict t p) in
621
622
623
624
		   accu := (p,[i, info]) :: !accu
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
625

626
627
628
    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
629
    let result (t,_,m) =
630
631
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
632
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
633
634
      d t selected unselect
    in
635

636
    let res = Array.map result disp.codes in
637
638
639
640
641
642
643
644
    post (disp,res)

  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
645
	   (t, (p,(p.Normal.catchv,e)) :: brs)
646
	) (t,[]) brs in
647
	
648
649
650
651
652
653
654
655
    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 
656
657
658
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
659
660
661
662
663
664
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
665
666


667
668
  let rec dispatch_prod disp =
    let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
669
670
671
672
673
    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)
674
      (fun x -> detect_left_tail_call (combine x))
675
676
677
678
679
680
  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)
681
      (fun x -> detect_right_tail_call (combine x))
682
  and dispatch_prod2 disp t t2 pl _ =
683
684
685
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718


  let dummy_label = Types.label ""

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
      | (res, _, `Label (l, _, _)) ->
	  if (!f) then (f := false; m := l) else if (l < !m) then m:= l;
      | _ -> () in
    Array.iter (List.iter aux) pl;
    if !f then None else Some !m

  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)

  let rec dispatch_record disp : record option =
719
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
720
721
722
723
724
725
726
727
728
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
    dispatch_record_opt disp t pl0
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
729
730
731
732
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
733
734
735
736
737
738
739
740
741
742
743
      | Some l ->
	  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)
	      (dispatch_record_field l disp t)
744
	      (fun x -> combine x)
745
746
747
748
749
750
	  in
	  let absent = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    dispatch_record_opt disp t pl
	  in
751
	  combine_record l present absent
752
753
754
755
756
757
758
759
760
761
762
763
  and dispatch_record_field l disp t tfield pl others =
    let t = Types.Record.restrict_field t l tfield in
    let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
    dispatch_record_label disp t pl
    

  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
764
765
766
767
768
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
		    (dispatch_record disp)
	  in
769
770
771
772
773
774
775
776
777
778
779
780
	  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
    )

781
  let rec print_source ppf = function
782
783
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
784
785
786
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.label_name l)
787
788
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
789
790
791
792
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i

  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 =
808
    let print_lhs ppf (code,prefix,d) =
809
      let arity = match d.codes.(code) with (_,a,_) -> a in
810
811
812
813
814
815
816
      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) =
817
      Format.fprintf ppf " | %a -> %a@\n"
818
819
820
	Types.Print.print_descr t
	print_ret ret
    in
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
    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
839
    in
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
    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
860
861
862
863
864
865
866
867
    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
868
      | `Label (l, present, absent) ->
869
	  let l = Types.label_name l in
870
871
872
873
874
875
876
877
878
879
	  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 ->
880
	  queue d;
881
882
883
884
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
885
886
	  Array.iteri
	    (fun code r ->
887
	       Format.fprintf ppf "| %a -> @\n"
888
	         print_lhs (code, l, d);
889
	       Format.fprintf ppf "   @[%a@]@\n"
890
	         print_record r
891
892
893
894
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf "@[%a@]@\n"
	    print_record r
895
896
897
898
899
900
    in
    
    List.iter print_basic actions.basic;
    print_prod actions.prod;
    print_record_opt ppf actions.record

901
902
903
904
  let print_actions ppf = function
    | `Kind k -> print_kind ppf k
    | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r

905
906
907
908
909
910
  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
	  to_print := rem;
	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
911
	    d.id Types.Print.print_descr (Types.normalize d.t);
912
913
914
	  let print_code code (t, arity, m) =
	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
	      code arity
915
	      Types.Print.print_descr (Types.normalize t);
916

917
918
919
	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
920
921
922
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
923
		      Format.fprintf ppf "]"
924
	       ) m; 
925

926
927
	       Format.fprintf ppf "@\n";
	  in
928
(*	  Array.iteri print_code d.codes;  *)
929
	  Format.fprintf ppf "let disp_%i = function@\n" d.id;
930
	  print_actions ppf (actions d);
931
	  Format.fprintf ppf "====================================@\n";
932
933
934
935
936
937
938
	  print_dispatchers ppf

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

939
940
  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)
941

942
end
943
944