Revu compilation du filtrage des variants. Ajout de la primitive Pisint et de l'instruction bytecode ISINT.

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

16 files changed, 141 insertions, 118 deletions

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 9fa3b2518..70795add1 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -212,6 +212,7 @@ let simplif_prim_pure p (args, approxs) =
       begin match p with
         Pidentity -> make_const_ptr x
       | Pnot -> make_const_bool(x = 0)
+      | Pisint -> make_const_bool true
       | _ -> (Uprim(p, args), Value_unknown)
       end
   | [Value_constptr x; Value_constptr y] ->
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index dba089b2f..d7b8bfaa5 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -753,6 +753,10 @@ let rec transl = function
                         float_array_set arr idx (transl_unbox_float arg3))))
       end)
 
+  (* Test block / immediate int *)
+  | Uprim(Pisint, [arg]) ->
+      tag_int(Cop(Cand, [transl_arg; Cconst_int 1]))
+
   (* Operations on bitvects *)
   | Uprim(Pbittest, [arg1; arg2]) ->
       bind "index" (untag_int(transl arg2)) (fun idx ->
diff --git a/boot/ocamllex b/boot/ocamllex
index 9d165b567..64139686c 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 55aa95b96..b66d3404f 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -451,6 +451,7 @@ let rec comp_expr env exp sz cont =
         | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3)
         | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3)
         | Parraysetu _ -> Ksetvectitem
+        | Pisint -> Kisint
         | Pbittest -> Kccall("bitvect_test", 2)
         | _ -> fatal_error "Bytegen.comp_expr: prim" in
       comp_args env args sz (instr :: cont)
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 689ffe317..981cd1e92 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -255,6 +255,7 @@ let emit_instr = function
   | Kintcomp Cgt -> out opGTINT      | Kintcomp Cge -> out opGEINT
   | Koffsetint n -> out opOFFSETINT; out_int n
   | Koffsetref n -> out opOFFSETREF; out_int n
+  | Kisint -> out opISINT
   | Kgetmethod -> out opGETMETHOD
   | Kevent ev -> record_event ev
   | Kstop -> out opSTOP
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index e54658450..ec645fa91 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -94,6 +94,7 @@ type instruction =
   | Kintcomp of comparison
   | Koffsetint of int
   | Koffsetref of int
+  | Kisint
   | Kgetmethod
   | Kevent of debug_event
   | Kstop
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 2355107d4..561ce5339 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -113,6 +113,7 @@ type instruction =
   | Kintcomp of comparison
   | Koffsetint of int
   | Koffsetref of int
+  | Kisint
   | Kgetmethod
   | Kevent of debug_event
   | Kstop
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index e23a6a030..2a1aaccc5 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -55,6 +55,8 @@ type primitive =
   | Parraysetu of array_kind
   | Parrayrefs of array_kind
   | Parraysets of array_kind
+  (* Test if the argument is a block or an immediate integer *)
+  | Pisint
   (* Bitvect operations *)
   | Pbittest
 
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 8d78c7482..f1974332d 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -55,6 +55,8 @@ type primitive =
   | Parraysetu of array_kind
   | Parrayrefs of array_kind
   | Parraysets of array_kind
+  (* Test if the argument is a block or an immediate integer *)
+  | Pisint
   (* Bitvect operations *)
   | Pbittest
 
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index a37ab2ac4..ae2b5e5f1 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -132,60 +132,38 @@ let divide_constructor {cases = cl; args = al} =
       ([], {cases = cl; args = al})
   in divide cl
 
-(* Making a constructor description from a variant pattern *)
+(* Matching against a variant *)
 
-let map_variant_matching row pm =
+let make_variant_matching_constant argl = 
+  { cases = []; args = argl }
+
+let make_variant_matching_nonconst = function
+    [] -> fatal_error "Matching.make_variant_matching_nonconst"
+  | ((arg, mut) :: argl) ->
+      {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl}
+
+let divide_variant row {cases = cl; args = al} =
   let row = Btype.row_repr row in
