patterns.ml 32 KB
Newer Older
1
2
type capture = string
type fv = capture SortedList.t
3

4
5
exception Error of string

6

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

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

let printed = ref []
let to_print = ref []
let rec print ppf (_,_,d) = 
  match d with
    | Constr t -> Types.Print.print_descr ppf t
    | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
    | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
    | Times (n1,n2) -> 
	Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Xml (n1,n2) -> 
	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Record (l,n) -> 
	Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
	to_print := n :: !to_print
    | Capture x ->
	Format.fprintf ppf "%s" x
    | Constant (x,c) ->
	Format.fprintf ppf "(%s := %a)" x Types.Print.print_const c



49
50
51
52
53
let counter = State.ref "Patterns.counter" 0

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

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

60
let constr x = (x,[],Constr x)
61
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
62
63
64
65
66
67
68
69
70
71
  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"))
  );
72
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
73
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
74
75
76
77
78
79
80
81
82
  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
  );
83
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
84
let times x y =
85
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
86
87
let xml x y =
  (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
88
let record l x = 
89
90
91
  (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))
92

93
94
95
96
97

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
98

99
100
101
102

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
103
let empty_res fv = List.map (fun v -> (v, Types.Positive.ty Types.empty)) fv
104
105
106
let times_res v1 v2 = Types.Positive.times v1 v2

module MemoFilter = Map.Make 
107
  (struct type t = Types.descr * node let compare = compare end)
108
109
110

let memo_filter = ref MemoFilter.empty

111
let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
112
(* TODO: avoid is_empty t when t is not changing (Cap) *)
113
114
115
116
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
117
      | Constr _ -> []
118
      | Cup ((a,_,_) as d1,d2) ->
119
	  SortedMap.union cup_res
120
121
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
122
      | Cap (d1,d2) ->
123
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
124
125
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
126
127
128
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
129
	  [(c, Types.Positive.ty t)]
130
      | Constant (c, cst) ->
131
132
	  [(c, Types.Positive.ty (Types.constant cst))]

133
134
135
136
137
138
139
140
141
142
143
144
and filter_prod ?kind fv p1 p2 t =
  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 ?kind t)


145
and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
146
147
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
148
149
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
150
151
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
152
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
153
154
155
156
157
    r

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

160

161

162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
(* Returns a pattern q equivalent to p when applied to a
   value of type t *)

type pat = 
    Types.descr 
    * capture SortedList.t 
    * (capture, Types.const) SortedMap.t
    * patd
and patd =
  | One
  | Zero
  | Alt of pat * pat
  | And of pat * pat
  | Prod of node * node
  | XML of node * node
  | Rec of Types.label * node

let rec restrict ((a,fv,d) as p) t =
  (* TODO OPT: Don't call cup,cap .... *)
  match d with
    | Constr s ->
	constr (Types.cap t a)
	(* Could return any type  (t&s)|u  with u&t=0 *)
    | Cup (((a1,_,_) as p1),((a2,_,_) as p2)) ->
	let p1 = 
	  if Types.is_empty (Types.cap t a1) then None 
	  else Some (restrict p1 t) in
	let p2 =
	  let t' = Types.diff t a1 in
	  if Types.is_empty (Types.cap t' a2) then None 
	  else Some (restrict p2 t') in
	(match (p1,p2) with
	   | Some p1, Some p2 -> cup p1 p2
	   | Some p1, None -> p1
	   | None, Some p2 -> p2
	   | _ -> assert false)
    | Cap ((_,_,Constr s), p') 
    | Cap (p', (_,_,Constr s)) when Types.subtype t s -> restrict p' t
    | Cap (p1,p2) -> cap (restrict p1 t) (restrict p2 t)
    | Capture _ | Constant (_,_) -> p
    | _ -> (Types.cap a t, fv, d)
  
let restrict ((a,fv,_) as p) t =
  if Types.is_empty (Types.cap a t) then `Reject
  else if (fv = []) && (Types.subtype t a) then `Accept
  else `Pat (restrict p t)


210
(* Normal forms for patterns and compilation *)
211

212
module Normal = 
213
214
215
216
217
218
219
220
221
222
223
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

224
  type 'a line = (result * 'a, Types.descr) sm
225
226
  type nf = {
    v     : fv;
227
    catchv: fv;  (* Variables catching the value *)
228
    a     : Types.descr;
229
230
    basic : unit line;
    prod  : (node sl * node sl) line;
231
232
233
    xml   : (node sl * node sl) line;
    record: ((Types.label, node sl) sm) line;

234
235
236
237
238
239
240
241
  }

  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `Fail
      | `Dispatch of (nf * record) list
      | `Label of Types.label * (nf * record) list * record ]
242
  type t = {
243
    nfv    : fv;
244
    ncatchv: fv;
245
    na     : Types.descr;
246
247
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
248
    nxml   : (nf * nf) nline;
249
    nrecord: record nline
250
  }
251

252
253
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
254
255
256
257
258
		basic = []; prod = []; xml = []; record = [] }
  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
			       [Types.Product.any_xml;
				Types.Product.any;
				Types.Record.any])
259
  let restrict t nf =
260
261
262
263
264
265
    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
266
    {  v = nf.v;
267
       catchv = nf.catchv;
268
       a = Types.cap t nf.a;
269
270
       basic = filter nf.basic;
       prod = filter nf.prod;
271
       xml = filter nf.xml;
272
       record = filter nf.record;
273
    }
274

275
276
  let fus = SortedMap.union_disj
  let slcup = SortedList.cup
277

278
  let cap nf1 nf2 =
279
280
281
282
283
284
285
286
287
288
289
290
291
292
    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 () () = ()
293
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
294
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
295
    { v = SortedList.cup nf1.v nf2.v;
296
      catchv = SortedList.cup nf1.catchv nf2.catchv;
297
      a = Types.cap nf1.a nf2.a;
298
299
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
300
      xml = merge merge_prod nf1.xml nf2.xml;
301
      record = merge merge_record nf1.record nf2.record;
302
    }
303

304

305
306
307
		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
308
    { v = nf1.v; (* = nf2.v *)
309
      catchv = SortedList.cap nf1.catchv nf2.catchv;
310
311
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
312
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
313
      xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
314
      record = SortedMap.union Types.cup nf1.record nf2.record;
315
    }
316

317
318
319
320
321
322
323
  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;
324
	prod = [ (src, ([p], [q])), acc ] }
325

326
327
328
329
330
331
332
333
334
  let xml 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;
	xml = [ (src, ([p], [q])), acc ] }

