diff options
Diffstat (limited to 'bytecomp/switch.ml')
| -rw-r--r-- | bytecomp/switch.ml | 238 |
1 files changed, 154 insertions, 84 deletions
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee13..da9a48f1a 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} - -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} +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 @@ -50,13 +100,15 @@ module type S = 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_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'' *) @@ -196,7 +248,7 @@ let case_append c1 c2 = let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +277,7 @@ let case_append c1 c2 = done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +287,7 @@ let case_append c1 c2 = done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -489,77 +541,77 @@ and enum top cases = end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint 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 konst arg i ifso ifnot = - make_if_test konst Arg.neint 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 konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (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 - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (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 konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (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 - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + 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 @@ -579,31 +631,31 @@ and enum top cases = if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (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 - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (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 @@ -613,17 +665,17 @@ and enum top cases = 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 konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -676,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j = let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 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 @@ -697,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j = tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j = let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + 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 @@ -768,13 +820,13 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +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 ; @@ -787,12 +839,31 @@ let zyva (low,high) konst arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +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 = + 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 = + 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 ; @@ -804,8 +875,7 @@ and test_sequence konst arg cases actions = pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end |