-  let consts = ref 0 and nonconsts = ref 0 in
-  if row.row_closed then
-    List.iter
-      (fun (_, f) ->
-	match Btype.row_field_repr f with
-	  Rabsent | Reither(true, _::_, _) -> ()
-	| Reither(true, _, _) | Rpresent None -> incr consts
-	| Reither _ | Rpresent _ -> incr nonconsts)
-      row.row_fields
-  else (consts := 100000; nonconsts := 100000);
-  flush stderr;
-  let const_cstr =
-    { cstr_res = Ctype.newty (Tvariant row);
-      cstr_args = [];
-      cstr_arity = 0;
-      cstr_tag = Cstr_block 0;
-      cstr_consts = !consts;
-      cstr_nonconsts = if !nonconsts = 0 then 0 else 1 }
-  and nonconst_cstr =
-    { cstr_res = Predef.type_int;
-      cstr_args = [];
-      cstr_arity = 0;
-      cstr_tag = Cstr_block 0;
-      cstr_consts = !nonconsts;
-      cstr_nonconsts = 0 }
-  in
-  let pat_variant pat =
-    match pat.pat_desc with Tpat_variant (lab, pato, _) ->
-      if Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
-      then raise Not_found;
-      let tag = Cstr_constant (Btype.hash_variant lab) in
-      { pat with pat_desc =
-	match pato with
-	  None -> Tpat_construct({const_cstr with cstr_tag = tag}, [])
-	| Some pat' -> Tpat_construct
-	      ({ const_cstr with cstr_arity = 2 },
-               [{ pat with pat_desc =
-		    Tpat_construct ({nonconst_cstr with cstr_tag = tag}, []);
-		  pat_type = Predef.type_int };
-		pat'])
-      }
-    | _ -> pat
-  in
-  { args = pm.args;
-    cases =
-      List.fold_right
-        (fun (patl, lam) l ->
-	  try (List.map pat_variant patl, lam) :: l with Not_found -> l)
-        pm.cases [] },
-  const_cstr
+  let rec divide = function
+      ({pat_desc = Tpat_variant(lab, pato, _)} :: patl, action) :: rem ->
+        let (variants, others) = divide rem in
+        if Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent then
+          (variants, others)
+        else begin
+          let tag = Btype.hash_variant lab in
+          match pato with
+            None ->
+              (add make_variant_matching_constant variants
+                   (Cstr_constant tag) (patl, action) al,
+               others)
+          | Some pat ->
+              (add make_variant_matching_nonconst variants
+                   (Cstr_block tag) (pat :: patl, action) al,
+               others)
+        end
+    | cl ->
+        ([], {cases = cl; args = al})
+  in divide cl
 
 
 (* Matching against a variable *)
@@ -342,8 +320,7 @@ let make_switch_or_test_sequence check arg const_lambda_list int_lambda_list =
   (* min_key and max_key can be arbitrarily large, so watch out for
      overflow in the following comparison *)
   if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
-    (* Sparse matching -- use a sequence of tests
-       (4 bytecode instructions per test)  *)
+    (* Sparse matching -- use a sequence of tests *)
     make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt)
        arg const_lambda_list
   else begin
@@ -359,6 +336,16 @@ let make_switch_or_test_sequence check arg const_lambda_list int_lambda_list =
              sw_numblocks = 0; sw_blocks = []; sw_checked = check})
   end
 
+let make_test_sequence_variant_constant check arg int_lambda_list =
+  make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt) arg
+                (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list)
+
+let make_test_sequence_variant_constr check arg int_lambda_list =
+  let v = Ident.create "variant" in
+  Llet(Alias, v, Lprim(Pfield 0, [arg]),
+       make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt) (Lvar v)
+                (List.map (fun (n, l) -> (Const_int n, l)) int_lambda_list))
+
 let make_bitvect_check arg int_lambda_list =
   let bv = String.make 32 '\000' in
   List.iter
@@ -398,8 +385,16 @@ let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
       	    arg const_lambda_list
   in (Lcatch(lambda1, lambda2), total2)
 
-let combine_constructor arg cstr partial
-	(tag_lambda_list, total1) (lambda2, total2) =
+let rec split_cases = function
+    [] -> ([], [])
+  | (cstr, act) :: rem ->
+      let (consts, nonconsts) = split_cases rem in
+      match cstr with
+        Cstr_constant n -> ((n, act) :: consts, nonconsts)
+      | Cstr_block n    -> (consts, (n, act) :: nonconsts)
+      | _ -> assert false
+
+let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
   if cstr.cstr_consts < 0 then begin
     (* Special cases for exceptions *)
     let lambda1 =
@@ -415,67 +410,78 @@ let combine_constructor arg cstr partial
     in (Lcatch(lambda1, lambda2), total2)
   end else begin
     (* Regular concrete type *)
