ocaml/bytecomp/switch.ml

856 lines
23 KiB
OCaml

(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2000 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
type 'a shared = Shared of 'a | Single of 'a
type 'a t_store =
{act_get : unit -> 'a array ;
act_get_shared : unit -> 'a shared array ;
act_store : 'a -> int ;
act_store_shared : 'a -> int ; }
exception Not_simple
module type Stored = sig
type t
type key
val make_key : t -> key option
end
module Store(A:Stored) = struct
module AMap =
Map.Make(struct type t = A.key let compare = Pervasives.compare end)
type intern =
{ mutable map : (bool * int) AMap.t ;
mutable next : int ;
mutable acts : (bool * A.t) list; }
let mk_store () =
let st =
{ map = AMap.empty ;
next = 0 ;
acts = [] ; } in
let add mustshare act =
let i = st.next in
st.acts <- (mustshare,act) :: st.acts ;
st.next <- i+1 ;
i in
let store mustshare act = match A.make_key act with
| Some key ->
begin try
let (shared,i) = AMap.find key st.map in
if not shared then st.map <- AMap.add key (true,i) st.map ;
i
with Not_found ->
let i = add mustshare act in
st.map <- AMap.add key (mustshare,i) st.map ;
i
end
| None ->
add mustshare act
and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts)
and get_shared () =
let acts =
Array.of_list
(List.rev_map
(fun (shared,act) ->
if shared then Shared act else Single act)
st.acts) in
AMap.iter
(fun _ (shared,i) ->
if shared then match acts.(i) with
| Single act -> acts.(i) <- Shared act
| Shared _ -> ())
st.map ;
acts in
{act_store = store false ; act_store_shared = store true ;
act_get = get; act_get_shared = get_shared; }
end
module type S =
sig
type primitive
val eqint : primitive
val neint : primitive
val leint : primitive
val ltint : primitive
val geint : primitive
val gtint : primitive
type act
val bind : act -> (act -> act) -> act
val make_const : int -> act
val make_offset : act -> int -> act
val make_prim : primitive -> act list -> act
val make_isout : act -> act -> act
val make_isin : act -> act -> act
val make_if : act -> act -> act -> act
val make_switch : act -> int array -> act array -> act
val make_catch : act -> int * (act -> act)
val make_exit : int -> act
end
(* The module will ``produce good code for the case statement'' *)
(*
Adaptation of
R.L. Berstein
``Producing good code for the case statement''
Sofware Practice and Experience, 15(10) (1985)
and
D.L. Spuler
``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
and Split Trees''
``Compiler Code Generation for Multiway Branch Statement as
a Static Search Problem''
Technical Reports, James Cook University
*)
(*
Main adaptation is considering interval tests
(implemented as one addition + one unsigned test and branch)
which leads to exhaustive search for finding the optimal
test sequence in small cases and heuristics otherwise.
*)
module Make (Arg : S) =
struct
type 'a inter =
{cases : (int * int * int) array ;
actions : 'a array}
type 'a t_ctx = {off : int ; arg : 'a}
let cut = ref 8
and more_cut = ref 16
(*
let pint chan i =
if i = min_int then Printf.fprintf chan "-oo"
else if i=max_int then Printf.fprintf chan "oo"
else Printf.fprintf chan "%d" i
let pcases chan cases =
for i =0 to Array.length cases-1 do
let l,h,act = cases.(i) in
if l=h then
Printf.fprintf chan "%d:%d " l act
else
Printf.fprintf chan "%a..%a:%d " pint l pint h act
done
let prerr_inter i = Printf.fprintf stderr
"cases=%a" pcases i.cases
*)
let get_act cases i =
let _,_,r = cases.(i) in
r
and get_low cases i =
let r,_,_ = cases.(i) in
r
type ctests = {
mutable n : int ;
mutable ni : int ;
}
let too_much = {n=max_int ; ni=max_int}
(*
let ptests chan {n=n ; ni=ni} =
Printf.fprintf chan "{n=%d ; ni=%d}" n ni
let pta chan t =
for i =0 to Array.length t-1 do
Printf.fprintf chan "%d: %a\n" i ptests t.(i)
done
*)
let less_tests c1 c2 =
if c1.n < c2.n then
true
else if c1.n = c2.n then begin
if c1.ni < c2.ni then
true
else
false
end else
false
and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
let less2tests (c1,d1) (c2,d2) =
if eq_tests c1 c2 then
less_tests d1 d2
else
less_tests c1 c2
let add_test t1 t2 =
t1.n <- t1.n + t2.n ;
t1.ni <- t1.ni + t2.ni ;
type t_ret = Inter of int * int | Sep of int | No
(*
let pret chan = function
| Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
| Sep i -> Printf.fprintf chan "Sep %d" i
| No -> Printf.fprintf chan "No"
*)
let coupe cases i =
let l,_,_ = cases.(i) in
l,
Array.sub cases 0 i,
Array.sub cases i (Array.length cases-i)
let case_append c1 c2 =
let len1 = Array.length c1
and len2 = Array.length c2 in
match len1,len2 with
| 0,_ -> c2
| _,0 -> c1
| _,_ ->
let l1,h1,act1 = c1.(Array.length c1-1)
and l2,h2,act2 = c2.(0) in
if act1 = act2 then
let r = Array.make (len1+len2-1) c1.(0) in
for i = 0 to len1-2 do
r.(i) <- c1.(i)
done ;
let l =
if len1-2 >= 0 then begin
let _,h,_ = r.(len1-2) in
if h+1 < l1 then
h+1
else
l1
end else
l1
and h =
if 1 < len2-1 then begin
let l,_,_ = c2.(1) in
if h2+1 < l then
l-1
else
h2
end else
h2 in
r.(len1-1) <- (l,h,act1) ;
for i=1 to len2-1 do
r.(len1-1+i) <- c2.(i)
done ;
r
else if h1 > l1 then
let r = Array.make (len1+len2) c1.(0) in
for i = 0 to len1-2 do
r.(i) <- c1.(i)
done ;
r.(len1-1) <- (l1,l2-1,act1) ;
for i=0 to len2-1 do
r.(len1+i) <- c2.(i)
done ;
r
else if h2 > l2 then
let r = Array.make (len1+len2) c1.(0) in
for i = 0 to len1-1 do
r.(i) <- c1.(i)
done ;
r.(len1) <- (h1+1,h2,act2) ;
for i=1 to len2-1 do
r.(len1+i) <- c2.(i)
done ;
r
else
Array.append c1 c2
let coupe_inter i j cases =
let lcases = Array.length cases in
let low,_,_ = cases.(i)
and _,high,_ = cases.(j) in
low,high,
Array.sub cases i (j-i+1),
case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
type kind = Kvalue of int | Kinter of int | Kempty
(*
let pkind chan = function
| Kvalue i ->Printf.fprintf chan "V%d" i
| Kinter i -> Printf.fprintf chan "I%d" i
| Kempty -> Printf.fprintf chan "E"
let rec pkey chan = function
| [] -> ()
| [k] -> pkind chan k
| k::rem ->
Printf.fprintf chan "%a %a" pkey rem pkind k
*)
let t = Hashtbl.create 17
let make_key cases =
let seen = ref []
and count = ref 0 in
let rec got_it act = function
| [] ->
seen := (act,!count):: !seen ;
let r = !count in
incr count ;
r
| (act0,index) :: rem ->
if act0 = act then
index
else
got_it act rem in
let make_one l h act =
if l=h then
Kvalue (got_it act !seen)
else
Kinter (got_it act !seen) in
let rec make_rec i pl =
if i < 0 then
[]
else
let l,h,act = cases.(i) in
if pl = h+1 then
make_one l h act::make_rec (i-1) l
else
Kempty::make_one l h act::make_rec (i-1) l in
let l,h,act = cases.(Array.length cases-1) in
make_one l h act::make_rec (Array.length cases-2) l
let same_act t =
let len = Array.length t in
let a = get_act t (len-1) in
let rec do_rec i =
if i < 0 then true
else
let b = get_act t i in
b=a && do_rec (i-1) in
do_rec (len-2)
(*
Intervall test x in [l,h] works by checking x-l in [0,h-l]
* This may be false for arithmetic modulo 2^31
* Subtracting l may change the relative ordering of values
and invalid the invariant that matched values are given in
increasing order
To avoid this, interval check is allowed only when the
integers indeed present in the whole case interval are
in [-2^16 ; 2^16]
This condition is checked by zyva
*)
let inter_limit = 1 lsl 16
let ok_inter = ref false
let rec opt_count top cases =
let key = make_key cases in
try
Hashtbl.find t key
with
| Not_found ->
let r =
let lcases = Array.length cases in
match lcases with
| 0 -> assert false
| _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
| _ ->
if lcases < !cut then
enum top cases
else if lcases < !more_cut then
heuristic top cases
else
divide top cases in
Hashtbl.add t key r ;
r
and divide top cases =
let lcases = Array.length cases in
let m = lcases/2 in
let _,left,right = coupe cases m in
let ci = {n=1 ; ni=0}
and cm = {n=1 ; ni=0}
and _,(cml,cleft) = opt_count false left
and _,(cmr,cright) = opt_count false right in
add_test ci cleft ;
add_test ci cright ;
if less_tests cml cmr then
add_test cm cmr
else
add_test cm cml ;
Sep m,(cm, ci)
and heuristic top cases =
let lcases = Array.length cases in
let sep,csep = divide false cases
and inter,cinter =
if !ok_inter then begin
let _,_,act0 = cases.(0)
and _,_,act1 = cases.(lcases-1) in
if act0 = act1 then begin
let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
let _,(cmi,cinside) = opt_count false inside
and _,(cmo,coutside) = opt_count false outside
and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
add_test cij cinside ;
add_test cij coutside ;
if less_tests cmi cmo then
add_test cmij cmo
else
add_test cmij cmi ;
Inter (1,lcases-2),(cmij,cij)
end else
Inter (-1,-1),(too_much, too_much)
end else
Inter (-1,-1),(too_much, too_much) in
if less2tests csep cinter then
sep,csep
else
inter,cinter
and enum top cases =
let lcases = Array.length cases in
let lim, with_sep =
let best = ref (-1) and best_cost = ref (too_much,too_much) in
for i = 1 to lcases-(1) do
let _,left,right = coupe cases i in
let ci = {n=1 ; ni=0}
and cm = {n=1 ; ni=0}
and _,(cml,cleft) = opt_count false left
and _,(cmr,cright) = opt_count false right in
add_test ci cleft ;
add_test ci cright ;
if less_tests cml cmr then
add_test cm cmr
else
add_test cm cml ;
if
less2tests (cm,ci) !best_cost
then begin
if top then
Printf.fprintf stderr "Get it: %d\n" i ;
best := i ;
best_cost := (cm,ci)
end
done ;
!best, !best_cost in
let ilow, ihigh, with_inter =
if not !ok_inter then
let rlow = ref (-1) and rhigh = ref (-1)
and best_cost= ref (too_much,too_much) in
for i=1 to lcases-2 do
let low, high, inside, outside = coupe_inter i i cases in
if low=high then begin
let _,(cmi,cinside) = opt_count false inside
and _,(cmo,coutside) = opt_count false outside
and cmij = {n=1 ; ni=0}
and cij = {n=1 ; ni=0} in
add_test cij cinside ;
add_test cij coutside ;
if less_tests cmi cmo then
add_test cmij cmo
else
add_test cmij cmi ;
if less2tests (cmij,cij) !best_cost then begin
rlow := i ;
rhigh := i ;
best_cost := (cmij,cij)
end
end
done ;
!rlow, !rhigh, !best_cost
else
let rlow = ref (-1) and rhigh = ref (-1)
and best_cost= ref (too_much,too_much) in
for i=1 to lcases-2 do
for j=i to lcases-2 do
let low, high, inside, outside = coupe_inter i j cases in
let _,(cmi,cinside) = opt_count false inside
and _,(cmo,coutside) = opt_count false outside
and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
add_test cij cinside ;
add_test cij coutside ;
if less_tests cmi cmo then
add_test cmij cmo
else
add_test cmij cmi ;
if less2tests (cmij,cij) !best_cost then begin
rlow := i ;
rhigh := j ;
best_cost := (cmij,cij)
end
done
done ;
!rlow, !rhigh, !best_cost in
let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
if less2tests with_sep !rc then begin
r := Sep lim ; rc := with_sep
end ;
!r, !rc
let make_if_test test arg i ifso ifnot =
Arg.make_if
(Arg.make_prim test [arg ; Arg.make_const i])
ifso ifnot
let make_if_lt arg i ifso ifnot = match i with
| 1 ->
make_if_test Arg.leint arg 0 ifso ifnot
| _ ->
make_if_test Arg.ltint arg i ifso ifnot
and make_if_ge arg i ifso ifnot = match i with
| 1 ->
make_if_test Arg.gtint arg 0 ifso ifnot
| _ ->
make_if_test Arg.geint arg i ifso ifnot
and make_if_eq arg i ifso ifnot =
make_if_test Arg.eqint arg i ifso ifnot
and make_if_ne arg i ifso ifnot =
make_if_test Arg.neint arg i ifso ifnot
let do_make_if_out h arg ifso ifno =
Arg.make_if (Arg.make_isout h arg) ifso ifno
let make_if_out ctx l d mk_ifso mk_ifno = match l with
| 0 ->
do_make_if_out
(Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
| _ ->
Arg.bind
(Arg.make_offset ctx.arg (-l))
(fun arg ->
let ctx = {off= (-l+ctx.off) ; arg=arg} in
do_make_if_out
(Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
let do_make_if_in h arg ifso ifno =
Arg.make_if (Arg.make_isin h arg) ifso ifno
let make_if_in ctx l d mk_ifso mk_ifno = match l with
| 0 ->
do_make_if_in
(Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
| _ ->
Arg.bind
(Arg.make_offset ctx.arg (-l))
(fun arg ->
let ctx = {off= (-l+ctx.off) ; arg=arg} in
do_make_if_in
(Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
let rec c_test ctx ({cases=cases ; actions=actions} as s) =
let lcases = Array.length cases in
assert(lcases > 0) ;
if lcases = 1 then
actions.(get_act cases 0) ctx
else begin
let w,c = opt_count false cases in
(*
Printf.fprintf stderr
"off=%d tactic=%a for %a\n"
ctx.off pret w pcases cases ;
*)
match w with
| No -> actions.(get_act cases 0) ctx
| Inter (i,j) ->
let low,high,inside, outside = coupe_inter i j cases in
let _,(cinside,_) = opt_count false inside
and _,(coutside,_) = opt_count false outside in
(* Costs are retrieved to put the code with more remaining tests
in the privileged (positive) branch of ``if'' *)
if low=high then begin
if less_tests coutside cinside then
make_if_eq
ctx.arg
(low+ctx.off)
(c_test ctx {s with cases=inside})
(c_test ctx {s with cases=outside})
else
make_if_ne
ctx.arg
(low+ctx.off)
(c_test ctx {s with cases=outside})
(c_test ctx {s with cases=inside})
end else begin
if less_tests coutside cinside then
make_if_in
ctx
(low+ctx.off)
(high-low)
(fun ctx -> c_test ctx {s with cases=inside})
(fun ctx -> c_test ctx {s with cases=outside})
else
make_if_out
ctx
(low+ctx.off)
(high-low)
(fun ctx -> c_test ctx {s with cases=outside})
(fun ctx -> c_test ctx {s with cases=inside})
end
| Sep i ->
let lim,left,right = coupe cases i in
let _,(cleft,_) = opt_count false left
and _,(cright,_) = opt_count false right in
let left = {s with cases=left}
and right = {s with cases=right} in
if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
make_if_ne
ctx.arg 0
(c_test ctx right) (c_test ctx left)
else if less_tests cright cleft then
make_if_lt
ctx.arg (lim+ctx.off)
(c_test ctx left) (c_test ctx right)
else
make_if_ge
ctx.arg (lim+ctx.off)
(c_test ctx right) (c_test ctx left)
end
(* Minimal density of switches *)
let theta = ref 0.33333
(* Minmal number of tests to make a switch *)
let switch_min = ref 3
(* Particular case 0, 1, 2 *)
let particular_case cases i j =
j-i = 2 &&
(let l1,h1,act1 = cases.(i)
and l2,h2,act2 = cases.(i+1)
and l3,h3,act3 = cases.(i+2) in
l1+1=l2 && l2+1=l3 && l3=h3 &&
act1 <> act3)
let approx_count cases i j n_actions =
let l = j-i+1 in
if l < !cut then
let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
ntests
else
l-1
(* Sends back a boolean that says whether is switch is worth or not *)
let dense {cases=cases ; actions=actions} i j =
if i=j then true
else
let l,_,_ = cases.(i)
and _,h,_ = cases.(j) in
let ntests = approx_count cases i j (Array.length actions) in
(*
(ntests+1) >= theta * (h-l+1)
*)
particular_case cases i j ||
(ntests >= !switch_min &&
float_of_int ntests +. 1.0 >=
!theta *. (float_of_int h -. float_of_int l +. 1.0))
(* Compute clusters by dynamic programming
Adaptation of the correction to Bernstein
``Correction to `Producing Good Code for the Case Statement' ''
S.K. Kannan and T.A. Proebsting
Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
*)
let comp_clusters ({cases=cases ; actions=actions} as s) =
let len = Array.length cases in
let min_clusters = Array.make len max_int
and k = Array.make len 0 in
let get_min i = if i < 0 then 0 else min_clusters.(i) in
for i = 0 to len-1 do
for j = 0 to i do
if
dense s j i &&
get_min (j-1) + 1 < min_clusters.(i)
then begin
k.(i) <- j ;
min_clusters.(i) <- get_min (j-1) + 1
end
done ;
done ;
min_clusters.(len-1),k
(* Assume j > i *)
let make_switch {cases=cases ; actions=actions} i j =
let ll,_,_ = cases.(i)
and _,hh,_ = cases.(j) in
let tbl = Array.make (hh-ll+1) 0
and t = Hashtbl.create 17
and index = ref 0 in
let get_index act =
try
Hashtbl.find t act
with
| Not_found ->
let i = !index in
incr index ;
Hashtbl.add t act i ;
i in
for k=i to j do
let l,h,act = cases.(k) in
let index = get_index act in
for kk=l-ll to h-ll do
tbl.(kk) <- index
done
done ;
let acts = Array.make !index actions.(0) in
Hashtbl.iter
(fun act i -> acts.(i) <- actions.(act))
t ;
(fun ctx ->
match -ll-ctx.off with
| 0 -> Arg.make_switch ctx.arg tbl acts
| _ ->
Arg.bind
(Arg.make_offset ctx.arg (-ll-ctx.off))
(fun arg -> Arg.make_switch arg tbl acts))
let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
let len = Array.length cases in
let r = Array.make n_clusters (0,0,0)
and t = Hashtbl.create 17
and index = ref 0
and bidon = ref (Array.length actions) in
let get_index act =
try
let i,_ = Hashtbl.find t act in
i
with
| Not_found ->
let i = !index in
incr index ;
Hashtbl.add
t act
(i,(fun _ -> actions.(act))) ;
i
and add_index act =
let i = !index in
incr index ;
incr bidon ;
Hashtbl.add t !bidon (i,act) ;
i in
let rec zyva j ir =
let i = k.(j) in
begin if i=j then
let l,h,act = cases.(i) in
r.(ir) <- (l,h,get_index act)
else (* assert i < j *)
let l,_,_ = cases.(i)
and _,h,_ = cases.(j) in
r.(ir) <- (l,h,add_index (make_switch s i j))
end ;
if i > 0 then zyva (i-1) (ir-1) in
zyva (len-1) (n_clusters-1) ;
let acts = Array.make !index (fun _ -> assert false) in
Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
{cases = r ; actions = acts}
;;
let do_zyva (low,high) arg cases actions =
let old_ok = !ok_inter in
ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
if !ok_inter <> old_ok then Hashtbl.clear t ;
let s = {cases=cases ; actions=actions} in
(*
Printf.eprintf "ZYVA: %b [low=%i,high=%i]\n" !ok_inter low high ;
pcases stderr cases ;
prerr_endline "" ;
*)
let n_clusters,k = comp_clusters s in
let clusters = make_clusters s n_clusters k in
c_test {arg=arg ; off=0} clusters
let abstract_shared actions =
let handlers = ref (fun x -> x) in
let actions =
Array.map
(fun act -> match act with
| Single act -> act
| Shared act ->
let i,h = Arg.make_catch act in
let oh = !handlers in
handlers := (fun act -> h (oh act)) ;
Arg.make_exit i)
actions in
!handlers,actions
let zyva lh arg cases actions =
assert (Array.length cases > 0) ;
let actions = actions.act_get_shared () in
let hs,actions = abstract_shared actions in
hs (do_zyva lh arg cases actions)
and test_sequence arg cases actions =
assert (Array.length cases > 0) ;
let actions = actions.act_get_shared () in
let hs,actions = abstract_shared actions in
let old_ok = !ok_inter in
ok_inter := false ;
if !ok_inter <> old_ok then Hashtbl.clear t ;
let s =
{cases=cases ;
actions=Array.map (fun act -> (fun _ -> act)) actions} in
(*
Printf.eprintf "SEQUENCE: %b\n" !ok_inter ;
pcases stderr cases ;
prerr_endline "" ;
*)
hs (c_test {arg=arg ; off=0} s)
;;
end