335
336
337
338
339
  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
340
	record = [ (src, [l,[p]]), acc ] }
341
342

  let any =
343
344
    { v = []; 
      catchv = [];
345
      a = Types.any;
346
347
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
348
      xml   = [ ([],([],[])), Types.Product.any_xml ];
349
      record = [ ([],[]), Types.Record.any ];
350
    }
351

352
353
354
  let capture x =
    let l = [x,`Catch] in
    { v = [x];
355
      catchv = [x];
356
      a = Types.any;
357
358
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
359
      xml  = [ (l,([],[])), Types.Product.any_xml  ];
360
      record = [ (l,[]), Types.Record.any ];
361
    }
362

363
364
365
  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
366
      catchv = [];
367
      a = Types.any;
368
369
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
370
      xml   = [ (l,([],[])), Types.Product.any_xml  ];
371
      record = [ (l,[]), Types.Record.any ];
372
    }
373

374
375
  let constr t =
    { v = [];
376
      catchv = [];
377
      a = t;
378
379
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
380
      xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
381
      record = [ ([],[]), Types.cap t Types.Record.any ];
382
    }
383

384
385
386
387
388
(* Put a pattern in normal form *)
  let rec nf (acc,fv,d) =
    if Types.is_empty acc 
    then empty
    else match d with
389
390
      | Constr t -> constr t
      | Cap (p,q) -> cap (nf p) (nf q)
391
392
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
393
      | Xml (p,q) -> xml acc p q
394
395
396
397
398
399
      | 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

400
401
402
403
  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

404
    and prod ?kind l =
405
406
407
      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
408
	let t = Types.Product.normal ?kind acc in
409
	List.fold_left aux accu t in
410
      List.fold_left line [] l
411
   
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427

    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),_) ->
428
	      let aux_ab = aux ab fields in
429
	      let pr = 
430
431
432
433
434
435
		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)
436
437
438
439
440
441
442
443
444
445
      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
446
447
448
449
    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;
450
      na      = nf.a;
451
452
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
453
      nxml    = nlines (prod ~kind:`XML nf.xml);
454
      nrecord = nlines (record nf.record);
455
    }
456

457
end
458
459


460
461
module Compile = 
struct
462
463
464
465
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
466
467
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
468
    xml: result dispatch dispatch;
469
470
471
472
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
473
474
      | `Result of result
      | `Absent ]
475
      
476
477
478
479
480
481
482
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
  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
  }
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520

  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

521
  let combine_kind basic prod xml record =
522
523
524
525
526
527
528
529
530
531
    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
532
533
534
535
      let rs = match xml with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
536
537
538
539
540
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
541
542
543
544
545
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
546
547
	| _ -> raise Exit
    )
548
    with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
549

550
  let combine (disp,act) =
551
552
553
554
555
556
557
558
559
560
561
    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
562
      | (`Ignore `Absent, Some r) -> r
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
      | (`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
   
600
601
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
602
		 
603
604
  module DispMap = Map.Make(
    struct
605
      type t = Types.descr * Normal.t array
606
607
608
      let compare = compare
    end
  )
609
    
610
  let dispatchers = ref DispMap.empty
611
612
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
613

614
    
615
616
617
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
618
619
620
621
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
622
	  if i = Array.length pl 
623
	  then (incr nb; `Result (!nb - 1, t, arity))
624
625
	  else
	    let p = pl.(i) in
626
627
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
628
629
630
631
632
633
634
635
636

	    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;
*)
	    
637
(*	    let tp = Types.normalize tp in *)
638
639
640
641
642
643
644
645
646
647
648
649
	    `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
650
651
	| `Result (code,t,arity) -> 
	    codes.(code) <- (t,arity, accu)
