1 (***********************************************************************)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
7 (* Copyright 2000 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
13 (* Store for actions in object style *)
14 exception Found of int
17 {act_get : unit -> 'a array ; act_store : 'a -> int}
20 let r_acts = ref [] in
22 let rec store_rec i = function
25 if same act0 act then raise (Found i)
27 let i,rem = store_rec (i+1) rem in
30 let i,acts = store_rec 0 !r_acts in
36 and get () = Array.of_list !r_acts in
37 {act_store=store ; act_get=get}
52 val bind : act -> (act -> act) -> act
53 val make_offset : act -> int -> act
54 val make_prim : primitive -> act list -> act
55 val make_isout : act -> act -> act
56 val make_isin : act -> act -> act
57 val make_if : act -> act -> act -> act
59 act -> int array -> act array -> act
62 (* The module will ``produce good code for the case statement'' *)
66 ``Producing good code for the case statement''
67 Sofware Practice and Experience, 15(10) (1985)
70 ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
72 ``Compiler Code Generation for Multiway Branch Statement as
73 a Static Search Problem''
74 Technical Reports, James Cook University
77 Main adaptation is considering interval tests
78 (implemented as one addition + one unsigned test and branch)
79 which leads to exhaustive search for finding the optimal
80 test sequence in small cases and heuristics otherwise.
82 module Make (Arg : S) =
86 {cases : (int * int * int) array ;
89 type 'a t_ctx = {off : int ; arg : 'a}
95 if i = min_int then Printf.fprintf chan "-oo"
96 else if i=max_int then Printf.fprintf chan "oo"
97 else Printf.fprintf chan "%d" i
99 let pcases chan cases =
100 for i =0 to Array.length cases-1 do
101 let l,h,act = cases.(i) in
103 Printf.fprintf chan "%d:%d " l act
105 Printf.fprintf chan "%a..%a:%d " pint l pint h act
108 let prerr_inter i = Printf.fprintf stderr
109 "cases=%a" pcases i.cases
111 let get_act cases i =
112 let _,_,r = cases.(i) in
114 and get_low cases i =
115 let r,_,_ = cases.(i) in
123 let too_much = {n=max_int ; ni=max_int}
125 let ptests chan {n=n ; ni=ni} =
126 Printf.fprintf chan "{n=%d ; ni=%d}" n ni
129 for i =0 to Array.length t-1 do
130 Printf.fprintf chan "%d: %a\n" i ptests t.(i)
136 (Array.length s.actions)
137 (fun _ -> {n=0 ; ni=0 }) in
139 let imax = Array.length c-1 in
141 let l,h,act = c.(i) in
144 if l < h && i<> 0 && i<>imax then
150 let less_tests c1 c2 =
153 else if c1.n = c2.n then begin
154 if c1.ni < c2.ni then
161 and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
163 let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2
165 let less2tests (c1,d1) (c2,d2) =
166 if eq_tests c1 c2 then
172 t1.n <- t1.n + t2.n ;
173 t1.ni <- t1.ni + t2.ni ;
175 type t_ret = Inter of int * int | Sep of int | No
177 let pret chan = function
178 | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
179 | Sep i -> Printf.fprintf chan "Sep %d" i
180 | No -> Printf.fprintf chan "No"
183 let l,_,_ = cases.(i) in
186 Array.sub cases i (Array.length cases-i)
189 let case_append c1 c2 =
190 let len1 = Array.length c1
191 and len2 = Array.length c2 in
196 let l1,h1,act1 = c1.(Array.length c1-1)
197 and l2,h2,act2 = c2.(0) in
199 let r = Array.create (len1+len2-1) c1.(0) in
200 for i = 0 to len1-2 do
205 if len1-2 >= 0 then begin
206 let _,h,_ = r.(len1-2) in
214 if 1 < len2-1 then begin
215 let l,_,_ = c2.(1) in
222 r.(len1-1) <- (l,h,act1) ;
224 r.(len1-1+i) <- c2.(i)
228 let r = Array.create (len1+len2) c1.(0) in
229 for i = 0 to len1-2 do
232 r.(len1-1) <- (l1,l2-1,act1) ;
238 let r = Array.create (len1+len2) c1.(0) in
239 for i = 0 to len1-1 do
242 r.(len1) <- (h1+1,h2,act2) ;
251 let coupe_inter i j cases =
252 let lcases = Array.length cases in
253 let low,_,_ = cases.(i)
254 and _,high,_ = cases.(j) in
256 Array.sub cases i (j-i+1),
257 case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
259 type kind = Kvalue of int | Kinter of int | Kempty
261 let pkind chan = function
262 | Kvalue i ->Printf.fprintf chan "V%d" i
263 | Kinter i -> Printf.fprintf chan "I%d" i
264 | Kempty -> Printf.fprintf chan "E"
266 let rec pkey chan = function
268 | [k] -> pkind chan k
270 Printf.fprintf chan "%a %a" pkey rem pkind k
272 let t = Hashtbl.create 17
277 let rec got_it act = function
279 seen := (act,!count):: !seen ;
283 | (act0,index) :: rem ->
289 let make_one l h act =
291 Kvalue (got_it act !seen)
293 Kinter (got_it act !seen) in
295 let rec make_rec i pl =
299 let l,h,act = cases.(i) in
301 make_one l h act::make_rec (i-1) l
303 Kempty::make_one l h act::make_rec (i-1) l in
305 let l,h,act = cases.(Array.length cases-1) in
306 make_one l h act::make_rec (Array.length cases-2) l
310 let len = Array.length t in
311 let a = get_act t (len-1) in
315 let b = get_act t i in
316 b=a && do_rec (i-1) in
321 Intervall test x in [l,h] works by checking x-l in [0,h-l]
322 * This may be false for arithmetic modulo 2^31
323 * Subtracting l may change the relative ordering of values
324 and invalid the invariant that matched values are given in
327 To avoid this, interval check is allowed only when the
328 integers indeed present in the whole case interval are
331 This condition is checked by zyva
334 let inter_limit = 1 lsl 16
336 let ok_inter = ref false
338 let rec opt_count top cases =
339 let key = make_key cases in
341 let r = Hashtbl.find t key in
346 let lcases = Array.length cases in
349 | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
351 if lcases < !cut then
353 else if lcases < !more_cut then
357 Hashtbl.add t key r ;
360 and divide top cases =
361 let lcases = Array.length cases in
363 let _,left,right = coupe cases m in
364 let ci = {n=1 ; ni=0}
365 and cm = {n=1 ; ni=0}
366 and _,(cml,cleft) = opt_count false left
367 and _,(cmr,cright) = opt_count false right in
370 if less_tests cml cmr then
376 and heuristic top cases =
377 let lcases = Array.length cases in
379 let sep,csep = divide false cases
382 if !ok_inter then begin
383 let _,_,act0 = cases.(0)
384 and _,_,act1 = cases.(lcases-1) in
385 if act0 = act1 then begin
386 let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
387 let _,(cmi,cinside) = opt_count false inside
388 and _,(cmo,coutside) = opt_count false outside
389 and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
390 and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
391 add_test cij cinside ;
392 add_test cij coutside ;
393 if less_tests cmi cmo then
397 Inter (1,lcases-2),(cmij,cij)
399 Inter (-1,-1),(too_much, too_much)
401 Inter (-1,-1),(too_much, too_much) in
402 if less2tests csep cinter then
409 let lcases = Array.length cases in
411 let best = ref (-1) and best_cost = ref (too_much,too_much) in
413 for i = 1 to lcases-(1) do
414 let _,left,right = coupe cases i in
415 let ci = {n=1 ; ni=0}
416 and cm = {n=1 ; ni=0}
417 and _,(cml,cleft) = opt_count false left
418 and _,(cmr,cright) = opt_count false right in
421 if less_tests cml cmr then
427 less2tests (cm,ci) !best_cost
430 Printf.fprintf stderr "Get it: %d\n" i ;
437 let ilow, ihigh, with_inter =
438 if not !ok_inter then
439 let rlow = ref (-1) and rhigh = ref (-1)
440 and best_cost= ref (too_much,too_much) in
441 for i=1 to lcases-2 do
442 let low, high, inside, outside = coupe_inter i i cases in
443 if low=high then begin
444 let _,(cmi,cinside) = opt_count false inside
445 and _,(cmo,coutside) = opt_count false outside
446 and cmij = {n=1 ; ni=0}
447 and cij = {n=1 ; ni=0} in
448 add_test cij cinside ;
449 add_test cij coutside ;
450 if less_tests cmi cmo then
454 if less2tests (cmij,cij) !best_cost then begin
457 best_cost := (cmij,cij)
461 !rlow, !rhigh, !best_cost
463 let rlow = ref (-1) and rhigh = ref (-1)
464 and best_cost= ref (too_much,too_much) in
465 for i=1 to lcases-2 do
466 for j=i to lcases-2 do
467 let low, high, inside, outside = coupe_inter i j cases in
468 let _,(cmi,cinside) = opt_count false inside
469 and _,(cmo,coutside) = opt_count false outside
470 and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
471 and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
472 add_test cij cinside ;
473 add_test cij coutside ;
474 if less_tests cmi cmo then
478 if less2tests (cmij,cij) !best_cost then begin
481 best_cost := (cmij,cij)
485 !rlow, !rhigh, !best_cost in
486 let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
487 if less2tests with_sep !rc then begin
488 r := Sep lim ; rc := with_sep
492 let make_if_test konst test arg i ifso ifnot =
494 (Arg.make_prim test [arg ; konst i])
497 let make_if_lt konst arg i ifso ifnot = match i with
499 make_if_test konst Arg.leint arg 0 ifso ifnot
501 make_if_test konst Arg.ltint arg i ifso ifnot
503 and make_if_le konst arg i ifso ifnot = match i with
505 make_if_test konst Arg.ltint arg 0 ifso ifnot
507 make_if_test konst Arg.leint arg i ifso ifnot
509 and make_if_gt konst arg i ifso ifnot = match i with
511 make_if_test konst Arg.geint arg 0 ifso ifnot
513 make_if_test konst Arg.gtint arg i ifso ifnot
515 and make_if_ge konst arg i ifso ifnot = match i with
517 make_if_test konst Arg.gtint arg 0 ifso ifnot
519 make_if_test konst Arg.geint arg i ifso ifnot
521 and make_if_eq konst arg i ifso ifnot =
522 make_if_test konst Arg.eqint arg i ifso ifnot
524 and make_if_ne konst arg i ifso ifnot =
525 make_if_test konst Arg.neint arg i ifso ifnot
527 let do_make_if_out h arg ifso ifno =
528 Arg.make_if (Arg.make_isout h arg) ifso ifno
530 let make_if_out konst ctx l d mk_ifso mk_ifno = match l with
533 (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
536 (Arg.make_offset ctx.arg (-l))
538 let ctx = {off= (-l+ctx.off) ; arg=arg} in
540 (konst d) arg (mk_ifso ctx) (mk_ifno ctx))
542 let do_make_if_in h arg ifso ifno =
543 Arg.make_if (Arg.make_isin h arg) ifso ifno
545 let make_if_in konst ctx l d mk_ifso mk_ifno = match l with
548 (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
551 (Arg.make_offset ctx.arg (-l))
553 let ctx = {off= (-l+ctx.off) ; arg=arg} in
555 (konst d) arg (mk_ifso ctx) (mk_ifno ctx))
558 let rec c_test konst ctx ({cases=cases ; actions=actions} as s) =
559 let lcases = Array.length cases in
562 actions.(get_act cases 0) ctx
565 let w,c = opt_count false cases in
567 Printf.fprintf stderr
568 "off=%d tactic=%a for %a\n"
569 ctx.off pret w pcases cases ;
572 | No -> actions.(get_act cases 0) ctx
574 let low,high,inside, outside = coupe_inter i j cases in
575 let _,(cinside,_) = opt_count false inside
576 and _,(coutside,_) = opt_count false outside in
577 (* Costs are retrieved to put the code with more remaining tests
578 in the privileged (positive) branch of ``if'' *)
579 if low=high then begin
580 if less_tests coutside cinside then
584 (c_test konst ctx {s with cases=inside})
585 (c_test konst ctx {s with cases=outside})
590 (c_test konst ctx {s with cases=outside})
591 (c_test konst ctx {s with cases=inside})
593 if less_tests coutside cinside then
598 (fun ctx -> c_test konst ctx {s with cases=inside})
599 (fun ctx -> c_test konst ctx {s with cases=outside})
605 (fun ctx -> c_test konst ctx {s with cases=outside})
606 (fun ctx -> c_test konst ctx {s with cases=inside})
609 let lim,left,right = coupe cases i in
610 let _,(cleft,_) = opt_count false left
611 and _,(cright,_) = opt_count false right in
612 let left = {s with cases=left}
613 and right = {s with cases=right} in
615 if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
618 (c_test konst ctx right) (c_test konst ctx left)
619 else if less_tests cright cleft then
621 ctx.arg (lim+ctx.off)
622 (c_test konst ctx left) (c_test konst ctx right)
625 ctx.arg (lim+ctx.off)
626 (c_test konst ctx right) (c_test konst ctx left)
631 (* Minimal density of switches *)
632 let theta = ref 0.33333
634 (* Minmal number of tests to make a switch *)
635 let switch_min = ref 3
637 (* Particular case 0, 1, 2 *)
638 let particular_case cases i j =
640 (let l1,h1,act1 = cases.(i)
641 and l2,h2,act2 = cases.(i+1)
642 and l3,h3,act3 = cases.(i+2) in
643 l1+1=l2 && l2+1=l3 && l3=h3 &&
646 let approx_count cases i j n_actions =
649 let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
654 (* Sends back a boolean that says whether is switch is worth or not *)
656 let dense {cases=cases ; actions=actions} i j =
659 let l,_,_ = cases.(i)
660 and _,h,_ = cases.(j) in
661 let ntests = approx_count cases i j (Array.length actions) in
663 (ntests+1) >= theta * (h-l+1)
665 particular_case cases i j ||
666 (ntests >= !switch_min &&
667 float_of_int ntests +. 1.0 >=
668 !theta *. (float_of_int h -. float_of_int l +. 1.0))
670 (* Compute clusters by dynamic programming
671 Adaptation of the correction to Bernstein
672 ``Correction to `Producing Good Code for the Case Statement' ''
673 S.K. Kannan and T.A. Proebsting
674 Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
677 let comp_clusters ({cases=cases ; actions=actions} as s) =
678 let len = Array.length cases in
679 let min_clusters = Array.create len max_int
680 and k = Array.create len 0 in
681 let get_min i = if i < 0 then 0 else min_clusters.(i) in
683 for i = 0 to len-1 do
687 get_min (j-1) + 1 < min_clusters.(i)
690 min_clusters.(i) <- get_min (j-1) + 1
694 min_clusters.(len-1),k
697 let make_switch {cases=cases ; actions=actions} i j =
698 let ll,_,_ = cases.(i)
699 and _,hh,_ = cases.(j) in
700 let tbl = Array.create (hh-ll+1) 0
701 and t = Hashtbl.create 17
710 Hashtbl.add t act i ;
714 let l,h,act = cases.(k) in
715 let index = get_index act in
716 for kk=l-ll to h-ll do
720 let acts = Array.create !index actions.(0) in
722 (fun act i -> acts.(i) <- actions.(act))
725 match -ll-ctx.off with
726 | 0 -> Arg.make_switch ctx.arg tbl acts
729 (Arg.make_offset ctx.arg (-ll-ctx.off))
730 (fun arg -> Arg.make_switch arg tbl acts))
733 let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
734 let len = Array.length cases in
735 let r = Array.create n_clusters (0,0,0)
736 and t = Hashtbl.create 17
738 and bidon = ref (Array.length actions) in
741 let i,_ = Hashtbl.find t act in
749 (i,(fun _ -> actions.(act))) ;
755 Hashtbl.add t !bidon (i,act) ;
761 let l,h,act = cases.(i) in
762 r.(ir) <- (l,h,get_index act)
763 else (* assert i < j *)
764 let l,_,_ = cases.(i)
765 and _,h,_ = cases.(j) in
766 r.(ir) <- (l,h,add_index (make_switch s i j))
768 if i > 0 then zyva (i-1) (ir-1) in
770 zyva (len-1) (n_clusters-1) ;
771 let acts = Array.create !index (fun _ -> assert false) in
772 Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
773 {cases = r ; actions = acts}
777 let zyva (low,high) konst arg cases actions =
778 let old_ok = !ok_inter in
779 ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
780 if !ok_inter <> old_ok then Hashtbl.clear t ;
782 let s = {cases=cases ; actions=actions} in
784 Printf.eprintf "ZYVA: %b\n" !ok_inter ;
785 pcases stderr cases ;
788 let n_clusters,k = comp_clusters s in
789 let clusters = make_clusters s n_clusters k in
790 let r = c_test konst {arg=arg ; off=0} clusters in
795 and test_sequence konst arg cases actions =
796 let old_ok = !ok_inter in
798 if !ok_inter <> old_ok then Hashtbl.clear t ;
801 actions=Array.map (fun act -> (fun _ -> act)) actions} in
803 Printf.eprintf "SEQUENCE: %b\n" !ok_inter ;
804 pcases stderr cases ;
807 let r = c_test konst {arg=arg ; off=0} s in