new Switch module

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3494 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

6 files changed, 672 insertions, 693 deletions

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index af2c3994c3..3adc93320e 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -571,17 +571,14 @@ let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
 exception Found of int
 
 let make_switch_gen arg cases acts =
-  let min_key,_,_ = cases.(0)
-  and _,max_key,_ = cases.(Array.length cases-1) in
-  let new_cases = Array.create (max_key-min_key+1) 0 in
+  let lcases = Array.length cases in
+  let new_cases = Array.create lcases 0 in
   let store = Switch.mk_store (=) in
             
   for i = 0 to Array.length cases-1 do
-    let l,h,act = cases.(i) in
+    let act = cases.(i) in
     let new_act = store.Switch.act_store act in
-    for j = l to h do
-      new_cases.(j-min_key) <- new_act
-    done
+    new_cases.(i) <- new_act
   done ;
   Cswitch
     (arg, new_cases,
@@ -609,6 +606,7 @@ struct
   let make_prim p args = Cop (p,args)
   let make_offset arg n = add_const arg n
   let make_isout h arg =  Cop (Ccmpa Clt, [h ; arg])
+  let make_isin h arg =  Cop (Ccmpa Cge, [h ; arg])
   let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
   let make_switch arg cases actions =
     make_switch_gen arg cases actions
@@ -1377,35 +1375,9 @@ and transl_switch arg index cases = match Array.length cases with
       (fun a ->
         SwitcherBlocks.zyva
           (fun i -> Cconst_int i)
-          a (Switch.Int 0) (Switch.Int (n_index-1))
+          a
           (Array.of_list !inters) actions)
         
-(* OLD CODE
-  | 2 -> Cifthenelse(arg, transl cases.(index.(1)), transl cases.(index.(0)))
-  | _ ->
-      (* Determine whether all actions minus one or two are equal to
-         Ustaticfail 0 *)
-      let num_fail = ref 0 in
-      let key1 = ref (-1) in
-      let key2 = ref (-1) in
-      for i = 0 to Array.length index - 1 do
-        if cases.(index.(i)) = Ustaticfail (0, []) then incr num_fail
-        else if !key1 < 0 then key1 := i
-        else if !key2 < 0 then key2 := i
-      done;
-      match Array.length index - !num_fail with
-        0 -> Csequence(arg, Cexit (0, []))
-      | 1 -> Cifthenelse(Cop(Ccmpi Ceq, [arg; Cconst_int !key1]),
-                         transl cases.(index.(!key1)), Cexit (0, []))
-      | 2 -> bind "test" arg (fun a ->
-               Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key1]),
-                           transl cases.(index.(!key1)),
-                           Cifthenelse(Cop(Ccmpi Ceq, [a; Cconst_int !key2]),
-                                       transl cases.(index.(!key2)),
-                                       Cexit (0, []))))
-      | _ -> Cswitch(arg, index, Array.map transl cases)
-OLD CODE *)
-
 and transl_letrec bindings cont =
   let rec init_blocks = function
       [] -> fill_blocks bindings
diff --git a/boot/ocamlc b/boot/ocamlc
index c163cd5705..245f47d29c 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 9f19574c7c..d52a226a68 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index eb843c0502..1452268975 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1307,9 +1307,15 @@ let make_switch_offset arg min_key max_key int_lambda_list default  =
           sw_failaction = default})
 
 let make_switch_switcher arg cases acts =
-  let min_key, max_key, clauses, default = as_int_list cases acts in
-  make_switch_offset arg 0 (max_key-min_key) clauses default
-
+  let l = ref [] in
+  for i = Array.length cases-1 downto 0 do
+    l := (i,acts.(cases.(i))) ::  !l
+  done ;    
+  Lswitch(arg,
+          {sw_numconsts = Array.length cases ; sw_consts = !l ;
+           sw_numblocks = 0 ; sw_blocks =  []  ;
+           sw_failaction = None})
+           
 let full sw =
   List.length sw.sw_consts = sw.sw_numconsts &&
   List.length sw.sw_blocks = sw.sw_numblocks
@@ -1374,6 +1380,7 @@ module SArg = struct
     bind Alias newvar arg (body newarg)
 
   let make_isout h arg = Lprim (Pisout, [h ; arg])
+  let make_isin h arg = Lprim (Pnot,[make_isout h arg])
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
   let make_switch = make_switch_switcher
 end
@@ -1387,14 +1394,11 @@ let lambda_of_int i =  Lconst (Const_base (Const_int i))
 let as_interval_canfail fail low high l =
   let store = mk_store equal_action in
   let rec nofail_rec cur_low cur_high cur_act = function
-    | [] -> begin match high with
-      | TooMuch -> [cur_low,cur_high,cur_act]
-      | Int h ->
-        if cur_high = h then
+    | [] ->
+        if cur_high = high then
           [cur_low,cur_high,cur_act]
         else
-          [(cur_low,cur_high,cur_act) ; (cur_high+1,h, 0)]
-    end
+          [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)]
     | ((i,act_i)::rem) as all ->
         let act_index = store.act_store act_i in
         if cur_high+1= i then
