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

4
5
6
(*
To be sure not to use generic comparison ...
*)
7
8
9
10
11
12
let (=) : int -> int -> bool = (==)
let (<) : int -> int -> bool = (<)
let (<=) : int -> int -> bool = (<=)
let (<>) : int -> int -> bool = (<>)
let compare = 1

13

14
(* Syntactic algebra *)
15
(* Constraint: any node except Constr has fv<>[] ... *)
16
type d =
17
  | Constr of Types.t
18
  | Cup of descr * descr
19
  | Cap of descr * descr
20
  | Times of node * node
21
  | Xml of node * node
22
  | Record of label * node
23
24
  | Capture of id
  | Constant of id * Types.const
25
  | Dummy
26
27
and node = {
  id : int;
28
  mutable descr : descr;
29
  accept : Types.Node.t;
30
31
  fv : fv;
  fv_list : id list;
32
33
34
} and descr = Types.t * fv * d


35

36
let id x = x.id
37
let descr x = x.descr
38
let fv x = x.fv
39
let fv_list x = x.fv_list
40
let accept x = Types.internalize x.accept
41
42
43

let printed = ref []
let to_print = ref []
44
let rec print ppf (a,_,d) = 
45
  match d with
46
    | Constr t -> Types.Print.print ppf t
47
48
49
50
51
52
53
54
55
    | 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) -> 
56
	Format.fprintf ppf "{ %a =  P%i }" Label.print (LabelPool.value l) n.id;
57
58
	to_print := n :: !to_print
    | Capture x ->
59
	Format.fprintf ppf "%a" U.print (Id.value x)
60
    | Constant (x,c) ->
61
	Format.fprintf ppf "(%a := %a)" U.print (Id.value x) 
62
	  Types.Print.print_const c
63
64
    | Dummy ->
	Format.fprintf ppf "*DUMMY*"
65

66
let dump_print ppf =
67
  while !to_print != [] do
68
69
70
71
72
73
74
75
76
77
78
    let p = List.hd !to_print in
    to_print := List.tl !to_print;
    if not (List.mem p.id !printed) then
      ( printed := p.id :: !printed;
	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
      )
  done

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


81
82
let counter = State.ref "Patterns.counter" 0

83
let dummy = (Types.empty,IdSet.empty,Dummy)
84
85
let make fv =
  incr counter;
86
87
88
  { id = !counter; descr = dummy; accept = Types.make (); fv = fv;
    fv_list = fv;
  }
89
90

let define x ((accept,fv,_) as d) =
91
  (* assert (x.fv = fv); *)
92
  Types.define x.accept accept;
93
  x.descr <- d
94

95
let constr x = (x,IdSet.empty,Constr x)
96
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
97
98
99
100
101
  if not (IdSet.equal fv1 fv2) then (
    let x = match IdSet.pick (IdSet.diff fv1 fv2) with
      | Some x -> x
      | None -> match IdSet.pick (IdSet.diff fv2 fv1) with Some x -> x 
	  | None -> assert false
102
103
104
    in
    raise 
      (Error 
105
	 ("The capture variable " ^ (U.to_string (Id.value x)) ^ 
106
107
	  " should appear on both side of this | pattern"))
  );
108
  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
109
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
110
111
112
  if not (IdSet.disjoint fv1 fv2) then (
    match IdSet.pick (IdSet.cap fv1 fv2) with
      | Some x -> 
113
114
	  raise 
	  (Error 
115
	     ("The capture variable " ^ (U.to_string (Id.value x)) ^ 
116
	      " cannot appear on both side of this & pattern"))
117
      | None -> assert false
118
  );
119
  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
