summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--asmcomp/closure.ml1
-rw-r--r--asmcomp/cmmgen.ml4
-rwxr-xr-xboot/ocamllexbin82301 -> 82802 bytes
-rw-r--r--bytecomp/bytegen.ml1
-rw-r--r--bytecomp/emitcode.ml1
-rw-r--r--bytecomp/instruct.ml1
-rw-r--r--bytecomp/instruct.mli1
-rw-r--r--bytecomp/lambda.ml2
-rw-r--r--bytecomp/lambda.mli2
-rw-r--r--bytecomp/matching.ml233
-rw-r--r--bytecomp/printinstr.ml1
-rw-r--r--bytecomp/printlambda.ml1
-rw-r--r--byterun/exec.h2
-rw-r--r--byterun/instruct.h2
-rw-r--r--byterun/interp.c3
-rw-r--r--utils/config.mlp4
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
Binary files differ
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"
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-21 00:18:22 +0000