@@ -1422,30 +1426,22 @@ let as_interval_canfail fail low high l =
     | (i,act_i)::rem as all ->
         let index = store.act_store act_i in
         if index=0 then
-          match low with
-          | TooMuch -> init_rec rem
-          | Int low -> fail_rec low i rem
-        else begin match low with
-        | TooMuch -> nofail_rec i i index rem
-        | Int low ->
-            if low < i then
-              (low,i-1,0)::nofail_rec i i index rem
+          fail_rec low i rem
+        else
+          if low < i then
+            (low,i-1,0)::nofail_rec i i index rem
           else
-              nofail_rec i i index rem
-      end in
+            nofail_rec i i index rem in
 
   ignore (store.act_store fail) ; (* fail has action index 0 *)
   let r = init_rec (sort_lambda_list l) in
-  low, high, Array.of_list r,  store.act_get ()
+  Array.of_list r,  store.act_get ()
 
 let as_interval_nofail l =
-  let store = mk_store equal_action
-  and high = ref (-1)
-  and low = ref (-1) in
+  let store = mk_store equal_action in
 
   let rec i_rec cur_low cur_high cur_act = function
     | [] ->
-        high := cur_high ;
         [cur_low, cur_high, cur_act]
     | (i,act)::rem ->
         let act_index = store.act_store act in
@@ -1456,21 +1452,19 @@ let as_interval_nofail l =
           i_rec i i act_index rem in
   let inters = match sort_lambda_list l with
   | (i,act)::rem ->
-      low := i ;
       let act_index = store.act_store act in
       i_rec i i act_index rem
   | _ -> assert false in
-  Int !low, Int !high, Array.of_list inters, store.act_get ()
+  Array.of_list inters, store.act_get ()
 
 let as_interval fail low high l = match fail with
 | None -> as_interval_nofail l
 | Some act -> as_interval_canfail act low high l
 
 let call_switcher konst fail arg low high int_lambda_list =
-  let real_low, real_high, cases, actions =
+  let cases, actions =
     as_interval fail low high int_lambda_list in
-  Switcher.zyva
-    konst arg real_low real_high cases actions
+  Switcher.zyva konst arg cases actions
 
 
 let exists_ctx ok ctx =
@@ -1613,9 +1607,7 @@ let combine_constant arg cst partial ctx def
           List.map (function Const_int n, l -> n,l | _ -> assert false)
             const_lambda_list in
         call_switcher
-          lambda_of_int fail arg
-          Switch.TooMuch Switch.TooMuch
-          int_lambda_list
+          lambda_of_int fail arg min_int max_int int_lambda_list
     | Const_char _ ->
         let int_lambda_list =
           List.map (function Const_char c, l -> (Char.code c, l)
@@ -1623,9 +1615,7 @@ let combine_constant arg cst partial ctx def
             const_lambda_list in
         call_switcher
           (fun i -> Lconst (Const_base (Const_int i)))
-          fail arg
-          (Switch.Int 0) (Switch.Int 255)
-          int_lambda_list
+          fail arg 0 255 int_lambda_list
     | Const_string _ ->
         make_test_sequence
           fail prim_string_notequal Praise arg const_lambda_list
@@ -1702,12 +1692,10 @@ let combine_constructor arg ex_pat cstr partial ctx def
           with
           | (1, 1, [0, act1], [0, act2]) ->
               Lifthenelse(arg, act2, act1)
-          | n,0,_,[] ->
+          | (n,_,_,[])  ->
               call_switcher
                 (fun i -> Lconst (Const_base (Const_int i)))
-                None arg
-                (Switch.Int 0) (Switch.Int (n-1))
-                consts
+                None arg 0 (n-1) consts
           | (n, _, _, _) ->
               match same_actions nonconsts with
               | None ->
@@ -1722,21 +1710,28 @@ let combine_constructor arg ex_pat cstr partial ctx def
                      call_switcher
                        (fun i -> Lconst (Const_base (Const_int i)))
                        None arg
-                       (Switch.Int 0) (Switch.Int (n-1))
-                       consts,
+                       0 (n-1) consts,
                      act) in
     lambda1, jumps_union local_jumps total1
   end
 
 let make_test_sequence_variant_constant fail arg int_lambda_list =
-  make_test_sequence fail (Pintcomp Cneq) (Pintcomp Clt) arg
-                (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)
+  let cases, actions =
+    as_interval fail min_int max_int int_lambda_list in
+  Switcher.test_sequence
+    (fun i -> Lconst (Const_base (Const_int i))) arg cases actions
+
+let call_switcher_variant_constant fail arg int_lambda_list =
+  call_switcher
+    (fun i -> Lconst (Const_base (Const_int i)))
+    fail arg min_int max_int int_lambda_list
 
-let make_test_sequence_variant_constr fail arg int_lambda_list =
+let call_switcher_variant_constr fail arg int_lambda_list =
   let v = Ident.create "variant" in
   Llet(Alias, v, Lprim(Pfield 0, [arg]),
-       make_test_sequence fail (Pintcomp Cneq) (Pintcomp Clt) (Lvar v)
-                (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list))
+       call_switcher
+         (fun i -> Lconst (Const_base (Const_int i)))
+         fail (Lvar v) min_int max_int int_lambda_list)
 
 let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
   let row = Btype.row_repr row in