652
      in
653
      aux 0 [] iface;
654
655
656
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
657
658
		  interface = iface;
		  codes = codes;
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
		  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

674
675
676
  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
677
678
      | `None -> 
	  assert false
679
680
681
682
683
684
      | `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 =
685
686
687
688
689
690
691
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
692
693
694
695
696
697
698

  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
699
700
701
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

702
703
704
  let assoc v l =
    try List.assoc v l with Not_found -> -1

705
706
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
707
708
709
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
710
    | _ -> assert false
711

712
713
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
714
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
715
716
717
718
719
720
721
722
723
724
725
726
    | _ -> 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
727
    let accu = ref [] in
728
    let rec aux (success : (int * Normal.result) list) t l = 
729
730
731
      if Types.non_empty t 
      then match l with
	| [] ->
732
733
734
735
736
737
738
739
740
	    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
741
    in
742
    aux [] t tests;
743
744
745
    !accu


746
  let get_tests pl f t d post =
747
748
749
750
751
    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) ->
752
753
754
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
755
756
757
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
758

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

771

772
773
774
775
776
777
  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
778
	   (t, (p,(p.Normal.catchv,e)) :: brs)
779
	) (t,[]) brs in
780
	
781
782
783
784
785
786
787
788
    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 
789
790
791
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
792
793
794
795
796
797
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
798
799


800
801
802
803
804
805
806
  let rec dispatch_prod ?(kind=`Normal) disp =
    let pl = 
      match kind with
	| `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
	| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
    in
    let t = Types.Product.get ~kind disp.t in
807
808
809
810
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
811
      (fun x -> detect_left_tail_call (combine x))
812
813
814
815
816
817
  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)
818
      (fun x -> detect_right_tail_call (combine x))
819
  and dispatch_prod2 disp t t2 pl _ =
820
821
822
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
823
824


825
  let dummy_label = Types.LabelPool.dummy_max
826
827
828
829

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
830
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
831
832
      | _ -> () in
    Array.iter (List.iter aux) pl;
833
    if !m = dummy_label then None else Some !m
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853

  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)

854
(*
855
856
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
857
*)
858
859
860
861
862

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
863
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
	   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) -> 
881
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
882
883
884
885
886
887
888
889
890
			   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

891
  let rec dispatch_record disp : record option =
892
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
893
894
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
895
    let r = dispatch_record_opt disp t pl0 in
896
(*    memo_dispatch_record := []; *)
897
    r
898
899
900
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
901
902
903
904
905
906
907
908
909
910
911
(*  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 *)
912
913
914
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
915
916
917
918
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
919
      | Some l ->
920
921
922
923
924
	  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
925
926
927
928
929
930
931
932
933
	  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)
934
	      (dispatch_record_field l disp t plabs)
935
	      (fun x -> combine x)
936
	  in
937
	  combine_record l present absent
938
  and dispatch_record_field l disp t plabs tfield pl others =
939
    let t = Types.Record.restrict_field t l tfield in
940
941
942
    let aux (ret, (res, catch, rem)) = 
      let catch = if ret = [] then catch else (l,ret) :: catch in
      (res, catch, rem) in
943
944
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
945
(*    if pl = plabs then `Absent else  *)
946
      (* TODO: Check that this is the good condition ....
947
948
949
950
951
952
953
954
955
	 Need condition on t ?

	 No, it isn't a good condition:
	 match { x = "a" } : { x =? "a"|"b" } with
	 | { x = "b" } -> 1
	 | _  -> 0;;
	 Need to investigate ....
      *)
	 
956
957
    dispatch_record_label disp t pl
    
958
      
959
960
961
962
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
963
964
965
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
966
		    (dispatch_prod ~kind:`XML disp)
967
968
		    (dispatch_record disp)
	  in
969
970
971
972
973
974
975
976
977
978
979
980
	  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
    )

981
  let rec print_source ppf = function
982
983
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
984
985
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
986
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
987
988
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
989
990
991
992
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
993
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007

  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 =
1008
    let print_lhs ppf (code,prefix,d) =
1009
      let arity = match d.codes.(code) with (_,a,_) -> a in
1010
1011
1012
1013
1014
1015
1016
      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) =
1017
      Format.fprintf ppf " | %a -> %a@\n"
1018
1019
1020
	Types.Print.print_descr t
	print_ret ret
    in
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
    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
1039
    in
1040
    let print_prod prefix = function
1041
1042
      | `None -> ()
      | `Ignore d2 ->
1043
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1044
1045
1046
	  print_prod2 d2
      | `TailCall d ->
	  queue d;
1047
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1048
1049
1050
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
      | `Dispatch (d,branches) ->
	  queue d;
1051
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1052
1053
1054
1055
1056
1057
1058
1059
	  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
1060
1061
1062
1063
1064
1065
1066
1067
    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
1068
      | `Absent -> Format.fprintf ppf "Jump to Absent"
1069
      | `Label (l, present, absent) ->
1070
	  let l = Types.LabelPool.value l in
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
	  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 ->