patterns.ml 28.2 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
type capture = string
type fv = capture SortedList.t
9

10
11
exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv
12

13
(* Syntactic algebra *)
14

15
type d =
16
  | Constr of Types.node
17
  | Cup of descr * descr
18
  | Cap of descr * descr * bool
19
  | Times of node * node
20
21
22
  | Record of Types.label * node
  | Capture of capture
  | Constant of capture * Types.const
23
24
and node = {
  id : int;
25
26
  mutable descr : descr option;
  accept : Types.node;
27
  fv : fv
28
} and descr = Types.descr * fv * d
29

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

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

41
let constr x = (Types.descr x,[],Constr x)
42
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
43
44
  if fv1 <> fv2 then raise (IllFormedCup (fv1,fv2));
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
45
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e = 
46
  if not (SortedList.disjoint fv1 fv2) then raise (IllFormedCap (fv1,fv2));
47
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
48
let times x y =
49
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
50
let record l x = 
51
52
53
  (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))
54

55
56
57
58
59

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
60

61
62
63
64

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
65
let empty_res fv = List.map (fun v -> (v, Types.Positive.ty Types.empty)) fv
66
67
68
let times_res v1 v2 = Types.Positive.times v1 v2

module MemoFilter = Map.Make 
69
  (struct type t = Types.descr * node let compare = compare end)
70
71
72

let memo_filter = ref MemoFilter.empty

73
let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
74
75
76
77
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
78
      | Constr _ -> []
79
      | Cup ((a,_,_) as d1,d2) ->
80
	  SortedMap.union cup_res
81
82
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
83
      | Cap (d1,d2,true) ->
84
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
85
86
      | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
87
88
89
90
91
92
93
94
95
96
97
98
      | 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)
99
100
101
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
102
	  [(c, Types.Positive.ty t)]
103
      | Constant (c, cst) ->
104
105
106
	  [(c, Types.Positive.ty (Types.constant cst))]

and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
107
108
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
109
110
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
111
112
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
113
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
114
115
116
117
118
    r

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

121

122

123
(* Normal forms for patterns and compilation *)
124

125
module Normal = 
126
127
128
129
130
131
132
133
134
135
136
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

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

162
163
164
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
		basic = []; prod = []; record = [] }
165
  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)
166

167

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

183
184
  let fus = SortedMap.union_disj
  let slcup = SortedList.cup
185

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

211

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

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

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

  let any =
240
241
    { v = []; 
      catchv = [];
242
      a = Types.any;
243
244
245
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      record = [ ([],[]), Types.Record.any ];
246
    }
247

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

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

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

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

292
293
294
295
296
297
298
299
  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
300
301
	let t = Types.Product.normal acc in
	List.fold_left aux accu t in
302
      List.fold_left line []
303
   
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319

    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),_) ->
320
	      let aux_ab = aux ab fields in
321
	      let pr = 
322
323
324
325
326
327
		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)
328
329
330
331
332
333
334
335
336
337
      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
338
339
340
341
    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;
342
      na      = nf.a;
343
344
345
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
      nrecord = nlines (record nf.record);
346
    }
347

348
end
349
350


351
352
module Compile = 
struct
353
354
355
356
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
357
358
359
360
361
362
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
363
364
      | `Result of result
      | `Absent ]
365
      
366
367
368
369
370
371
372
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
  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
  }
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410

  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

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
  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
427
428
429
430
431
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
432
433
434
435
	| _ -> raise Exit
    )
    with Exit -> `Kind { basic = basic; prod = prod; record = record }

436
  let combine (disp,act) =
437
438
439
440
441
442
443
444
445
446
447
    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
448
      | (`Ignore `Absent, Some r) -> r
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
      | (`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
   
486
487
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
488
		 
489
490
  module DispMap = Map.Make(
    struct
491
      type t = Types.descr * Normal.t array
492
493
494
      let compare = compare
    end
  )
495
    
496
  let dispatchers = ref DispMap.empty
497
498
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
499

500
    
501
502
503
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
504
505
506
507
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
508
	  if i = Array.length pl 
509
	  then (incr nb; `Result (!nb - 1, t, arity))
510
511
	  else
	    let p = pl.(i) in
512
513
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
514
515
516
517
518
519
520
521
522

	    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;
*)
	    
523
(*	    let tp = Types.normalize tp in *)
524
525
526
527
528
529
530
531
532
533
534
535
536
	    `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)
537
      in
538
      aux 0 [] iface;
539
540
541
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
542
543
		  interface = iface;
		  codes = codes;
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
		  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

