summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/dectree.ml3
-rw-r--r--bytecomp/matching.ml11
-rw-r--r--bytecomp/translcore.ml4
-rw-r--r--stdlib/Makefile2
-rw-r--r--tools/Makefile12
-rw-r--r--tools/dumpobj.ml4
-rw-r--r--typing/typedecl.ml6
-rw-r--r--typing/typedecl.mli1
-rw-r--r--typing/typedtree.ml2
-rw-r--r--typing/typedtree.mli2
-rw-r--r--utils/config.mli3
-rw-r--r--utils/config.mlp1
12 files changed, 34 insertions, 17 deletions
diff --git a/bytecomp/dectree.ml b/bytecomp/dectree.ml
index d847fac70..66e07611b 100644
--- a/bytecomp/dectree.ml
+++ b/bytecomp/dectree.ml
@@ -19,7 +19,8 @@ let make_decision_tree casei =
let rec partition start =
if start >= n then [] else
let stop = ref (n-1) in
- while keyv.(!stop) - keyv.(start) > 4 * (!stop - start) do
+ while let span = keyv.(!stop) - keyv.(start) in
+ span >= 256 or span > 4 * (!stop - start) do
decr stop
done;
(* We've found a dense enough segment.
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index ace2a0c5b..77ee1fd18 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -60,8 +60,8 @@ let divide_constant {cases = cl; args = al} =
let make_constr_matching cstr (arg :: argl) =
let (first_pos, last_pos) =
match cstr.cstr_tag with
- Cstr_tag n -> (0, cstr.cstr_arity - 1)
- | Cstr_exception p -> (1, cstr.cstr_arity) in
+ Cstr_tag _ -> (0, cstr.cstr_arity - 1)
+ | Cstr_exception _ -> (1, cstr.cstr_arity) in
let rec make_args pos =
if pos > last_pos
then argl
@@ -176,7 +176,7 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
end else begin
(* Regular concrete type *)
let caselist =
- List.map (fun (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
+ List.map (function (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
let lambda1 =
match (caselist, cstr.cstr_span) with
([0, act], 1) -> act
@@ -184,7 +184,10 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
| ([1, act], 2) -> Lifthenelse(arg, act, Lstaticfail)
| ([0, act0; 1, act1], 2) -> Lifthenelse(arg, act1, act0)
| ([1, act1; 0, act0], 2) -> Lifthenelse(arg, act1, act0)
- | _ -> Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist) in
+ | _ ->
+ if cstr.cstr_span < Config.max_tag
+ then Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist)
+ else Lswitch(Lprim(Pfield 0, [arg]), 0, cstr.cstr_span, caselist) in
if total1 & List.length tag_lambda_list = cstr.cstr_span
then (lambda1, true)
else (Lcatch(lambda1, lambda2), total2)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 35499b524..7650ed5da 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -37,7 +37,9 @@ let rec bind_pattern env pat arg mut =
bind_pattern_list env patl arg mut 0
| Tpat_construct(cstr, patl) ->
bind_pattern_list env patl arg mut
- (match cstr.cstr_tag with Cstr_tag _ -> 0 | Cstr_exception _ -> 1)
+ (match cstr.cstr_tag with
+ Cstr_tag _ -> 0
+ | Cstr_exception _ -> 1)
| Tpat_record lbl_pat_list ->
bind_label_pattern env lbl_pat_list arg mut
| _ ->
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 2c88ffaa4..e6b845e0e 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -1,7 +1,7 @@
include ../Makefile.config
COMPILER=../camlc
-CAMLC=../boot/camlrun $(COMPILER)
+CAMLC=../byterun/camlrun $(COMPILER)
CAMLDEP=../tools/camldep
OBJS=pervasives.cmo list.cmo string.cmo char.cmo array.cmo sys.cmo \
diff --git a/tools/Makefile b/tools/Makefile
index e4ca7290a..b89a26d9d 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -5,10 +5,10 @@ LINKFLAGS=$(INCLUDES)
all: dumpobj
-DUMPOBJ=opnames.zo dumpobj.zo
+DUMPOBJ=opnames.cmo dumpobj.cmo
dumpobj: $(DUMPOBJ)
- $(CAMLC) $(LINKFLAGS) -o dumpobj misc.zo tbl.zo config.zo ident.zo opcodes.zo runtimedef.zo $(DUMPOBJ)
+ $(CAMLC) $(LINKFLAGS) -o dumpobj misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo runtimedef.cmo $(DUMPOBJ)
clean::
rm -f dumpobj
@@ -27,16 +27,16 @@ clean::
beforedepend:: opnames.ml
.SUFFIXES:
-.SUFFIXES: .ml .zo .mli .zi
+.SUFFIXES: .ml .cmo .mli .cmi
-.ml.zo:
+.ml.cmo:
$(CAMLC) -c $(COMPFLAGS) $<
-.mli.zi:
+.mli.cmi:
$(CAMLC) -c $(COMPFLAGS) $<
clean::
- rm -f *.zo *.zi
+ rm -f *.cmo *.cmi
depend: beforedepend
camldep $(INCLUDES) *.mli *.ml > .depend
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 30baf82dd..2645cef6f 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -31,7 +31,7 @@ let inputs ic =
type global_table_entry =
Empty
| Global of Ident.t
- | Constant of obj
+ | Constant of Obj.t
let start = ref 0 (* Position of beg. of code *)
let reloc = ref ([] : (reloc_info * int) list) (* Relocation table *)
@@ -277,7 +277,7 @@ let dump_exe ic =
let symbol_size = input_binary_int ic in
let debug_size = input_binary_int ic in
seek_in ic (trailer_pos - debug_size - symbol_size - data_size);
- let init_data = (input_value ic : obj array) in
+ let init_data = (input_value ic : Obj.t array) in
globals := Array.new (Array.length init_data) Empty;
for i = 0 to Array.length init_data - 1 do
!globals.(i) <- Constant (init_data.(i))
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 3b813b6ab..ef25c8315 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -8,6 +8,7 @@ open Typetexp
type error =
Repeated_parameter
| Duplicate_constructor of string
+ | Too_many_constructors
| Duplicate_label of string
| Recursive_abbrev of string
@@ -51,6 +52,8 @@ let transl_declaration env (name, sdecl) id =
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := Cset.add name !all_constrs)
cstrs;
+ if List.length cstrs > Config.max_tag then
+ raise(Error(sdecl.ptype_loc, Too_many_constructors));
Type_variant(List.map
(fun (name, args) ->
(name, List.map (transl_simple_type env true) args))
@@ -111,6 +114,9 @@ let report_error = function
print_string "A type parameter occurs several times"
| Duplicate_constructor s ->
print_string "Two constructors are named "; print_string s
+ | Too_many_constructors ->
+ print_string "Too many constructors -- maximum is ";
+ print_int Config.max_tag; print_string " constructors"
| Duplicate_label s ->
print_string "Two labels are named "; print_string s
| Recursive_abbrev s ->
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 840492505..2507e6fc8 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -11,6 +11,7 @@ val transl_exception:
type error =
Repeated_parameter
| Duplicate_constructor of string
+ | Too_many_constructors
| Duplicate_label of string
| Recursive_abbrev of string
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index ff44fd0fb..2390d9fbb 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -35,7 +35,7 @@ type constructor_description =
and constructor_tag =
Cstr_tag of int (* Regular constructor *)
- | Cstr_exception of Path.t (* Exception constructor *)
+ | Cstr_exception of Path.t (* Exception constructor *)
(* Record label descriptions *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 1c52b126f..976feb496 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -35,7 +35,7 @@ type constructor_description =
and constructor_tag =
Cstr_tag of int (* Regular constructor *)
- | Cstr_exception of Path.t (* Exception constructor *)
+ | Cstr_exception of Path.t (* Exception constructor *)
(* Record label descriptions *)
diff --git a/utils/config.mli b/utils/config.mli
index 05e6528fc..483de0b51 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -21,3 +21,6 @@ val cmo_magic_number: string
(* Magic number for object bytecode files *)
val cma_magic_number: string
(* Magic number for archive files *)
+
+val max_tag: int
+ (* Biggest tag that can be stored in the header of a block. *)
diff --git a/utils/config.mlp b/utils/config.mlp
index 5cee74284..59b2d050a 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -13,3 +13,4 @@ and cma_magic_number = "Caml1999A001"
let load_path = ref ([] : string list)
+let max_tag = 251
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-21 04:05:40 +0000