@@ -1771,7 +1766,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
       | (_, []) -> (* One can compare integers and pointers *)
           make_test_sequence_variant_constant fail arg consts
       | ([], _) ->
-          let lam = make_test_sequence_variant_constr
+          let lam = call_switcher_variant_constr
                        fail arg nonconsts in
           (* One must not dereference integers *)
           begin match fail with
@@ -1780,10 +1775,10 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
           end
       | (_, _) ->
           let lam_const =
-            make_test_sequence_variant_constant
+            call_switcher_variant_constant
               fail arg consts
           and lam_nonconst =
-            make_test_sequence_variant_constr
+            call_switcher_variant_constr
               fail arg nonconsts in
           test_int_or_block arg lam_const lam_nonconst
   in
@@ -1801,8 +1796,7 @@ let combine_array arg kind partial ctx def
       call_switcher
         lambda_of_int
         fail (Lvar newvar)
-        (Switch.Int 0) Switch.TooMuch
-        len_lambda_list in
+        0 max_int len_lambda_list in
     bind
       Alias newvar (Lprim(Parraylength kind, [arg])) switch in
   lambda1, jumps_union local_jumps total1
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index 0e635c6ec7..94bd585bba 100644
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-type iext = TooMuch | Int of int
-
 (* Store for actions in object style *)
 exception Found of int
 
@@ -39,6 +37,7 @@ let mk_store same =
   {act_store=store ; act_get=get}
 
 
+
 module type S =
  sig
    type primitive
@@ -54,660 +53,672 @@ module type S =
    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 * int * int) array -> act array -> act
+      act -> int array -> act array -> 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 l_status = Linter | Lsimple
-    type t_status =
-        Linear of l_status | Switch | ToCluster | Empty
 
-    let string_of_status = function
-      | Linear Linter -> "Linter"
-      | Linear Lsimple -> "L"
-      | Empty -> "E"
-      | Switch -> "S"
-      | ToCluster -> "?"
+    type 'a inter =
+        {cases : (int * int * int) array ;
+          actions : 'a array}
 
+type 'a t_ctx =  {off : int ; arg : 'a}
 
-    type 'a inter =
-        {low : iext ; high : iext ;
-          icases : (int * int * int) array ;
-          iacts : 'a array ;
-          status : t_status}
-
-    let prerr_icases t =
-      prerr_string "{ " ;
-      for i = 0 to Array.length t-1 do
-        let l,h,act = t.(i) in
-        Printf.fprintf stderr "(%d,%d,%d) " l h act
-      done ;
-      prerr_string "}"
+let cut = ref 8
 
+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 string_of_iext = function
-      | TooMuch -> "oo"
-      | Int i   -> string_of_int 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
-        "status=%s, low=%s, high=%s, cases="
-        (string_of_status i.status)
-        (string_of_iext i.low) (string_of_iext i.high) ;
-      prerr_icases i.icases
+    let prerr_inter i = Printf.fprintf stderr
+        "cases=%a" pcases i.cases
 
-let inter_default _ = function
-   | 0 -> true
-   | _ -> false
+let get_act cases i =
+  let _,_,r = cases.(i) in
+  r
+and get_low cases i =
+  let r,_,_ = cases.(i) in
+  r
 
-let is_closed i = match i.low, i.high with
-  | Int _, Int _ -> true
-  | _,_          -> false
+type ctests = {
+    mutable n : int ;
+    mutable ni : int ;
+  }
 
-type 'a t_ctx = 
-  {ctx_low : iext ; ctx_high : iext ; off : int ;
-  arg : 'a}
+let too_much = {n=max_int ; ni=max_int}
 
-let find_staticfail _ = 0
+let ptests chan {n=n ; ni=ni } =
+  Printf.fprintf chan "{n=%d ; ni=%d }" n ni
 
-let arg_default i ctx = i.iacts.(0) ctx
+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 as_checked i = match i.low, i.high with
-| Int _, Int _ ->
-    let cases = i.icases in
-    let len = Array.length cases in
-    let l0,h0,a0 = cases.(0)
-    and ln,hn,an = cases.(len-1) in
-    if inter_default i a0 && inter_default i an then
-      {i with low=TooMuch ; high=TooMuch ;
-       icases=Array.sub cases 1 (len-2)}
-    else
-      i
-| TooMuch,Int _ ->
-    let cases = i.icases in
-    let len = Array.length cases in
-    let ln,hn,an = cases.(len-1) in
-    if inter_default i an then
-      {i with high=TooMuch ; icases = Array.sub cases 0 (len-1)}
-    else
-      i
-| Int _,TooMuch ->
-    let cases = i.icases in
-    let len = Array.length cases in
-    let l0,h0,a0 = cases.(0) in
-    if inter_default i a0 then
-      {i with low=TooMuch ; icases = Array.sub cases 1 (len-1)}
+let count_tests s =
+  let r =
+    Array.init
+      (Array.length s.actions)
+      (fun _ -> {n=0 ; ni=0 }) in
+  let c = s.cases in
+  let imax = Array.length c-1 in
+  for i=0 to imax do
+    let l,h,act = c.(i) in
+    let x = r.(act) in
+    x.n <- x.n+1 ;
+    if l < h && i<> 0 && i<>imax then
+      x.ni <- x.ni+1 ;
+  done ;
+  r
+
+
+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
-      i
-| _,_ -> i
-*)
+      false
+  end else
+    false
 
