1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2000 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16
17 type 'a shared = Shared of 'a | Single of 'a
18
19 type ('a, 'ctx) t_store =
20 {act_get : unit -> 'a array ;
21 act_get_shared : unit -> 'a shared array ;
22 act_store : 'ctx -> 'a -> int ;
23 act_store_shared : 'ctx -> 'a -> int ; }
24
25 exception Not_simple
26
27 module type Stored = sig
28 type t
29 type key
30 val compare_key : key -> key -> int
31 val make_key : t -> key option
32 end
33
34 module type CtxStored = sig
35 include Stored
36 type context
37 val make_key : context -> t -> key option
38 end
39
40 module CtxStore(A:CtxStored) = struct
41 module AMap =
42 Map.Make(struct type t = A.key let compare = A.compare_key end)
43
44 type intern =
45 { mutable map : (bool * int) AMap.t ;
46 mutable next : int ;
47 mutable acts : (bool * A.t) list; }
48
49 let mk_store () =
50 let st =
51 { map = AMap.empty ;
52 next = 0 ;
53 acts = [] ; } in
54
55 let add mustshare act =
56 let i = st.next in
57 st.acts <- (mustshare,act) :: st.acts ;
58 st.next <- i+1 ;
59 i in
60
61 let store mustshare ctx act = match A.make_key ctx act with
62 | Some key ->
63 begin try
64 let (shared,i) = AMap.find key st.map in
65 if not shared then st.map <- AMap.add key (true,i) st.map ;
66 i
67 with Not_found ->
68 let i = add mustshare act in
69 st.map <- AMap.add key (mustshare,i) st.map ;
70 i
71 end
72 | None ->
73 add mustshare act
74
75 and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts)
76
77 and get_shared () =
78 let acts =
79 Array.of_list
80 (List.rev_map
81 (fun (shared,act) ->
82 if shared then Shared act else Single act)
83 st.acts) in
84 AMap.iter
85 (fun _ (shared,i) ->
86 if shared then match acts.(i) with
87 | Single act -> acts.(i) <- Shared act
88 | Shared _ -> ())
89 st.map ;
90 acts in
91 {act_store = store false ; act_store_shared = store true ;
92 act_get = get; act_get_shared = get_shared; }
93 end
94
95 module Store(A:Stored) = struct
96 module Me =
97 CtxStore
98 (struct
99 include A
100 type context = unit
101 let make_key () = A.make_key
102 end)
103
104 let mk_store = Me.mk_store
105 end
106
107
108
109 module type S =
110 sig
111 type primitive
112 val eqint : primitive
113 val neint : primitive
114 val leint : primitive
115 val ltint : primitive
116 val geint : primitive
117 val gtint : primitive
118 type act
119
120 val bind : act -> (act -> act) -> act
121 val make_const : int -> act
122 val make_offset : act -> int -> act
123 val make_prim : primitive -> act list -> act
124 val make_isout : act -> act -> act
125 val make_isin : act -> act -> act
126 val make_if : act -> act -> act -> act
127 val make_switch : Location.t -> act -> int array -> act array -> act
128 val make_catch : act -> int * (act -> act)
129 val make_exit : int -> act
130 end
131
132 (* The module will ``produce good code for the case statement'' *)
133 (*
134 Adaptation of
135 R.L. Berstein
136 ``Producing good code for the case statement''
137 Software Practice and Experience, 15(10) (1985)
138 and
139 D.L. Spuler
140 ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
141 and Split Trees''
142 ``Compiler Code Generation for Multiway Branch Statement as
143 a Static Search Problem''
144 Technical Reports, James Cook University
145 *)
146 (*
147 Main adaptation is considering interval tests
148 (implemented as one addition + one unsigned test and branch)
149 which leads to exhaustive search for finding the optimal
150 test sequence in small cases and heuristics otherwise.
151 *)
152 module Make (Arg : S) =
153 struct
154
155 type 'a inter =
156 {cases : (int * int * int) array ;
157 actions : 'a array}
158
159 type 'a t_ctx = {off : int ; arg : 'a}
160
161 let cut = ref 8
162 and more_cut = ref 16
163
164 (*
165 let pint chan i =
166 if i = min_int then Printf.fprintf chan "-oo"
167 else if i=max_int then Printf.fprintf chan "oo"
168 else Printf.fprintf chan "%d" i
169
170 let pcases chan cases =
171 for i =0 to Array.length cases-1 do
172 let l,h,act = cases.(i) in
173 if l=h then
174 Printf.fprintf chan "%d:%d " l act
175 else
176 Printf.fprintf chan "%a..%a:%d " pint l pint h act
177 done
178
179 let prerr_inter i = Printf.fprintf stderr
180 "cases=%a" pcases i.cases
181 *)
182
183 let get_act cases i =
184 let _,_,r = cases.(i) in
185 r
186 and get_low cases i =
187 let r,_,_ = cases.(i) in
188 r
189
190 type ctests = {
191 mutable n : int ;
192 mutable ni : int ;
193 }
194
195 let too_much = {n=max_int ; ni=max_int}
196
197 (*
198 let ptests chan {n=n ; ni=ni} =
199 Printf.fprintf chan "{n=%d ; ni=%d}" n ni
200
201 let pta chan t =
202 for i =0 to Array.length t-1 do
203 Printf.fprintf chan "%d: %a\n" i ptests t.(i)
204 done
205 *)
206
207 let less_tests c1 c2 =
208 if c1.n < c2.n then
209 true
210 else if c1.n = c2.n then begin
211 if c1.ni < c2.ni then
212 true
213 else
214 false
215 end else
216 false
217
218 and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
219
220 let less2tests (c1,d1) (c2,d2) =
221 if eq_tests c1 c2 then
222 less_tests d1 d2
223 else
224 less_tests c1 c2
225
226 let add_test t1 t2 =
227 t1.n <- t1.n + t2.n ;
228 t1.ni <- t1.ni + t2.ni ;
229
230 type t_ret = Inter of int * int | Sep of int | No
231
232 (*
233 let pret chan = function
234 | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
235 | Sep i -> Printf.fprintf chan "Sep %d" i
236 | No -> Printf.fprintf chan "No"
237 *)
238
239 let coupe cases i =
240 let l,_,_ = cases.(i) in
241 l,
242 Array.sub cases 0 i,
243 Array.sub cases i (Array.length cases-i)
244
245
246 let case_append c1 c2 =
247 let len1 = Array.length c1
248 and len2 = Array.length c2 in
249 match len1,len2 with
250 | 0,_ -> c2
251 | _,0 -> c1
252 | _,_ ->
253 let l1,h1,act1 = c1.(Array.length c1-1)
254 and l2,h2,act2 = c2.(0) in
255 if act1 = act2 then
256 let r = Array.make (len1+len2-1) c1.(0) in
257 for i = 0 to len1-2 do
258 r.(i) <- c1.(i)
259 done ;
260
261 let l =
262 if len1-2 >= 0 then begin
263 let _,h,_ = r.(len1-2) in
264 if h+1 < l1 then
265 h+1
266 else
267 l1
268 end else
269 l1
270 and h =
271 if 1 < len2-1 then begin
272 let l,_,_ = c2.(1) in
273 if h2+1 < l then
274 l-1
275 else
276 h2
277 end else
278 h2 in
279 r.(len1-1) <- (l,h,act1) ;
280 for i=1 to len2-1 do
281 r.(len1-1+i) <- c2.(i)
282 done ;
283 r
284 else if h1 > l1 then
285 let r = Array.make (len1+len2) c1.(0) in
286 for i = 0 to len1-2 do
287 r.(i) <- c1.(i)
288 done ;
289 r.(len1-1) <- (l1,l2-1,act1) ;
290 for i=0 to len2-1 do
291 r.(len1+i) <- c2.(i)
292 done ;
293 r
294 else if h2 > l2 then
295 let r = Array.make (len1+len2) c1.(0) in
296 for i = 0 to len1-1 do
297 r.(i) <- c1.(i)
298 done ;
299 r.(len1) <- (h1+1,h2,act2) ;
300 for i=1 to len2-1 do
301 r.(len1+i) <- c2.(i)
302 done ;
303 r
304 else
305 Array.append c1 c2
306
307
308 let coupe_inter i j cases =
309 let lcases = Array.length cases in
310 let low,_,_ = cases.(i)
311 and _,high,_ = cases.(j) in
312 low,high,
313 Array.sub cases i (j-i+1),
314 case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
315
316 type kind = Kvalue of int | Kinter of int | Kempty
317
318 (*
319 let pkind chan = function
320 | Kvalue i ->Printf.fprintf chan "V%d" i
321 | Kinter i -> Printf.fprintf chan "I%d" i
322 | Kempty -> Printf.fprintf chan "E"
323
324 let rec pkey chan = function
325 | [] -> ()
326 | [k] -> pkind chan k
327 | k::rem ->
328 Printf.fprintf chan "%a %a" pkey rem pkind k
329 *)
330
331 let t = Hashtbl.create 17
332
333 let make_key cases =
334 let seen = ref []
335 and count = ref 0 in
336 let rec got_it act = function
337 | [] ->
338 seen := (act,!count):: !seen ;
339 let r = !count in
340 incr count ;
341 r
342 | (act0,index) :: rem ->
343 if act0 = act then
344 index
345 else
346 got_it act rem in
347
348 let make_one l h act =
349 if l=h then
350 Kvalue (got_it act !seen)
351 else
352 Kinter (got_it act !seen) in
353
354 let rec make_rec i pl =
355 if i < 0 then
356 []
357 else
358 let l,h,act = cases.(i) in
359 if pl = h+1 then
360 make_one l h act::make_rec (i-1) l
361 else
362 Kempty::make_one l h act::make_rec (i-1) l in
363
364 let l,h,act = cases.(Array.length cases-1) in
365 make_one l h act::make_rec (Array.length cases-2) l
366
367
368 let same_act t =
369 let len = Array.length t in
370 let a = get_act t (len-1) in
371 let rec do_rec i =
372 if i < 0 then true
373 else
374 let b = get_act t i in
375 b=a && do_rec (i-1) in
376 do_rec (len-2)
377
378
379 (*
380 Interval test x in [l,h] works by checking x-l in [0,h-l]
381 * This may be false for arithmetic modulo 2^31
382 * Subtracting l may change the relative ordering of values
383 and invalid the invariant that matched values are given in
384 increasing order
385
386 To avoid this, interval check is allowed only when the
387 integers indeed present in the whole case interval are
388 in [-2^16 ; 2^16]
389
390 This condition is checked by zyva
391 *)
392
393 let inter_limit = 1 lsl 16
394
395 let ok_inter = ref false
396
397 let rec opt_count top cases =
398 let key = make_key cases in
399 try
400 Hashtbl.find t key
401 with
402 | Not_found ->
403 let r =
404 let lcases = Array.length cases in
405 match lcases with
406 | 0 -> assert false
407 | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
408 | _ ->
409 if lcases < !cut then
410 enum top cases
411 else if lcases < !more_cut then
412 heuristic cases
413 else
414 divide cases in
415 Hashtbl.add t key r ;
416 r
417
418 and divide cases =
419 let lcases = Array.length cases in
420 let m = lcases/2 in
421 let _,left,right = coupe cases m in
422 let ci = {n=1 ; ni=0}
423 and cm = {n=1 ; ni=0}
424 and _,(cml,cleft) = opt_count false left
425 and _,(cmr,cright) = opt_count false right in
426 add_test ci cleft ;
427 add_test ci cright ;
428 if less_tests cml cmr then
429 add_test cm cmr
430 else
431 add_test cm cml ;
432 Sep m,(cm, ci)
433
434 and heuristic cases =
435 let lcases = Array.length cases in
436
437 let sep,csep = divide cases
438
439 and inter,cinter =
440 if !ok_inter then begin
441 let _,_,act0 = cases.(0)
442 and _,_,act1 = cases.(lcases-1) in
443 if act0 = act1 then begin
444 let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
445 let _,(cmi,cinside) = opt_count false inside
446 and _,(cmo,coutside) = opt_count false outside
447 and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
448 and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
449 add_test cij cinside ;
450 add_test cij coutside ;
451 if less_tests cmi cmo then
452 add_test cmij cmo
453 else
454 add_test cmij cmi ;
455 Inter (1,lcases-2),(cmij,cij)
456 end else
457 Inter (-1,-1),(too_much, too_much)
458 end else
459 Inter (-1,-1),(too_much, too_much) in
460 if less2tests csep cinter then
461 sep,csep
462 else
463 inter,cinter
464
465
466 and enum top cases =
467 let lcases = Array.length cases in
468 let lim, with_sep =
469 let best = ref (-1) and best_cost = ref (too_much,too_much) in
470
471 for i = 1 to lcases-(1) do
472 let _,left,right = coupe cases i in
473 let ci = {n=1 ; ni=0}
474 and cm = {n=1 ; ni=0}
475 and _,(cml,cleft) = opt_count false left
476 and _,(cmr,cright) = opt_count false right in
477 add_test ci cleft ;
478 add_test ci cright ;
479 if less_tests cml cmr then
480 add_test cm cmr
481 else
482 add_test cm cml ;
483
484 if
485 less2tests (cm,ci) !best_cost
486 then begin
487 if top then
488 Printf.fprintf stderr "Get it: %d\n" i ;
489 best := i ;
490 best_cost := (cm,ci)
491 end
492 done ;
493 !best, !best_cost in
494
495 let ilow, ihigh, with_inter =
496 if not !ok_inter then
497 let rlow = ref (-1) and rhigh = ref (-1)
498 and best_cost= ref (too_much,too_much) in
499 for i=1 to lcases-2 do
500 let low, high, inside, outside = coupe_inter i i cases in
501 if low=high then begin
502 let _,(cmi,cinside) = opt_count false inside
503 and _,(cmo,coutside) = opt_count false outside
504 and cmij = {n=1 ; ni=0}
505 and cij = {n=1 ; ni=0} in
506 add_test cij cinside ;
507 add_test cij coutside ;
508 if less_tests cmi cmo then
509 add_test cmij cmo
510 else
511 add_test cmij cmi ;
512 if less2tests (cmij,cij) !best_cost then begin
513 rlow := i ;
514 rhigh := i ;
515 best_cost := (cmij,cij)
516 end
517 end
518 done ;
519 !rlow, !rhigh, !best_cost
520 else
521 let rlow = ref (-1) and rhigh = ref (-1)
522 and best_cost= ref (too_much,too_much) in
523 for i=1 to lcases-2 do
524 for j=i to lcases-2 do
525 let low, high, inside, outside = coupe_inter i j cases in
526 let _,(cmi,cinside) = opt_count false inside
527 and _,(cmo,coutside) = opt_count false outside
528 and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
529 and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
530 add_test cij cinside ;
531 add_test cij coutside ;
532 if less_tests cmi cmo then
533 add_test cmij cmo
534 else
535 add_test cmij cmi ;
536 if less2tests (cmij,cij) !best_cost then begin
537 rlow := i ;
538 rhigh := j ;
539 best_cost := (cmij,cij)
540 end
541 done
542 done ;
543 !rlow, !rhigh, !best_cost in
544 let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
545 if less2tests with_sep !rc then begin
546 r := Sep lim ; rc := with_sep
547 end ;
548 !r, !rc
549
550 let make_if_test test arg i ifso ifnot =
551 Arg.make_if
552 (Arg.make_prim test [arg ; Arg.make_const i])
553 ifso ifnot
554
555 let make_if_lt arg i ifso ifnot = match i with
556 | 1 ->
557 make_if_test Arg.leint arg 0 ifso ifnot
558 | _ ->
559 make_if_test Arg.ltint arg i ifso ifnot
560
561 and make_if_ge arg i ifso ifnot = match i with
562 | 1 ->
563 make_if_test Arg.gtint arg 0 ifso ifnot
564 | _ ->
565 make_if_test Arg.geint arg i ifso ifnot
566
567 and make_if_eq arg i ifso ifnot =
568 make_if_test Arg.eqint arg i ifso ifnot
569
570 and make_if_ne arg i ifso ifnot =
571 make_if_test Arg.neint arg i ifso ifnot
572
573 let do_make_if_out h arg ifso ifno =
574 Arg.make_if (Arg.make_isout h arg) ifso ifno
575
576 let make_if_out ctx l d mk_ifso mk_ifno = match l with
577 | 0 ->
578 do_make_if_out
579 (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
580 | _ ->
581 Arg.bind
582 (Arg.make_offset ctx.arg (-l))
583 (fun arg ->
584 let ctx = {off= (-l+ctx.off) ; arg=arg} in
585 do_make_if_out
586 (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
587
588 let do_make_if_in h arg ifso ifno =
589 Arg.make_if (Arg.make_isin h arg) ifso ifno
590
591 let make_if_in ctx l d mk_ifso mk_ifno = match l with
592 | 0 ->
593 do_make_if_in
594 (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
595 | _ ->
596 Arg.bind
597 (Arg.make_offset ctx.arg (-l))
598 (fun arg ->
599 let ctx = {off= (-l+ctx.off) ; arg=arg} in
600 do_make_if_in
601 (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
602
603 let rec c_test ctx ({cases=cases ; actions=actions} as s) =
604 let lcases = Array.length cases in
605 assert(lcases > 0) ;
606 if lcases = 1 then
607 actions.(get_act cases 0) ctx
608
609 else begin
610
611 let w,_c = opt_count false cases in
612 (*
613 Printf.fprintf stderr
614 "off=%d tactic=%a for %a\n"
615 ctx.off pret w pcases cases ;
616 *)
617 match w with
618 | No -> actions.(get_act cases 0) ctx
619 | Inter (i,j) ->
620 let low,high,inside, outside = coupe_inter i j cases in
621 let _,(cinside,_) = opt_count false inside
622 and _,(coutside,_) = opt_count false outside in
623 (* Costs are retrieved to put the code with more remaining tests
624 in the privileged (positive) branch of ``if'' *)
625 if low=high then begin
626 if less_tests coutside cinside then
627 make_if_eq
628 ctx.arg
629 (low+ctx.off)
630 (c_test ctx {s with cases=inside})
631 (c_test ctx {s with cases=outside})
632 else
633 make_if_ne
634 ctx.arg
635 (low+ctx.off)
636 (c_test ctx {s with cases=outside})
637 (c_test ctx {s with cases=inside})
638 end else begin
639 if less_tests coutside cinside then
640 make_if_in
641 ctx
642 (low+ctx.off)
643 (high-low)
644 (fun ctx -> c_test ctx {s with cases=inside})
645 (fun ctx -> c_test ctx {s with cases=outside})
646 else
647 make_if_out
648 ctx
649 (low+ctx.off)
650 (high-low)
651 (fun ctx -> c_test ctx {s with cases=outside})
652 (fun ctx -> c_test ctx {s with cases=inside})
653 end
654 | Sep i ->
655 let lim,left,right = coupe cases i in
656 let _,(cleft,_) = opt_count false left
657 and _,(cright,_) = opt_count false right in
658 let left = {s with cases=left}
659 and right = {s with cases=right} in
660
661 if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
662 Arg.make_if
663 ctx.arg
664 (c_test ctx right) (c_test ctx left)
665 else if less_tests cright cleft then
666 make_if_lt
667 ctx.arg (lim+ctx.off)
668 (c_test ctx left) (c_test ctx right)
669 else
670 make_if_ge
671 ctx.arg (lim+ctx.off)
672 (c_test ctx right) (c_test ctx left)
673
674 end
675
676
677 (* Minimal density of switches *)
678 let theta = ref 0.33333
679
680 (* Minimal number of tests to make a switch *)
681 let switch_min = ref 3
682
683 (* Particular case 0, 1, 2 *)
684 let particular_case cases i j =
685 j-i = 2 &&
686 (let l1,_h1,act1 = cases.(i)
687 and l2,_h2,_act2 = cases.(i+1)
688 and l3,h3,act3 = cases.(i+2) in
689 l1+1=l2 && l2+1=l3 && l3=h3 &&
690 act1 <> act3)
691
692 let approx_count cases i j =
693 let l = j-i+1 in
694 if l < !cut then
695 let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
696 ntests
697 else
698 l-1
699
700 (* Sends back a boolean that says whether is switch is worth or not *)
701
702 let dense {cases} i j =
703 if i=j then true
704 else
705 let l,_,_ = cases.(i)
706 and _,h,_ = cases.(j) in
707 let ntests = approx_count cases i j in
708 (*
709 (ntests+1) >= theta * (h-l+1)
710 *)
711 particular_case cases i j ||
712 (ntests >= !switch_min &&
713 float_of_int ntests +. 1.0 >=
714 !theta *. (float_of_int h -. float_of_int l +. 1.0))
715
716 (* Compute clusters by dynamic programming
717 Adaptation of the correction to Bernstein
718 ``Correction to `Producing Good Code for the Case Statement' ''
719 S.K. Kannan and T.A. Proebsting
720 Software Practice and Experience Vol. 24(2) 233 (Feb 1994)
721 *)
722
723 let comp_clusters s =
724 let len = Array.length s.cases in
725 let min_clusters = Array.make len max_int
726 and k = Array.make len 0 in
727 let get_min i = if i < 0 then 0 else min_clusters.(i) in
728
729 for i = 0 to len-1 do
730 for j = 0 to i do
731 if
732 dense s j i &&
733 get_min (j-1) + 1 < min_clusters.(i)
734 then begin
735 k.(i) <- j ;
736 min_clusters.(i) <- get_min (j-1) + 1
737 end
738 done ;
739 done ;
740 min_clusters.(len-1),k
741
742 (* Assume j > i *)
743 let make_switch loc {cases=cases ; actions=actions} i j =
744 let ll,_,_ = cases.(i)
745 and _,hh,_ = cases.(j) in
746 let tbl = Array.make (hh-ll+1) 0
747 and t = Hashtbl.create 17
748 and index = ref 0 in
749 let get_index act =
750 try
751 Hashtbl.find t act
752 with
753 | Not_found ->
754 let i = !index in
755 incr index ;
756 Hashtbl.add t act i ;
757 i in
758
759 for k=i to j do
760 let l,h,act = cases.(k) in
761 let index = get_index act in
762 for kk=l-ll to h-ll do
763 tbl.(kk) <- index
764 done
765 done ;
766 let acts = Array.make !index actions.(0) in
767 Hashtbl.iter
768 (fun act i -> acts.(i) <- actions.(act))
769 t ;
770 (fun ctx ->
771 match -ll-ctx.off with
772 | 0 -> Arg.make_switch loc ctx.arg tbl acts
773 | _ ->
774 Arg.bind
775 (Arg.make_offset ctx.arg (-ll-ctx.off))
776 (fun arg -> Arg.make_switch loc arg tbl acts))
777
778
779 let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k =
780 let len = Array.length cases in
781 let r = Array.make n_clusters (0,0,0)
782 and t = Hashtbl.create 17
783 and index = ref 0
784 and bidon = ref (Array.length actions) in
785 let get_index act =
786 try
787 let i,_ = Hashtbl.find t act in
788 i
789 with
790 | Not_found ->
791 let i = !index in
792 incr index ;
793 Hashtbl.add
794 t act
795 (i,(fun _ -> actions.(act))) ;
796 i
797 and add_index act =
798 let i = !index in
799 incr index ;
800 incr bidon ;
801 Hashtbl.add t !bidon (i,act) ;
802 i in
803
804 let rec zyva j ir =
805 let i = k.(j) in
806 begin if i=j then
807 let l,h,act = cases.(i) in
808 r.(ir) <- (l,h,get_index act)
809 else (* assert i < j *)
810 let l,_,_ = cases.(i)
811 and _,h,_ = cases.(j) in
812 r.(ir) <- (l,h,add_index (make_switch loc s i j))
813 end ;
814 if i > 0 then zyva (i-1) (ir-1) in
815
816 zyva (len-1) (n_clusters-1) ;
817 let acts = Array.make !index (fun _ -> assert false) in
818 Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
819 {cases = r ; actions = acts}
820 ;;
821
822
823 let do_zyva loc (low,high) arg cases actions =
824 let old_ok = !ok_inter in
825 ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
826 if !ok_inter <> old_ok then Hashtbl.clear t ;
827
828 let s = {cases=cases ; actions=actions} in
829
830 (*
831 Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ;
832 pcases stderr cases ;
833 prerr_endline "" ;
834 *)
835 let n_clusters,k = comp_clusters s in
836 let clusters = make_clusters loc s n_clusters k in
837 c_test {arg=arg ; off=0} clusters
838
839 let abstract_shared actions =
840 let handlers = ref (fun x -> x) in
841 let actions =
842 Array.map
843 (fun act -> match act with
844 | Single act -> act
845 | Shared act ->
846 let i,h = Arg.make_catch act in
847 let oh = !handlers in
848 handlers := (fun act -> h (oh act)) ;
849 Arg.make_exit i)
850 actions in
851 !handlers,actions
852
853 let zyva loc lh arg cases actions =
854 assert (Array.length cases > 0) ;
855 let actions = actions.act_get_shared () in
856 let hs,actions = abstract_shared actions in
857 hs (do_zyva loc lh arg cases actions)
858
859 and test_sequence arg cases actions =
860 assert (Array.length cases > 0) ;
861 let actions = actions.act_get_shared () in
862 let hs,actions = abstract_shared actions in
863 let old_ok = !ok_inter in
864 ok_inter := false ;
865 if !ok_inter <> old_ok then Hashtbl.clear t ;
866 let s =
867 {cases=cases ;
868 actions=Array.map (fun act -> (fun _ -> act)) actions} in
869 (*
870 Printf.eprintf "SEQUENCE: %B\n" !ok_inter ;
871 pcases stderr cases ;
872 prerr_endline "" ;
873 *)
874 hs (c_test {arg=arg ; off=0} s)
875 ;;
876
877 end
878