120
let times x y =
121
  (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
122
let xml x y =
123
  (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
124
let record l x = 
125
  (Types.record l x.accept, x.fv, Record (l,x))
126
127
let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
128
129


130
131
132
133
134
135
module Node = struct
  type t = node
  let compare n1 n2 = n1.id - n2.id
  let equal n1 n2 = n1.id == n2.id
  let hash n = n.id

136
137
138
  let check n = ()
  let dump ppf _ = Format.fprintf ppf "<Patterns.Node>"

139
140
141
142
143
144
145
146
147
148

  module SMemo = Set.Make(Custom.Int)
  let memo = Serialize.Put.mk_property (fun t -> ref SMemo.empty)
  let rec serialize t n = 
    let l = Serialize.Put.get_property memo t in
    Serialize.Put.int t n.id;
    if not (SMemo.mem n.id !l) then (
      l := SMemo.add n.id !l;
      Types.Node.serialize t n.accept;
      IdSet.serialize t n.fv;
149
      Serialize.Put.list Id.serialize t n.fv_list;
150
151
152
153
154
155
156
157
158
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
      serialize_descr t n.descr
    )
  and serialize_descr s (_,_,d) =
    serialize_d s d
  and serialize_d s = function
    | Constr t ->
	Serialize.Put.bits 3 s 0;
	Types.serialize s t
    | Cup (p1,p2) ->
	Serialize.Put.bits 3 s 1;
	serialize_descr s p1; 
	serialize_descr s p2
    | Cap (p1,p2) ->
	Serialize.Put.bits 3 s 2;
	serialize_descr s p1; 
	serialize_descr s p2
    | Times (p1,p2) ->
	Serialize.Put.bits 3 s 3;
	serialize s p1;
	serialize s p2
    | Xml (p1,p2) ->
	Serialize.Put.bits 3 s 4;
	serialize s p1;
	serialize s p2
    | Record (l,p) ->
	Serialize.Put.bits 3 s 5;
	LabelPool.serialize s l;
	serialize s p
    | Capture x ->
	Serialize.Put.bits 3 s 6;
	Id.serialize s x
    | Constant (x,c) ->
	Serialize.Put.bits 3 s 7;
	Id.serialize s x;
	Types.Const.serialize s c
    | Dummy -> assert false

  module DMemo = Map.Make(Custom.Int)
  let memo = Serialize.Get.mk_property (fun t -> ref DMemo.empty)
  let rec deserialize t = 
    let l = Serialize.Get.get_property memo t in
    let id = Serialize.Get.int t in
    try DMemo.find id !l
    with Not_found ->
      let accept = Types.Node.deserialize t in
      let fv = IdSet.deserialize t in
196
      let fv_list = Serialize.Get.list Id.deserialize t in
197
      incr counter;
198
199
      let n = { id = !counter; descr = dummy; accept = accept; fv = fv; 
		fv_list = fv_list } in
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
      l := DMemo.add id n !l;
      n.descr <- deserialize_descr t;
      n
  and deserialize_descr s =
    match Serialize.Get.bits 3 s with
      | 0 -> constr (Types.deserialize s)
      | 1 ->
	  (* Avoid unnecessary tests *)
	  let (acc1,fv1,_) as x1 = deserialize_descr s in
	  let (acc2,fv2,_) as x2 = deserialize_descr s in
	  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
      | 2 ->
	  let (acc1,fv1,_) as x1 = deserialize_descr s in
	  let (acc2,fv2,_) as x2 = deserialize_descr s in
	  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
      | 3 ->
	  let x = deserialize s in
	  let y = deserialize s in
	  times x y
      | 4 ->
	  let x = deserialize s in
	  let y = deserialize s in
	  xml x y
      | 5 ->
	  let l = LabelPool.deserialize s in
	  let x = deserialize s in
	  record l x
      | 6 -> capture (Id.deserialize s)
      | 7 ->
	  let x = Id.deserialize s in
	  let c = Types.Const.deserialize s in
	  constant x c
      | _ -> assert false


end
236
237
238
239
240


(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
241
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
242
243
let times_res v1 v2 = Types.Positive.times v1 v2

244
(* Try with a hash-table *)
245
module MemoFilter = Map.Make 
246
  (struct 
247
     type t = Types.t * node 
248
249
     let compare (t1,n1) (t2,n2) = 
       if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
250
       Types.compare t1 t2
251
   end)
252
253
254

let memo_filter = ref MemoFilter.empty

255
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
256
(* TODO: avoid is_empty t when t is not changing (Cap) *)
257
258
259
260
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
261
      | Constr _ -> IdMap.empty
262
      | Cup ((a,_,_) as d1,d2) ->
263
	  IdMap.merge cup_res
264
265
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
266
      | Cap (d1,d2) ->
267
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
268
269
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
270
271
272
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
273
	  IdMap.singleton c (Types.Positive.ty t)
274
      | Constant (c, cst) ->
275
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
276
      | Dummy -> assert false
277

278
279
280
281
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
282
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
283
       in
284
       IdMap.merge cup_res accu term
285
286
287
288
289
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


290
and filter_node t p : Types.Positive.v id_map =
291
292
293
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    let (_,fv,_) as d = descr p in
294
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
295
296
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
297
    IdMap.collide Types.Positive.define res r;
298
299
300
301
302
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
303
  IdMap.get (IdMap.map Types.Positive.solve r)
304
305


306
307
(* Normal forms for patterns and compilation *)

308
309
let min (a:int) (b:int) = if a < b then a else b

310
311
312
let any_basic = Types.Record.or_absent Types.non_constructed


313
module Normal = struct
314

315
  type source = 
316
317
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
318
  type result = source id_map
319

320
321
322
323
324
325
326
  let compare_source s1 s2 =
    if s1 == s2 then 0 
    else match (s1,s2) with
      | SCatch, _ -> -1 | _, SCatch -> 1
      | SLeft, _ -> -1 | _, SLeft -> 1
      | SRight, _ -> -1 | _, SRight -> 1
      | SRecompose, _ -> -1 | _, SRecompose -> 1
327
      | SConst c1, SConst c2 -> Types.Const.compare c1 c2
328
329
330
331
332
333

  let hash_source = function
    | SCatch -> 1
    | SLeft -> 2
    | SRight -> 3
    | SRecompose -> 4
334
    | SConst c -> Types.Const.hash c
335
336
337
338
339
340
341
342
343
    
  let compare_result r1 r2 =
    IdMap.compare compare_source r1 r2

  let hash_result r =
    IdMap.hash hash_source r


  module NodeSet = 
344
345
    SortedList.Make(Node)

346

347
  type nnf = NodeSet.t * Types.t (* pl,t;   t <= \accept{pl} *)
348
349
350

  let compare_nnf (l1,t1) (l2,t2) =
    let c = NodeSet.compare l1 l2 in if c <> 0 then c
351
    else Types.compare t1 t2
352
353

  let hash_nnf (l,t) =
354
    (NodeSet.hash l) + 17 * (Types.hash t)
355
356
357
358

  module NLineBasic = 
    SortedList.Make(
      struct
359
	include Custom.Dummy
360
	let serialize s _ = failwith "Patterns.NLineBasic.serialize"
361
	type t = result * Types.t
362
363
	let compare (r1,t1) (r2,t2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
364
	  else Types.compare t1 t2
365
	let equal x y = compare x y == 0
366
	let hash (r,t) = hash_result r + 17 * Types.hash t
367
368
369
370
371
372
      end
    )

  module NLineProd = 
    SortedList.Make(
      struct
373
	include Custom.Dummy
374
	let serialize s _ = failwith "Patterns.NLineProd.serialize"
375
	type t = result * nnf * nnf
376
377
378
379
	let compare (r1,x1,y1) (r2,x2,y2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
	  else let c = compare_nnf x1 x2 in if c <> 0 then c
	  else compare_nnf y1 y2
380
	let equal x y = compare x y == 0
381
382
383
384
385
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

386
  type record =
387
    | RecNolabel of result option * result option
388
    | RecLabel of label * NLineProd.t
389
  type t = {
390
    nfv    : fv;
391
    ncatchv: fv;
392
393
394
395
    na     : Types.t;
    nbasic : NLineBasic.t;
    nprod  : NLineProd.t;
    nxml   : NLineProd.t;
396
    nrecord: record
397
398
  }

399
400
401
402
403
404
  let compare_nf t1 t2 =
    if t1 == t2 then 0
    else
      (* TODO: reorder; remove comparison of nfv ? *)
      let c = IdSet.compare t1.nfv t2.nfv in if c <> 0 then c 
      else let c = IdSet.compare t1.ncatchv t2.ncatchv in if c <> 0 then c
405
      else let c = Types.compare t1.na t2.na in if c <> 0 then c
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
      else let c = NLineBasic.compare t1.nbasic t2.nbasic in if c <> 0 then c
      else let c = NLineProd.compare t1.nprod t2.nprod in if c <> 0 then c
      else let c = NLineProd.compare t1.nxml t2.nxml in if c <> 0 then c
      else match t1.nrecord, t2.nrecord with
	| RecNolabel (s1,n1), RecNolabel (s2,n2) ->
	    let c = match (s1,s2) with
	      | None,None -> 0
	      | Some r1, Some r2 -> compare_result r1 r2
	      | None, _ -> -1
	      | _, None -> 1 in
	    if c <> 0 then c 
	    else (match (n1,n2) with
	      | None,None -> 0
	      | Some r1, Some r2 -> compare_result r1 r2
	      | None, _ -> -1
	      | _, None -> 1)
	| RecNolabel (_,_), _ -> -1
	| _, RecNolabel (_,_) -> 1
	| RecLabel (l1,p1), RecLabel (l2,p2) ->
	    let c = LabelPool.compare l1 l2 in if c <> 0 then c
	    else NLineProd.compare p1 p2
427

428
  let fus = IdMap.union_disj
429

430
431
432
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
433
434
435
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
436
      nrecord = (match lab with 
437
		   | Some l -> RecLabel (l,NLineProd.empty)
438
		   | None -> RecNolabel (None,None))
439
    }
440
  let dummy = nempty None
441
442
443
444
445
446


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
447
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
448
      na      = Types.cup nf1.na nf2.na;
449
450
451
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
452
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
453
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
454
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
455
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
456
457
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
458
		   | _ -> assert false)
459
460
461
    }

  let double_fold f l1 l2 =
462
463
464
465
466
467
    List.fold_left 
      (fun accu x1 -> List.fold_left (fun accu x2 -> f accu x1 x2) accu l2)
      [] l1

  let double_fold_prod f l1 l2 =
    double_fold f (NLineProd.get l1) (NLineProd.get l2)
468
469
	 
  let ncap nf1 nf2 =
470
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
471
472
473
474
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	let s = Types.cap s1 s2  in
	if Types.is_empty s then accu else
475
476
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
477
478
479
480
481
482
    in
    let basic accu (res1,t1) (res2,t2) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	(fus res1 res2, t) :: accu
    in
483
    let record r1 r2 = match r1,r2 with
484
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
485
	  (* assert (l1 = l2); *)
486
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
487
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
488
489
490
491
492
493
	  let x = match x1,x2 with 
	    | Some res1, Some res2 -> Some (fus res1 res2) 
	    | _ -> None
	  and y = match y1,y2 with
	    | Some res1, Some res2 -> Some (fus res1 res2)
	    | _ -> None in
494
	  RecNolabel (x,y)
495
      | _ -> assert false
496
    in
497
498
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
499
      na = Types.cap nf1.na nf2.na;
500
501
502
503
504
505
      nbasic = NLineBasic.from_list (double_fold basic 
				       (NLineBasic.get nf1.nbasic) 
				       (NLineBasic.get nf2.nbasic));
      nprod = NLineProd.from_list (double_fold_prod prod nf1.nprod nf2.nprod);
      nxml = NLineProd.from_list (double_fold_prod prod nf1.nxml nf2.nxml);
      nrecord = record nf1.nrecord nf2.nrecord;
506
507
    }

508
509
510
511
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

512
  let empty_res = IdMap.empty
513

514
  let ntimes lab acc p q = 
515
516
517
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
518
    { nempty lab with 
519
	nfv = IdSet.cup p.fv q.fv; 
520
	na = acc;
521
	nprod = NLineProd.singleton (src, nnode p, nnode q);
522
523
    }

524
  let nxml lab acc p q = 
525
526
527
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
528
    { nempty lab with 
529
	nfv = IdSet.cup p.fv q.fv; 
530
	na = acc;
531
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
532
533
    }
    
534
535
536
537
538
539
540
541
542
543
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
544
		nrecord = RecLabel(label, 
545
				 NLineProd.singleton (src,nnode p, ncany))}
546
547
548
549
550
551
552
553
	  else
	    let src = IdMap.constant SRight p.fv in
	    let p' = make p.fv in  (* optimize this ... *)
	      (* cache the results to avoid looping ... *)
	    define p' (record l p);
	    { nempty lab with
		nfv = p.fv;
		na = acc;
554
555
556
557
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
558
559
560
	  

  let nconstr lab t =
561
562
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
563
564
565
566
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
567
	    RecNolabel ((if x then Some empty_res else None), 
568
569
		      (if y then Some empty_res else None))
	| Some l ->
570
	    RecLabel (l,aux (Types.Record.split_normal t l))
571
572
    in	      
    { nempty lab with
573
	na = t;
574
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
575
576
577
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
578
579
    }

580
  let nconstant lab x c = 
581
582
583
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
584
      na = Types.any;
585
586
587
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
588
      nrecord = match lab with
589
	| None -> RecNolabel (Some l, Some l)
590
	| Some lab -> 
591
592
593
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
594
595
    }

596
  let ncapture lab x = 
597
598
599
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
600
      na = Types.any;
601
602
603
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
604
      nrecord = match lab with
605
	| None -> RecNolabel (Some l, Some l)
606
	| Some lab -> 
607
608
609
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
610
611
    }