+and eq_tests c1 c2 =
+  c1.n = c2.n && c1.ni=c2.ni
 
+let min_tests c1 c2 = if less_tests c1 c2 then c1 else c2
 
+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.create (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.create (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.create (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 ninters {low=low ; high=high ; icases = cases} =
-  Array.length cases +
-    (match low,high with
-    | Int _, Int _ -> 0
-    | _,_          -> 1)
-
-let min_key i = match i.low with
-| TooMuch ->
-    let low,_,_ = i.icases.(0) in
-    low
-| Int low -> low
-
-and max_key i =  match i.high with
-| TooMuch ->
-    let _,high,_ = i.icases.(Array.length i.icases-1) in
-    high
-| Int high -> high
-
-let nlabels i =  max_key i/4 - min_key i/4
-
-let count_bornes i =  if is_closed i then 0 else 1
-
-exception NoSuch
-
-let single_values i =
-  let singles = ref []
-  and def = ref None
-  and cases = i.icases in
-  for i = 0 to Array.length cases-1 do
-    let low,high,act = cases.(i) in
-    if low=high then begin
-      match !def with
-      | Some def when def=act -> ()
-      | _ ->
-          singles := (low,act) :: !singles
-    end else match !def with
-    | None ->
-        def := Some act ;
-        singles :=
-           List.filter (fun (_,act0) -> act0 <> act) !singles
-    | Some def ->
-        if def <> act then raise NoSuch
-  done ;
-  match i.low,i.high,!def,!singles with
-  | Int _, Int _, None,(_,x)::r -> r,x
-  | Int _, Int _, Some x,r  -> r,x
-  | _,_,Some x,r when inter_default i x -> r,x
-  | _,_,None,r              -> r,find_staticfail i
-  | _,_,_,_                 -> raise NoSuch  
-
-let count_by_action i =
-  let low = i.low and high = i.high in
-  let t = Array.create (Array.length i.iacts) (0,0,0) in
-  let add l h act =
-    let old_n,old_itests,old_ztests = t.(act) in    
-    t.(act) <-
-       (old_n+1,
-        old_itests +
-          (if l=h then 0
-          else if Int l = low then 0
-          else if Int h = high then 0
-          else 1),
-        old_ztests +
-          (if l=h && Int l = low then 1 else 0)) in
-  Array.iter (fun (l,h,act) -> add l h act) i.icases ;
-  t
-
-and group_by_action i =
-  let t = Array.create (Array.length i.iacts) [] in
-  let add l h act = t.(act) <- (l,h)::t.(act) in
-  Array.iter (fun (l,h,act) -> add l h act) i.icases ;
-  t
-
-and low_action i =
-  let _,_,act = i.icases.(0) in
-  act
-
-and high_action i =
-  let cases = i.icases in
-  let _,_,act = cases.(Array.length cases-1) in
-  act
-
-let array_iteri_rev f t =
-  for i = Array.length t-1 downto 0 do
-    f i t.(i)
-  done
+  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
 
-exception Found of int
+  let l,h,act = cases.(Array.length cases-1) in
+  make_one l h act::make_rec (Array.length cases-2) l 
+                       
 
-let inter_values i =
-  if is_closed i then begin
-
-    let find_max t =
-      let max = ref (-1) and max_itests = ref (-1) and max_ztests = ref (-1)
-      and max_act = ref (-1) in
-      array_iteri_rev
-        (fun act (n,itests,ztests) ->
-          if
-            n > !max ||(* choose action with maximum number of intervals *)
-                   (* then with maximal number of actual interval tests *)
-            (n = !max &&  itests > !max_itests) ||
-                   (* then with minimal number of tests against zero *)
-            (n = !max && itests = !max_itests && ztests < !max_ztests)
-          then begin
-            max := n ;
-            max_itests := itests ;
-            max_ztests := ztests ;
-            max_act := act
-          end) t ;
-      !max_act in
-    
-    let max_act = find_max (count_by_action i) in
-    List.filter
-      (fun (l,h,act) -> act <> max_act)
-      (Array.to_list i.icases),
-    max_act
+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)
 
-  end else
-    List.filter
-      (fun (l,h,act) -> not (inter_default i act))
-      (Array.to_list i.icases),
-    find_staticfail i
 
   
-let count_tests i = match i.icases with
-| [| _ |] -> count_bornes i, Lsimple
-| _ ->
-  let count_inter =
-    try
-      let l,_ = inter_values i in
-      List.length l
-    with
-    | NoSuch -> 1000
-
-  and count_simple =
-    let  cases,low,high = i.icases, i.low, i.high in
-    let n = Array.length cases-1 in
-    n + count_bornes i in
+let rec opt_count top cases =
+  let key = make_key cases in
+  try
+    let r = Hashtbl.find t key in
+    r
+  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
+              heuristic top cases in
+      Hashtbl.add t key r ;
+      r
 
-  if count_inter <=  count_simple then
-    count_inter, Linter
+and heuristic top cases =
+  let lcases = Array.length cases in
+  let m = lcases/2 in
+  let lim,left,right = coupe cases m in
+  let sep,csep =
+    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 inter,cinter =
+    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) in
+  if less2tests csep cinter then
+    sep,csep
   else
-    count_simple, Lsimple
-  
+    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 lim,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 lcases <= 2 then
+        -1,-1,(too_much,too_much)
+      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 konst test arg i ifso ifnot =
   Arg.make_if
-    (Arg.make_prim test [arg.arg ; konst (i+arg.off)])
+    (Arg.make_prim test [arg ; konst i])
     ifso ifnot
 
-let inter_ctx off l h arg =
-  {off=off ; ctx_low = Int l ; ctx_high = Int h ; arg = arg}
+let make_if_lt konst arg i  ifso ifnot = match i with
+| 1 ->
+    make_if_test konst Arg.leint arg 0 ifso ifnot
+| _ ->
+    make_if_test konst Arg.ltint arg i ifso ifnot
+    
+and make_if_le konst arg i ifso ifnot = match i with
+| -1 ->
+    make_if_test konst Arg.ltint arg 0 ifso ifnot
+| _ ->
+    make_if_test konst Arg.leint arg i ifso ifnot
 
-let make_if_inter konst arg l h mk_ifin ifout =
-  if l=h then
-    make_if_test konst Arg.neint arg l ifout
-      (mk_ifin (inter_ctx arg.off l h arg.arg))
-  else
-    let new_off = arg.off-l in
+and make_if_gt konst arg i  ifso ifnot = match i with
+| -1 ->
+    make_if_test konst Arg.geint arg 0 ifso ifnot
+| _ ->
+    make_if_test konst Arg.gtint arg i ifso ifnot
+    
+and make_if_ge konst arg i  ifso ifnot = match i with
+| 1 ->
+    make_if_test konst Arg.gtint arg 0 ifso ifnot
+| _ ->
+    make_if_test konst 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_ne  konst arg i ifso ifnot =
+  make_if_test konst 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
+| 0 ->
+    do_make_if_out
+      (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
+| _ ->
     Arg.bind
-      (Arg.make_offset arg.arg (-l))
+      (Arg.make_offset ctx.arg (-l-ctx.off))
       (fun arg ->
-        Arg.make_if
-          (Arg.make_isout (konst (h-l)) arg)
-          ifout (mk_ifin (inter_ctx new_off l h arg)))
-
-and make_if_inter_last  konst arg l h mk_ifin ifout =
-  if l=h then
-    make_if_test konst Arg.eqint arg l 
-      (mk_ifin (inter_ctx arg.off l h arg.arg))
-      ifout
-  else
-    let new_off = arg.off-l in
+        let ctx = {off= (-l) ; arg=arg} in
+        do_make_if_out
+          (konst 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
+| 0 ->
+    do_make_if_in
+      (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
+| _ ->
     Arg.bind
-      (Arg.make_offset arg.arg (-l))
+      (Arg.make_offset ctx.arg (-l-ctx.off))
       (fun arg ->
-        Arg.make_if
-          (Arg.make_isout (konst (h-l)) arg)
-          ifout (mk_ifin (inter_ctx new_off l h arg)))
+        let ctx = {off= (-l) ; arg=arg} in
+        do_make_if_in
+          (konst d) arg (mk_ifso ctx) (mk_ifno ctx))
 
-let make_inters_ifs  konst arg ({iacts = acts} as i) =
-  try
-    let l,def = inter_values i in
-    let rec if_rec arg = function
-      | [] -> acts.(def) arg
-      | (l1,h1,act1)::rem ->
-          if Int l1 = arg.ctx_low then
-            make_if_test konst (if l1=h1 then Arg.neint else Arg.gtint) arg  h1
-              (if_rec  {arg with ctx_low=Int (h1+1)} rem)
-              (acts.(act1) arg)
-          else if Int h1 = arg.ctx_high then
-            make_if_test konst (if l1=h1 then Arg.neint else Arg.ltint) arg  l1
-              (if_rec {arg with ctx_high = Int (l1-1)} rem)
-              (acts.(act1) arg)
+
+let rec c_test konst 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
+    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
+              konst ctx.arg
+              (low+ctx.off)
+              (c_test konst ctx {s with cases=inside})
+              (c_test konst ctx {s with cases=outside})
           else
-            make_if_inter konst arg  l1 h1 acts.(act1) (if_rec arg rem) in
-    if_rec arg l
-  with
-  | NoSuch -> assert false
-        
-                     
-let make_linear_ifs l_status konst arg ({iacts = acts} as i) =
-  match l_status with
-  | Linter -> make_inters_ifs  konst arg i
-  | Lsimple ->
-      let  cases,low,high = i.icases,arg.ctx_low,arg.ctx_high in
-      let n = Array.length cases-1 in
-      let rec do_rec arg i =
-        if i=n then
-          let _,_,act = cases.(i) in
-          acts.(act) arg
+            make_if_ne
+              konst ctx.arg
+              (low+ctx.off)
+              (c_test konst ctx {s with cases=outside})
+              (c_test konst ctx {s with cases=inside})
+        end else begin
+          if less_tests coutside cinside then
+            make_if_in
+              konst 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})
+          else
+            make_if_out
+              konst 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})
+        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 less_tests cright cleft then
+          make_if_lt konst
+            ctx.arg (lim+ctx.off)
+            (c_test konst ctx left) (c_test konst ctx right)
         else
