Rectifications du switch (ajout d'un test de borne).

Ajout de Pbittest.


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

4 files changed, 60 insertions, 40 deletions

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index b0ea552c6..ae5cf6297 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -30,7 +30,7 @@ type ulambda =
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list
-  | Uswitch of ulambda * int array * ulambda array * int array * ulambda array
+  | Uswitch of ulambda * ulambda_switch
   | Ustaticfail
   | Ucatch of ulambda * ulambda
   | Utrywith of ulambda * Ident.t * ulambda
@@ -40,6 +40,13 @@ type ulambda =
   | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
   | Uassign of Ident.t * ulambda
 
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_cases_consts: ulambda array;
+    us_index_blocks: int array;
+    us_cases_blocks: ulambda array;
+    us_checked: bool }
+
 (* Description of known functions *)
 
 type function_description =
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index b0ea552c6..ae5cf6297 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -30,7 +30,7 @@ type ulambda =
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list
-  | Uswitch of ulambda * int array * ulambda array * int array * ulambda array
+  | Uswitch of ulambda * ulambda_switch
   | Ustaticfail
   | Ucatch of ulambda * ulambda
   | Utrywith of ulambda * Ident.t * ulambda
@@ -40,6 +40,13 @@ type ulambda =
   | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
   | Uassign of Ident.t * ulambda
 
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_cases_consts: ulambda array;
+    us_index_blocks: int array;
+    us_cases_blocks: ulambda array;
+    us_checked: bool }
+
 (* Description of known functions *)
 
 type function_description =
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 21d41c153..f06844e62 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -47,8 +47,9 @@ let occurs_var var u =
     | Uletrec(decls, body) ->
         List.exists (fun (id, u) -> occurs u) decls or occurs body
     | Uprim(p, args) -> List.exists occurs args
-    | Uswitch(arg, const_index, const_cases, block_index, block_cases) ->
-        occurs arg or occurs_array const_cases or occurs_array block_cases
+    | Uswitch(arg, s) ->
+        occurs arg or occurs_array s.us_cases_consts
+                   or occurs_array s.us_cases_blocks
     | Ustaticfail -> false
     | Ucatch(body, hdlr) -> occurs body or occurs hdlr
     | Utrywith(body, exn, hdlr) -> occurs body or occurs hdlr
@@ -183,11 +184,18 @@ let rec close fenv cenv = function
        Value_unknown)
   | Lprim(p, args) ->
       (Uprim(p, close_list fenv cenv args), Value_unknown)
-  | Lswitch(arg, nconst, consts, nblock, blocks) ->
+  | Lswitch(arg, sw) ->
       let (uarg, _) = close fenv cenv arg in
-      let (const_index, const_cases) = close_switch fenv cenv nconst consts in
-      let (block_index, block_cases) = close_switch fenv cenv nblock blocks in
-      (Uswitch(uarg, const_index, const_cases, block_index, block_cases),
+      let (const_index, const_cases) =
+        close_switch fenv cenv sw.sw_numconsts sw.sw_consts in
+      let (block_index, block_cases) =
+        close_switch fenv cenv sw.sw_numblocks sw.sw_blocks in
+      (Uswitch(uarg, 
+               {us_index_consts = const_index;
+                us_cases_consts = const_cases;
+                us_index_blocks = block_index;
+                us_cases_blocks = block_cases;
+                us_checked = sw.sw_checked}),
        Value_unknown)
   | Lstaticfail ->
       (Ustaticfail, Value_unknown)
@@ -217,8 +225,6 @@ let rec close fenv cenv = function
       let (uhi, _) = close fenv cenv hi in
       let (ubody, _) = close fenv cenv body in
       (Ufor(id, ulo, uhi, dir, ubody), Value_unknown)
-  | Lshared(lam, _) ->
-      close fenv cenv lam
   | Lassign(id, lam) ->
       let (ulam, _) = close fenv cenv lam in
       (Uassign(id, ulam), Value_unknown)
@@ -315,26 +321,21 @@ and close_one_function fenv cenv id funct =
       (clos, (id, pos, approx) :: _) -> (clos, approx)
     | _ -> fatal_error "Closure.close_one_function"
 
-(* Close a switch, preserving sharing between cases. *)
+(* Close a switch *)
 
 and close_switch fenv cenv num_keys cases =
   let index = Array.new num_keys 0 in
   let ucases = ref []
-  and num_cases = ref 0
-  and cases_processed = ref [] in
+  and num_cases = ref 0 in
   if List.length cases < num_keys then begin
     num_cases := 1;
     ucases := [Ustaticfail]
   end;
   List.iter
     (function (key, lam) ->
-      try
-        index.(key) <- List.assq lam !cases_processed
-      with Not_found ->
         let (ulam, _) = close fenv cenv lam in
         ucases := ulam :: !ucases;
         index.(key) <- !num_cases;
-        cases_processed := (lam, !num_cases) :: !cases_processed;
         incr num_cases)
     cases;
   (index, Array.of_list(List.rev !ucases))
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 42d06937c..828b42934 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -671,37 +671,42 @@ let rec transl = function
                         float_array_set arr idx (transl_unbox_float arg3))))
       end)
 