559
560
561
562
563
564
565
566
567
568
  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 =
569
570
571
572
573
574
575
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
576
577
578
579
580
581
582

  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
583
584
585
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

586
587
588
  let assoc v l =
    try List.assoc v l with Not_found -> -1

589
590
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
591
592
593
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
594
    | _ -> assert false
595

596
597
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
598
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
599
600
601
602
603
604
605
606
607
608
609
610
    | _ -> 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
611
    let accu = ref [] in
612
    let rec aux (success : (int * Normal.result) list) t l = 
613
614
615
      if Types.non_empty t 
      then match l with
	| [] ->
616
617
618
619
620
621
622
623
624
	    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
625
    in
626
    aux [] t tests;
627
628
629
    !accu


630
  let get_tests pl f t d post =
631
632
633
634
635
    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) ->
636
637
638
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
639
640
641
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
642

643
644
645
    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
646
    let result (t,_,m) =
647
648
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
649
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
650
651
      d t selected unselect
    in
652
    let res = Array.map result disp.codes in
653
654
    post (disp,res)

655

656
657
658
659
660
661
  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
662
	   (t, (p,(p.Normal.catchv,e)) :: brs)
663
	) (t,[]) brs in
664
	
665
666
667
668
669
670
671
672
    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 
673
674
675
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
676
677
678
679
680
681
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
682
683


684
685
  let rec dispatch_prod disp =
    let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
686
687
688
689
690
    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)
691
      (fun x -> detect_left_tail_call (combine x))
692
693
694
695
696
697
  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)
698
      (fun x -> detect_right_tail_call (combine x))
699
  and dispatch_prod2 disp t t2 pl _ =
700
701
702
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
703
704


705
  let dummy_label = Types.LabelPool.dummy_max
706
707
708
709

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
710
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
711
712
      | _ -> () in
    Array.iter (List.iter aux) pl;
713
    if !m = dummy_label then None else Some !m
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733

  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)

734
(*
735
736
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
737
*)
738
739
740
741
742

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
743
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
	   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) -> 
761
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
762
763
764
765
766
767
768
769
770
			   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

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

852
  let rec print_source ppf = function
853
854
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
855
856
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
857
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
858
859
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
860
861
862
863
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
864
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
865
866
867
868
869
870
871
872
873
874
875
876
877
878

  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 =
879
    let print_lhs ppf (code,prefix,d) =
880
      let arity = match d.codes.(code) with (_,a,_) -> a in
881
882
883
884
885
886
887
      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) =
888
      Format.fprintf ppf " | %a -> %a@\n"
889
890
891
	Types.Print.print_descr t
	print_ret ret
    in
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
    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
910
    in
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
    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
931
932
933
934
935
936
937
938
    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
939
      | `Absent -> Format.fprintf ppf "Jump to Absent"
940
      | `Label (l, present, absent) ->
941
	  let l = Types.LabelPool.value l in
942
943
944
945
946
947
948
949
950
951
	  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 ->
952
	  queue d;
953
954
955
956
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
957
958
	  Array.iteri
	    (fun code r ->
959
	       Format.fprintf ppf "| %a -> @\n"
960
	         print_lhs (code, l, d);
961
	       Format.fprintf ppf "   @[%a@]@\n"
962
	         print_record r
963
964
965
966
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf "@[%a@]@\n"
	    print_record r
967
968
969
970
971
972
    in
    
    List.iter print_basic actions.basic;
    print_prod actions.prod;
    print_record_opt ppf actions.record

973
974
975
976
  let print_actions ppf = function
    | `Kind k -> print_kind ppf k
    | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r

977
978
979
980
981
  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
	  to_print := rem;
982
983
(*	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
	    d.id Types.Print.print_descr (Types.normalize d.t); *)
984
985
986
	  let print_code code (t, arity, m) =
	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
	      code arity
987
	      Types.Print.print_descr (Types.normalize t);
988

989
990
991
	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
992
993
994
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
995
		      Format.fprintf ppf "]"
996
	       ) m; 
997

998
999
	       Format.fprintf ppf "@\n";
	  in
1000
(*	  Array.iteri print_code d.codes;  *)
1001
	  Format.fprintf ppf "let disp_%i = function@\n" d.id;
1002
	  print_actions ppf (actions d);
1003
	  Format.fprintf ppf "====================================@\n";
1004
1005
1006
1007
1008
1009
1010
	  print_dispatchers ppf

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

1011
1012
  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)
1013

1014
end
1015
1016