-          let _,high,act = cases.(i) in
-          make_if_test konst
-            Arg.leint arg high (acts.(act) arg)
-            (do_rec arg (i+1)) in
-      match low,high with
-      | TooMuch, TooMuch ->
-          let l = min_key i
-          and h = max_key i in
-          make_if_inter
-            konst arg l h (fun arg -> do_rec arg 0)
-            (arg_default i arg)
-      | TooMuch,_ ->
-          let l = min_key i in
-          make_if_test
-            konst Arg.ltint arg l (arg_default i arg) (do_rec arg 0)
-      | _, TooMuch ->
-          let h = max_key i in
-          make_if_test
-            konst Arg.gtint arg h (arg_default i arg) (do_rec arg 0)
-      | _,_ -> do_rec arg 0 
-
-let special_case i = match i.low, i.high with
-| Int 0, Int 2 -> begin match i.icases with
-  | [| (0,0,act1) ; (1,1,act2)  ; (2,2,act3) |] -> act1 <> act3
-  | _ -> false
-end
-| _ -> false
-  
-
-
-exception Ends
-exception NoCut of t_status
+          make_if_ge konst
+             ctx.arg (lim+ctx.off)
+            (c_test konst ctx right) (c_test konst ctx left)
+        
+  end
 
 
-let limit_switch = 4
-and limit_tree = 3
+(* Minimal density of switches *)
+let theta = ref 0.33333
 