-  (* Compaction of sparse switches *)
-  | Uprim(Ptranslate tbl, [arg]) ->
-      bind "transl" (transl arg) (fun arg ->
-        let rec transl_tests lo hi =
-          if lo > hi then int_const 0 else begin
-            let i = (lo + hi) / 2 in
-            let (first_val, last_val, ofs) = tbl.(i) in
-            Cifthenelse(
-              Cop(Ccmpi Clt, [arg; int_const first_val]),
-              transl_tests lo (i-1),
-              Cifthenelse(
-                Cop(Ccmpi Cgt, [arg; int_const last_val]),
-                transl_tests (i+1) hi,
-                add_const arg ((ofs - first_val) * 2)))
-          end in
-        transl_tests 0 (Array.length tbl - 1))
+  (* Operations on bitvects *)
+  | Uprim(Pbittest, [arg1; arg2]) ->
+      bind "index" (untag_int(transl arg2)) (fun idx ->
+        tag_int(
+          Cop(Cand, [Cop(Clsr, [Cop(Cloadchunk Byte_unsigned,
+                                    [add_int (transl arg1)
+                                      (Cop(Clsr, [idx; Cconst_int 3]))]);
+                                Cop(Cand, [idx; Cconst_int 7])]);
+                     Cconst_int 1])))
 
   | Uprim(_, _) ->
       fatal_error "Cmmgen.transl"
 
-  | Uswitch(arg, const_index, const_cases, block_index, block_cases) ->
-      if Array.length block_index = 0 then
-        transl_switch (untag_int (transl arg)) const_index const_cases
-      else if Array.length const_index = 0 then
-        transl_switch (get_tag (transl arg)) block_index block_cases
+  | Uswitch(arg, s) ->
+      (* As in the bytecode interpreter, only matching against constants
+         can be checked *)
+      if Array.length s.us_index_blocks = 0 then
+        if s.us_checked then
+          bind "switch" (untag_int (transl arg)) (fun idx ->
+            Cifthenelse(
+              Cop(Ccmpa Cge,
+                  [idx; Cconst_pointer(Array.length s.us_index_consts)]),
+              Cexit,
+              transl_switch idx s.us_index_consts s.us_cases_consts))
+        else
+          transl_switch (untag_int (transl arg))
+                        s.us_index_consts s.us_cases_consts
+      else if Array.length s.us_index_consts = 0 then
+        transl_switch (get_tag (transl arg))
+                      s.us_index_blocks s.us_cases_blocks
       else
         bind "switch" (transl arg) (fun arg ->
           Cifthenelse(
             Cop(Cand, [arg; Cconst_int 1]),
-            transl_switch (untag_int arg) const_index const_cases,
-            transl_switch (get_tag arg) block_index block_cases))
+            transl_switch (untag_int arg) s.us_index_consts s.us_cases_consts,
+            transl_switch (get_tag arg) s.us_index_blocks s.us_cases_blocks))
   | Ustaticfail ->
       Cexit
   | Ucatch(body, handler) ->