612
  let rec nnormal lab (acc,fv,d) =
613
    if Types.is_empty acc 
614
    then nempty lab
615
    else match d with
616
617
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
618
      | Cup ((acc1,_,_) as p,q) -> 
619
620
621
622
623
624
625
	  ncup (nnormal lab p) (ncap (nnormal lab q) 
				  (nconstr lab (Types.neg acc1)))
      | Times (p,q) -> ntimes lab acc p q
      | Xml (p,q) -> nxml lab acc p q
      | Capture x -> ncapture lab x
      | Constant (x,c) -> nconstant lab x c
      | Record (l,p) -> nrecord lab acc l p
626
      | Dummy -> assert false
627
628
629
630
631
632

(*TODO: when an operand of Cap has its first_label > lab,
  directly shift it*)

  let rec first_label (acc,fv,d) =
    if Types.is_empty acc 
633
    then LabelPool.dummy_max
634
635
636
637
638
639
    else match d with
      | Constr t -> Types.Record.first_label t
      | Cap (p,q) -> min (first_label p) (first_label q)
      | Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
	    (* should "first_label_type acc1" ? *)
      | Record (l,p) -> l
640
      | _ -> LabelPool.dummy_max
641

642
643
644
   
  let remove_catchv n =
    let ncv = n.ncatchv in