-let cut_here i =
-  let c_if, l_status = count_tests i in
+(* Minmal number of tests to make a switch *)
+let switch_min = ref 3
 
-  if c_if=0 then raise (NoCut Empty) ;
-  if special_case i then raise (NoCut Switch) ;
-  if c_if - count_bornes i <=  limit_switch then
-    raise (NoCut (Linear l_status)) ;
-  let icases = i.icases in
-  let len = Array.length icases
-  and c_switch = nlabels i + 1 in
-  if c_switch <= c_if  then raise (NoCut Switch) ;
+(* 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 r = ref (-1) and max = ref (-1) in
-  for j = 0 to len-1 do
-    let low,high,_ = icases.(j) in
-    if high-low+1 > !max then begin
-      max := high-low ;
-      r := j
-    end
-  done ;
-  if len > 2 then begin
-    let l0,h0,act0 = icases.(0)
-    and ln,hn,actn = icases.(len-1) in
-    if
-      act0 = actn &&
-      (h0-l0+hn-ln+2 > !max)
-    then
-      raise Ends
-  end ;
-  !r
-
-let sub_cases from_here len cases =
-  if len <= 0 then [||]
+(* Sends back a boolean that says whether is switch is worth or not *)
+let dense ({cases=cases ; actions=actions} as s) i j =
+  if i=j then true
   else
-    Array.sub cases from_here len
+    let l,_,_ = cases.(i)
+    and _,h,_ = cases.(j) in
+    let _,(_,{n=ntests}) =
+      opt_count false (Array.sub cases i (j-i+1)) 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 present act i len cases =
-  let rec do_rec i =
-    if i < len then
-      let _,_,act0 = cases.(i) in
-      act0=act || do_rec (i+1)
-    else
-      false in
-  do_rec i
-
 
-
-let explode_linear i k =
-  let acts = i.iacts
-  and cases = i.icases in
-  let last = Array.length cases-1 in
-
-  let rec explode_rec j = match last-j with
-    | 0 ->
-        let (l,_,_) as x = cases.(j) in
-        {i with low = Int l ; icases = [| x |] ; status = Empty}::k
-    | _ ->
-        let (l,h,_) as x = cases.(j) in
-        {i with low = Int l ; high = Int h ;
-           icases = [| x |] ; status = Empty}::
-        explode_rec (j+1) in
-        
-  
-  match cases with
-  | [| |] | [| _ |] -> {i with status=Empty}::k
-  | _ ->
-      let (_,h0,_) as x = cases.(0) in
-      {i with high = Int h0 ; icases = [| x |] ; status = Empty}::
-      explode_rec 1
-
-let rec do_cluster i k =
-
-  let cases = i.icases in
-  if i.high = TooMuch && inter_default i (low_action i) then
-    let l0,h0,act0 = cases.(0) in
-    let rest = sub_cases  1 (Array.length cases-1) cases in
-    {i with high=Int h0 ; icases = [| cases.(0) |] ; status=Empty}::
-    do_cluster
-      {i with low=Int (h0+1) ; icases = rest}
-      k
-  else
-  try
-    match cases with
-    | [| _,_,act |] ->
-        if is_closed i || inter_default i act then
-          {i with status=Empty}::k
-        else
-          let _,status = count_tests i in
-          raise (NoCut (Linear status))
-    | _ ->
-    let j = cut_here i in
-
-    let c_low,c_high,c_act = cases.(j) in
-    if false (* c_low=c_high *) then begin
-      let left,right =
-        if j=0 || present c_act 0 j cases then
-          sub_cases 0 (j+1) cases,
-          sub_cases (j+1) (Array.length cases-j-1) cases
-        else
-          sub_cases 0 j cases,
-          sub_cases j (Array.length cases-j) cases in
-
-      do_cluster
-        {i with high = Int (c_low-1) ; icases=left}
-        (do_cluster
-           {i with low = Int c_low ; icases=right} k)
-    end else begin
-      let left = sub_cases 0 j cases
-      and center = [| cases.(j) |]
-      and right = sub_cases (j+1) (Array.length cases-j-1) cases in
-
-      if j=0 then
-        {i with low=i.low ; high = Int c_high ;
-         icases = center ; status=Empty}::
-        do_cluster
-          {i with low = Int (c_high+1) ; high=i.high ; icases = right} k
-      else if j = Array.length cases-1 then
-        do_cluster
-          {i with low = i.low ; high= Int (c_low-1) ; icases = left}
-          ({i with low = Int c_low ; high = i.high ;
-            icases=center ; status=Empty}::k)
-      else
-        do_cluster
-          {i with low = i.low ; high= Int (c_low-1) ; icases = left}
-          ({i with low = Int c_low ; high = Int c_high ;
-            icases=center ; status=Empty}::
-           do_cluster
-             {i with low = Int (c_high+1) ; high=i.high ; icases = right}
-             k)
-    end
-with
-| NoCut status ->
-
-    begin match status with
-    | Linear _ -> explode_linear i k
-    | _ -> {i with status=status}::k
-    end
-| Ends ->
-    let cases = i.icases in
-    let len = Array.length cases in
-    let _,h0,act0 = cases.(0)
-    and center = sub_cases 1 (len-2) cases
-    and ln,_,actn = cases.(len-1) in
-
-
-    {i with high = Int h0 ; status = Empty ; icases = [| cases.(0) |]}::
-    do_cluster
-      {i with low = Int (h0+1) ; high = Int (ln-1) ; icases = center}
-      ({i with low = Int ln ; status = Empty ; icases = [| cases.(len-1) |]}::k)
-
-
-let do_merge_clusters i1 i2 =
-  {low=i1.low ; high = i2.high ;
-    icases = Array.append i1.icases i2.icases ;
-    iacts= i1.iacts ;
-    status = ToCluster}
-
-
-exception NoMerge
-
-let merge_clusters i1 i2 = match i1.status, i2.status with
-| Linear _, Linear _  -> do_merge_clusters  i1 i2
-| _,_                -> raise NoMerge
-
-let cluster i = do_cluster i []
-
-
-
-let fail_out inter =
-  let t = inter.icases in
-  let j = ref 1
-  and len = Array.length t in
-  let new_low = 
-    let _,high,act0 as all0 = t.(0) in
-    if inter_default inter act0 then begin
-      t.(0) <- t.(1) ;
-      Int (high+1)
-    end else  begin
-      inter.low 
-    end in
-
-  for i = 1 to Array.length t-1 do
-    let (_,high,act as all) = t.(i)
-    and low0,_,act0 = t.(!j-1) in
-    if inter_default inter act ||  act0=act then
-      t.(!j-1) <- low0, high, act0
-    else begin
-      t.(!j) <- all ;
-      incr j
-    end 
+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 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 ;
-  let new_t =
-    if !j <> len then
-      Array.sub t 0 !j
-    else
-      t in
-  let _,new_high,_ = new_t.(!j-1) in
-  {inter with low = new_low ; high = Int new_high ; icases = new_t}
-      
-
-let as_int_int_acts i =
-  let acts = i.iacts in
-  Array.map
-    (fun (l,h,act) -> (l,h,acts.(act)))
-    i.icases
-
-let comp_leaf konst  arg i =  match i.status with
-  | Linear l_status -> make_linear_ifs l_status konst arg i
-  | Empty ->
-      let _,_,act = i.icases.(0) in
-      i.iacts.(act) arg
-  | Switch ->
-    let min_key = min_key i in
-    let mk_switch arg =
-      let acts = Array.map (fun act -> act arg) i.iacts in
-      Arg.make_switch arg.arg i.icases acts in
-    mk_switch {arg with arg = Arg.make_offset arg.arg (-arg.off-min_key)}
-
-  | ToCluster -> Misc.fatal_error  "Matching.comp_leaf"
-
-
-type 'a action =  | Unique of 'a | Shared of int * 'a
-
-
-let same_cluster_action c1 c2 = match c1.status, c2 with
-| Empty, Shared (i2,_) ->  low_action c1=i2
-| _,_ -> false
-
-let cluster_clusters konst arg cls =
-  let actions = ref [Shared (0, cls.(0).iacts.(0))]
-  and n_actions = ref 1 in
-  let rec store_rec  act i = function
-    | [] -> begin match act.status with 
-      | Empty ->
-          let index = low_action act in
-          [Shared (index, act.iacts.(index))]
-      | _ -> [Unique (fun arg -> comp_leaf konst arg act)]
-    end
-    | act0::rem ->
-        if same_cluster_action act act0 then
-          raise (Found i)
-        else
-          act0::store_rec act (i+1) rem in
-  let store act =
+  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.create (hh-ll+1) 0
+  and t = Hashtbl.create 17
+  and index = ref 0 in
+  let get_index act =
     try
-      actions := store_rec act 0 !actions ;
-      let r = !n_actions in
-      incr n_actions ;
-      r
+      Hashtbl.find t act
     with
-    | Found i -> i in
-  let cases =
-    Array.map
-      (fun c -> min_key c, max_key c,store c) cls in
-  let low = cls.(0).low
-  and high = cls.(Array.length cls-1).high in
-  {high = high ; low = low ;
-    icases = cases ;
-    iacts = Array.map
-      (function
-        | Unique act -> act
-        | Shared (_,act) -> act)
-      (Array.of_list !actions) ;
-    status = ToCluster}
-      
+    | 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.create !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.create 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
   
-let final_tests konst arg cl =
-
-  let rec comp_tree cl =
-  let n,status = count_tests cl in
-
-  if n <= limit_tree then
-    comp_leaf konst
-      {arg with ctx_low = cl.low ; ctx_high = cl.high}
-      {cl with status = Linear status}
-  else
-    let cases = cl.icases in
-    let len = Array.length cases in
-    let half = match cl.low, cl.high with
-    | TooMuch,Int _ -> (len-1)/2
-    | Int _, TooMuch -> (len+1)/2
-    | _,_ -> len/2 in
-    let left = sub_cases 0 half cases
-    and right = sub_cases half (len-half) cases in
-    let _,key,_ = left.(half-1) in
-      make_if_test konst
-        Arg.leint arg key
-          (comp_tree {cl with high=Int key ; icases = left})
-          (comp_tree {cl with low=Int (key+1) ; icases=right}) in
-
-  comp_tree cl 
+  zyva (len-1) (n_clusters-1) ;
+  let acts = Array.create !index (fun _ -> assert false) in
+  Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
+  {cases = r ; actions = acts}
+;;
 
   
-  
-let comp_clusters konst arg l =
-  let cls = Array.of_list l in
-  let cl = cluster_clusters konst arg cls in
-  final_tests konst arg cl
-
-let comp_inter konst arg i = comp_clusters konst arg (cluster i)
-
-
-let zyva konst arg low high cases acts =
-    let cl = 
-      {low = low ; high = high ;
-        icases = cases  ;
-        iacts=Array.map (fun act -> (fun _ -> act)) acts ;
-        status = ToCluster} in
-    comp_inter konst
-      {ctx_low=low ; ctx_high=high ; off=0 ; arg=arg} cl
-
+let zyva konst arg cases actions = 
+  let s = {cases=cases ; actions=actions} in
+  let n_clusters,k = comp_clusters s in
+  let clusters = make_clusters s n_clusters k in
+  c_test konst {arg=arg ; off=0} clusters
+
+and test_sequence konst arg cases actions =
+  let s =
+    {cases=cases ;
+    actions=Array.map (fun act -> (fun _ -> act)) actions} in
+   c_test konst {arg=arg ; off=0} s
+;;
 
 end
diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
index 456d32003e..a0b34a87a1 100644
--- a/bytecomp/switch.mli
+++ b/bytecomp/switch.mli
@@ -15,10 +15,6 @@
   of if tests and switches.
 *)
 
-(* integer plus infinity, for interval limits *)
-
-type iext = TooMuch | Int of int
-
 (* For detecting action sharing, object style *)
 
 type 'a t_store =
@@ -46,12 +42,13 @@ module type S =
     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
    (* construct an actual switch :
       make_switch arg cases acts
-      NB:  cases is in the interval form *)
+      NB:  cases is in the value form *)
     val make_switch :
-      act -> (int * int * int) array -> act array -> act
+        act -> int array -> act array -> act
   end
 
 
@@ -61,7 +58,7 @@ module type S =
     - arg is the argument of the switch.
     - low, high are the interval limits.
     - cases is a list of sub-interval and action indices
-    - action is an array of actions.
+    - actions is an array of actions.
 
   All these arguments specify a switch construct and zyva
   returns an action that performs the switch,
@@ -72,7 +69,12 @@ module Make :
       val zyva :
           (int -> Arg.act) ->
            Arg.act ->
-           iext -> iext ->
+           (int * int * int) array ->
+           Arg.act array ->
+           Arg.act
+     val test_sequence :
+          (int -> Arg.act) ->
+           Arg.act ->
            (int * int * int) array ->
            Arg.act array ->
            Arg.act