-    let rec split_cases = function
-      [] -> ([], [])
-    | (cstr, act) :: rem ->
-        let (consts, nonconsts) = split_cases rem in
-        match cstr with
-          Cstr_constant n -> ((n, act) :: consts, nonconsts)
-        | Cstr_block n    -> (consts, (n, act) :: nonconsts)
-        | _ -> assert false in
-    let (consts, nonconsts) = split_cases tag_lambda_list
-    and total = total1 &
-      (partial = Total or
-       List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts) in
-    let mkifthenelse arg act2 n act1 =
-      if n = 0 then Lifthenelse(arg, act2, act1) else
-      Lifthenelse
-        (Lprim (Pandint, [arg; Lconst (Const_pointer 0)]), act2, act1) in
+    let (consts, nonconsts) = split_cases tag_lambda_list in
     let lambda1 =
-      if total &
-	List.for_all (fun (_, act) -> act = lambda_unit) tag_lambda_list
-      then
-	lambda_unit
-      else
       match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
-        (_, _, [n, act], []) when total -> act
-      | (_, _, [], [n, act]) when total -> act
-      | (_, _, [n, act1], [m, act2]) when total ->
-          mkifthenelse arg act2 n act1
-      |	(1, 0, [n, act], []) -> act
+        (1, 0, [0, act], []) -> act
       | (0, 1, [], [0, act]) -> act
-      | (1, 1, [n, act1], [0, act2]) ->
-          mkifthenelse arg act2 n act1
-      | (1, 1, [n, act1], []) ->
-          mkifthenelse arg Lstaticfail n act1
-      | (n, 1, [], [0, act2]) ->
-          mkifthenelse arg act2 1 Lstaticfail
+      | (1, 1, [0, act1], [0, act2]) ->
+          Lifthenelse(arg, act2, act1)
+      | (1, 1, [0, act1], []) ->
+          Lifthenelse(arg, Lstaticfail, act1)
+      | (1, 1, [], [0, act2]) ->
+          Lifthenelse(arg, act2, Lstaticfail)
       | (_, _, _, _) ->
-	  if cstr.cstr_nonconsts > 1
-          || List.for_all (fun (n,_) -> n < cstr.cstr_consts & n >= 0) consts
-	  && List.for_all (fun (n,_) -> n < cstr.cstr_nonconsts & n >= 0)
-	       nonconsts
-	  && List.length consts > 1 + cstr.cstr_consts / 4
-	  then
-	    Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
-			  sw_consts = consts;
-			  sw_numblocks = cstr.cstr_nonconsts;
-			  sw_blocks = nonconsts;
-			  sw_checked = false})
-	  else
-	  let cases = List.map (fun (n, act) -> Const_int n, act) consts in
-	  if cstr.cstr_nonconsts = 0 then
-      	    make_switch_or_test_sequence (not total) arg cases consts
-	  else
-	    let act =
-	      match nonconsts with [_, act] -> act | _ -> Lstaticfail in
-	    mkifthenelse arg act 1
-      	      (make_switch_or_test_sequence (not total) arg cases consts)
-    in
-    if total then (lambda1, true)
+          Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
+                        sw_consts = consts;
+                        sw_numblocks = cstr.cstr_nonconsts;
+                        sw_blocks = nonconsts;
+                        sw_checked = false}) in
+    if total1
+    && List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
+    then (lambda1, true)
     else (Lcatch(lambda1, lambda2), total2)
   end
 
+let combine_variant row arg partial (tag_lambda_list, total1)
+                                    (lambda2, total2) =
+  let row = Btype.row_repr row in
+  let num_constr = ref 0 in
+  if row.row_closed then
+    List.iter
+      (fun (_, f) ->
+	match Btype.row_field_repr f with
+	  Rabsent | Reither(true, _::_, _) -> ()
+        | _ -> incr num_constr)
+      row.row_fields
+  else
+    num_constr := max_int;
+  let (consts, nonconsts) = split_cases tag_lambda_list in
+  let total =
+    total1 && (partial = Total || List.length tag_lambda_list = !num_constr) in
+  let test_int_or_block arg if_int if_block =
+    Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
+  let lambda1 =
+    if total &&
+       List.for_all (fun (_, act) -> act = lambda_unit) tag_lambda_list
+    then
+      lambda_unit
+    else
+      match (consts, nonconsts) with
+        ([n, act], []) when total -> act
+      | ([], [n, act]) when total -> act
+      | ([n, act1], [m, act2]) when total ->
+          test_int_or_block arg act1 act2
+      | ([n, act], []) ->
+          make_test_sequence_variant_constant (not total) arg consts
+      | (_, []) ->
+          let lam = make_test_sequence_variant_constant
+                       (not total) arg consts in
+          if total then lam else test_int_or_block arg lam Lstaticfail
+      | ([], _) ->
+          let lam = make_test_sequence_variant_constr
+                       (not total) arg nonconsts in
+          if total then lam else test_int_or_block arg Lstaticfail lam
+      | (_, _) ->
+          let lam_const = make_test_sequence_variant_constant
+                               (not total) arg consts in
+          let lam_nonconst = make_test_sequence_variant_constr
+                               (not total) arg nonconsts in
+          test_int_or_block arg lam_const lam_nonconst
+  in
+  if total then (lambda1, true)
+  else (Lcatch(lambda1, lambda2), total2)
+
 let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) =
   if total1 & total2 then
     (Lsequence(lambda1, lambda2), true)