645
646
647
648
    let nlinesbasic l = 
      NLineBasic.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
    let nlinesprod l  = 
      NLineProd.map (fun (res,x,y) -> (IdMap.diff res ncv,x,y)) l in
649
    { nfv     = IdSet.diff n.nfv ncv;
650
651
      ncatchv = n.ncatchv;
      na      = n.na;
652
653
654
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
655
      nrecord = (match n.nrecord with
656
		   | RecNolabel (x,y) ->
657
658
659
660
661
662
		       let x = match x with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
		       let y = match y with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
663
		       RecNolabel (x,y)
664
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
665
666
    }

667
  let normal l t pl =
668
    remove_catchv
669
670
671
672
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
673
end
674
675


676
677
module Compile = 
struct
678
  type actions =
679
680
    | AIgnore of result
    | AKind of actions_kind
681
  and actions_kind = {
682
    basic: (Types.t * result) list;
683
684
    atoms: result Atoms.map;
    chars: result Chars.map;
685
    prod: result dispatch dispatch;
686
    xml: result dispatch dispatch;
687
688
689
    record: record option;
  }
  and record = 
690
    | RecLabel of label * result dispatch dispatch
691
    | RecNolabel of result option * result option
692
      
693
  and 'a dispatch =
694
695
696
697
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
698
699

  and result = int * source array
700
  and source = 
701
702
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
703
704
      
  and return_code = 
705
      Types.t * int *   (* accepted type, arity *)
706
      (int * int id_map) list
707
708

  and interface =
709
710
    [ `Result of int
    | `Switch of interface * interface
711
712
713
714
    | `None ]

  and dispatcher = {
    id : int;
715
    t  : Types.t;
716
    pl : Normal.t array;
717
    label : label option;
718
719
    interface : interface;
    codes : return_code array;
720
721
    mutable actions : actions option;
    mutable printed : bool
722
  }
723

724
725
726
727
728
729
730
  let equal_array f a1 a2 =
    let rec aux i = (i < 0) || ((f a1.(i) a2.(i)) && (aux (i - 1))) in
    let l1 = Array.length a1 and l2 = Array.length a2 in
    (l1 == l2) && (aux (l1 - 1))

  let equal_source s1 s2 =
    (s1 == s2) || match (s1,s2) with
731
      | Const x, Const y -> Types.Const.equal x y 
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
      | Left x, Left y -> x == y
      | Right x, Right y -> x == y
      | Recompose (x1,x2), Recompose (y1,y2) -> (x1 == y1) && (x2 == y2)
      | _ -> false

  let equal_result (r1,s1) (r2,s2) =
    (r1 == r2) && (equal_array equal_source s1 s2)

  let equal_result_dispatch d1 d2 =
    (d1 == d2) || match (d1,d2) with
      | Dispatch (d1,a1), Dispatch (d2,a2) -> (d1 == d2) && (equal_array equal_result a1 a2)
      | TailCall d1, TailCall d2 -> d1 == d2
      | Ignore a1, Ignore a2 -> equal_result a1 a2
      | _ -> false


748
749
  let array_for_all f a =
    let rec aux f a i =
750
      if i == Array.length a then true
751
752
753
754
755
756
      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 =
757
      if i == Array.length a then true
758
759
760
761
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

762
  let combine_kind basic prod xml record =
763
764
765
766
767
768
769
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
770
771
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
772
	| _ -> raise Exit in
773
      let rs = match xml with
774
775
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
776
	| _ -> raise Exit in
777
778
      let rs = match record with
	| None -> rs
779
780
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
781
782
	| _ -> raise Exit in
      match rs with
783
	| ((_, ret) as r) :: rs when 
784
	    List.for_all ( equal_result r ) rs 
785
	    && array_for_all 
786
787
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
788
789
	| _ -> raise Exit
    )
790
791
792
793
794
795
796
797
798
799
800
    with Exit -> 
      AKind 
      { basic = basic;
	atoms = 
	   Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
	chars = 
	   Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
	prod = prod; 
	xml = xml; 
	record = record }
      
801
802
  let combine f (disp,act) =
    if Array.length act == 0 then Impossible
803
    else
804
805
      if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes) 
	 && (array_for_all ( f act.(0) ) act) then
806
	   Ignore act.(0)
807
      else
808
	Dispatch (disp, act)
809
810
811


  let detect_right_tail_call = function
812
    | Dispatch (disp,branches) 
813
814
815
	when
	  array_for_all_i
	    (fun i (code,ret) ->
816
	       (i == code) && 
817
818
	       (array_for_all_i 
		  (fun pos -> 
819
		     function Right j when pos == j -> true | _ -> false)
820
821
822
		  ret
	       )
	    ) branches
823
	  -> TailCall disp
824
825
826
    | x -> x

  let detect_left_tail_call = function
827
    | Dispatch (disp,branches)
828
829
830
831
	when
	  array_for_all_i
	    (fun i -> 
	       function 
832
		 | Ignore (code,ret) ->
833
		     (i == code) &&
834
835
		     (array_for_all_i 
			(fun pos -> 
836
			   function Left j when pos == j -> true | _ -> false)
837
838
839
840
841
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
842
	 TailCall disp
843
844
    | x -> x
   
845
846
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
847
		 
848
849
850
851
852
853
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

854
855
  module DispMap = Map.Make(
    struct
856
      type t = Types.t * Normal.t array
857
858
859
860
861
862
863
864

      let rec compare_rec a1 a2 i =
	if i < 0 then 0 
	else
	  let c = Normal.compare_nf a1.(i) a2.(i) in
	  if c <> 0 then c else compare_rec a1 a2 (i - 1)
	  
      let compare (t1,a1) (t2,a2) =
865
	let c = Types.compare t1 t2 in if c <> 0 then c 
866
867
868
	else let l1 = Array.length a1 and l2 = Array.length a2 in
	if l1 < l2 then -1 else if l1 > l2 then 1
	else compare_rec a1 a2 (l1 - 1)
869
870
    end
  )
871
872

    (* Try with a hash-table ! *)
873
    
874
  let dispatchers = ref DispMap.empty
875
876
877
		
  let timer_disp = Stats.Timer.create "Patterns.dispatcher loop"
      
878
  let dispatcher t pl lab : dispatcher =
879
880
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
881
      let nb = ref 0 in
882
883
      let codes = ref [] in
      let rec aux t arity i accu = 
884
885
	if i == Array.length pl 
	then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
886
	else
887
888
889
890
891
892
893
	  let p = pl.(i) in
	  let tp = p.Normal.na in
(*	  let tp = Types.normalize tp in *)

	  let a1 = Types.cap t tp in
	  if Types.is_empty a1 then
	    `Switch (`None,aux t arity (i+1) accu)
894
	  else
895
	    let v = p.Normal.nfv in
896
	    let a2 = Types.diff t tp in
897
	    let accu' = (i,IdMap.num arity v) :: accu in
898
899
900
901
902
903
904
	    if Types.is_empty a2 then
	      `Switch (aux t (arity + (IdSet.length v)) (i+1) accu',`None)
	    else
	      `Switch (aux a1 (arity + (IdSet.length v)) (i+1) accu',
		       aux a2 arity (i+1) accu)

(* Unopt version:
905
	    `Switch 
906
	      (
907
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
908
	       aux (Types.diff t tp) arity (i+1) accu
909
	      )
910
911
*)

912
      in