@@ -579,15 +585,14 @@ let rec compile_match repr partial m =
                 let (constrs, others) = divide_constructor pm in
 		let partial' =
 		  if others.cases = [] then partial else Partial in
-                combine_constructor newarg cstr partial'
+                combine_constructor newarg cstr
                   (compile_list partial' constrs)
 		  (compile_match repr partial others)
             | Tpat_variant(lab, _, row) ->
-	        let pm, cstr = map_variant_matching row pm in
-                let (constrs, others) = divide_constructor pm in
+                let (constrs, others) = divide_variant row pm in
 		let partial' =
 		  if others.cases = [] then partial else Partial in
-                combine_constructor newarg cstr partial'
+                combine_variant row newarg partial'
                   (compile_list partial' constrs)
 		  (compile_match repr partial others)
             | Tpat_record((lbl, _) :: _) ->
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 9ffa9bdf9..3577386ef 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -98,6 +98,7 @@ let instruction = function
   | Kintcomp Cge -> print_string "\tgeint"
   | Koffsetint n -> print_string "\toffsetint "; print_int n
   | Koffsetref n -> print_string "\toffsetref "; print_int n
+  | Kisint -> print_string "\tisint"
   | Kgetmethod -> print_string "\tgetmethod"
   | Kstop -> print_string "\tstop"
   | Kevent ev -> print_string "\tevent "; print_int ev.ev_char
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 6400d9063..03c23597c 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -115,6 +115,7 @@ let primitive = function
   | Parraysetu _ -> print_string "array.unsafe_set"
   | Parrayrefs _ -> print_string "array.get"
   | Parraysets _ -> print_string "array.set"
+  | Pisint -> print_string "isint"
   | Pbittest -> print_string "testbit"
 
 let rec lambda = function
diff --git a/byterun/exec.h b/byterun/exec.h
index 627570656..444f8548c 100644
--- a/byterun/exec.h
+++ b/byterun/exec.h
@@ -42,5 +42,5 @@ struct exec_trailer {
 
 /* Magic number for this release */
 
-#define EXEC_MAGIC "Caml1999X004"
+#define EXEC_MAGIC "Caml1999X005"
 
diff --git a/byterun/instruct.h b/byterun/instruct.h
index 823a0ed76..5ad1e6c41 100644
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -44,7 +44,7 @@ enum instructions {
   NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT,
   ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT,
   EQ, NEQ, LTINT, LEINT, GTINT, GEINT,
-  OFFSETINT, OFFSETREF,
+  OFFSETINT, OFFSETREF, ISINT,
   GETMETHOD,
   STOP, EVENT, BREAK
 };
diff --git a/byterun/interp.c b/byterun/interp.c
index d5c21f310..a61252e7a 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -941,6 +941,9 @@ value interprete(code_t prog, asize_t prog_size)
       accu = Val_unit;
       pc++;
       Next;
+    Instruct(ISINT):
+      accu = Val_long(accu & 1);
+      Next;
 
 /* Object-oriented operations */
 
diff --git a/utils/config.mlp b/utils/config.mlp
index 756682f3b..c990c5ce0 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "2.99 (99/12/02)"
+let version = "2.99 (99/12/06)"
 
 let standard_library =
   try
@@ -27,7 +27,7 @@ let native_partial_linker = "%%PARTIALLD%%"
 let c_libraries = "%%CCLIBS%%"
 let ranlib = "%%RANLIBCMD%%"
 
-let exec_magic_number = "Caml1999X004"
+let exec_magic_number = "Caml1999X005"
 and cmi_magic_number = "Caml1999I005"
 and cmo_magic_number = "Caml1999O004"
 and cma_magic_number = "Caml1999A004"