summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xboot/ocamlcbin1530049 -> 1531940 bytes
-rwxr-xr-xboot/ocamldepbin420724 -> 420724 bytes
-rwxr-xr-xboot/ocamllexbin184001 -> 184001 bytes
-rw-r--r--bytecomp/bytegen.ml4
-rw-r--r--bytecomp/matching.ml6
-rw-r--r--bytecomp/printlambda.ml3
-rw-r--r--bytecomp/translcore.ml17
-rw-r--r--toplevel/genprintval.ml18
-rw-r--r--typing/datarepr.ml6
-rw-r--r--typing/predef.ml1
-rw-r--r--typing/subst.ml1
-rw-r--r--typing/typecore.ml32
-rw-r--r--typing/typedecl.ml103
-rw-r--r--typing/types.ml4
-rw-r--r--typing/types.mli4
-rw-r--r--utils/config.mlp2
16 files changed, 141 insertions, 60 deletions
diff --git a/boot/ocamlc b/boot/ocamlc
index 39da4873d..84aad25de 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
Binary files differ
diff --git a/boot/ocamldep b/boot/ocamldep
index 2dab90bdd..f14b486eb 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
Binary files differ
diff --git a/boot/ocamllex b/boot/ocamllex
index 8143ae371..adcfea001 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
Binary files differ
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 3b25c3db3..d62210309 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -144,7 +144,7 @@ let rec size_of_lambda = function
| Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body)
when check_recordwith_updates id body ->
begin match kind with
- | Record_regular -> RHS_block size
+ | Record_regular _ -> RHS_block size
| Record_float -> RHS_floatblock size
end
| Llet(str, id, arg, body) -> size_of_lambda body
@@ -154,7 +154,7 @@ let rec size_of_lambda = function
RHS_block (List.length args)
| Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args)
| Lprim (Pmakearray Pgenarray, args) -> assert false
- | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size
+ | Lprim (Pduprecord (Record_regular _, size), args) -> RHS_block size
| Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda lam
| Lsequence (lam, lam') -> size_of_lambda lam'
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index e98148319..de160a8f0 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1315,7 +1315,9 @@ let make_constr_matching p def ctx = function
| ((arg, mut) :: argl) ->
let cstr = pat_as_constr p in
let newargs =
- match cstr.cstr_tag with
+ if cstr.cstr_inlined then
+ (arg, Alias) :: argl
+ else match cstr.cstr_tag with
Cstr_constant _ | Cstr_block _ ->
make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
| Cstr_exception _ ->
@@ -1595,7 +1597,7 @@ let make_record_matching all_labels def = function
let lbl = all_labels.(pos) in
let access =
match lbl.lbl_repres with
- Record_regular -> Pfield lbl.lbl_pos
+ Record_regular _ -> Pfield lbl.lbl_pos
| Record_float -> Pfloatfield lbl.lbl_pos in
let str =
match lbl.lbl_mut with
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index e02196f9b..d3d5a0916 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -83,7 +83,8 @@ let print_bigarray name unsafe kind ppf layout =
let record_rep ppf r =
match r with
- | Record_regular -> fprintf ppf "regular"
+ | Record_regular 0 -> fprintf ppf "regular"
+ | Record_regular i -> fprintf ppf "regular (tag %i)" i
| Record_float -> fprintf ppf "float"
;;
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 526c0f576..bded66023 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -728,7 +728,10 @@ and transl_exp0 e =
Cstr_constant n ->
Lconst(Const_pointer n)
| Cstr_block n ->
- begin try
+ if cstr.cstr_inlined then begin match ll with
+ | [x] -> x
+ | _ -> assert false
+ end else begin try
Lconst(Const_block(n, List.map extract_constant ll))
with Not_constant ->
Lprim(Pmakeblock(n, Immutable), ll)
@@ -758,13 +761,13 @@ and transl_exp0 e =
| Texp_field(arg, _, lbl) ->
let access =
match lbl.lbl_repres with
- Record_regular -> Pfield lbl.lbl_pos
+ Record_regular _ -> Pfield lbl.lbl_pos
| Record_float -> Pfloatfield lbl.lbl_pos in
Lprim(access, [transl_exp arg])
| Texp_setfield(arg, _, lbl, newval) ->
let access =
match lbl.lbl_repres with
- Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
+ Record_regular _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
| Record_float -> Psetfloatfield lbl.lbl_pos in
Lprim(access, [transl_exp arg; transl_exp newval])
| Texp_array expr_list ->
@@ -1063,7 +1066,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
for i = 0 to Array.length all_labels - 1 do
let access =
match all_labels.(i).lbl_repres with
- Record_regular -> Pfield i
+ Record_regular _ -> Pfield i
| Record_float -> Pfloatfield i in
lv.(i) <- Lprim(access, [Lvar init_id])
done
@@ -1081,12 +1084,12 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
if mut = Mutable then raise Not_constant;
let cl = List.map extract_constant ll in
match repres with
- Record_regular -> Lconst(Const_block(0, cl))
+ Record_regular tag -> Lconst(Const_block(tag, cl))
| Record_float ->
Lconst(Const_float_array(List.map extract_float cl))
with Not_constant ->
match repres with
- Record_regular -> Lprim(Pmakeblock(0, mut), ll)
+ Record_regular tag -> Lprim(Pmakeblock(tag, mut), ll)
| Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
begin match opt_init_expr with
None -> lam
@@ -1101,7 +1104,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
let update_field (_, lbl, expr) cont =
let upd =
match lbl.lbl_repres with
- Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
+ Record_regular _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
| Record_float -> Psetfloatfield lbl.lbl_pos in
Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
begin match opt_init_expr with
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 957be155e..58ed61bc3 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -248,7 +248,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
- let {cd_id;cd_args;cd_res} =
+ let {cd_id;cd_args;cd_res;cd_inlined} =
Datarepr.find_constr_by_tag tag constr_list in
let type_params =
match cd_res with
@@ -272,7 +272,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
Ctype.Cannot_apply -> abstract_type)
ty_args in
tree_of_constr_with_args (tree_of_constr env path)
- (Ident.name cd_id) 0 depth obj ty_args
+ (Ident.name cd_id) cd_inlined 0 depth obj
+ ty_args
| {type_kind = Type_record(lbl_list, rep)} ->
begin match check_depth depth obj ty with
Some x -> x
@@ -352,9 +353,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
tree_list start ty_list
and tree_of_constr_with_args
- tree_of_cstr cstr_name start depth obj ty_args =
+ tree_of_cstr cstr_name inlined start depth obj ty_args =
let lid = tree_of_cstr cstr_name in
- let args = tree_of_val_list start depth obj ty_args in
+ let args =
+ if inlined then
+ match ty_args with
+ | [ty] -> [ tree_of_val (depth - 1) obj ty ]
+ | _ -> assert false
+ else
+ tree_of_val_list start depth obj ty_args
+ in
Oval_constr (lid, args)
and tree_of_exception depth bucket =
@@ -383,7 +391,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
(* TODO? *)
in
tree_of_constr_with_args
- (fun x -> Oide_ident x) name 1 depth bucket ty_args
+ (fun x -> Oide_ident x) name false 1 depth bucket ty_args
with Not_found | EVP.Error ->
match check_depth depth bucket ty with
Some x -> x
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 66035625b..fe97c2bd4 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -21,7 +21,7 @@ let none = {desc = Ttuple []; level = -1; id = -1}
(* Clearly ill-formed type *)
let dummy_label =
{ lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
- lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
+ lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular 0;
lbl_private = Public;
lbl_loc = Location.none;
lbl_attributes = [];
@@ -83,7 +83,7 @@ let constructor_descrs ty_res cstrs priv =
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
- | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
+ | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_inlined} :: rem ->
let ty_res =
match cd_res with
| Some ty_res' -> ty_res'
@@ -124,6 +124,7 @@ let constructor_descrs ty_res cstrs priv =
cstr_generalized = cd_res <> None;
cstr_loc = cd_loc;
cstr_attributes = cd_attributes;
+ cstr_inlined = cd_inlined;
} in
(cd_id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
@@ -143,6 +144,7 @@ let exception_descr path_exc decl =
cstr_generalized = false;
cstr_loc = decl.exn_loc;
cstr_attributes = decl.exn_attributes;
+ cstr_inlined = false;
}
exception Constr_not_found
diff --git a/typing/predef.ml b/typing/predef.ml
index 55fe4b880..098356a8a 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -110,6 +110,7 @@ let cstr id args =
cd_res = None;
cd_loc = Location.none;
cd_attributes = [];
+ cd_inlined = false;
}
let ident_false = ident_create "false"
diff --git a/typing/subst.ml b/typing/subst.ml
index c1b97d9cc..a65d3936c 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -204,6 +204,7 @@ let constructor_declaration s c =
cd_res = may_map (typexp s) c.cd_res;
cd_loc = loc s c.cd_loc;
cd_attributes = attrs s c.cd_attributes;
+ cd_inlined = c.cd_inlined;
}
let type_declaration s decl =
diff --git a/typing/typecore.ml b/typing/typecore.ml
index fff085a8f..541b15bef 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -3272,34 +3272,10 @@ and type_construct env loc lid sarg ty_expected attrs =
end;
generalize_structure ty_res;
end;
- let sargs, ty_args =
+ let arg_env, sargs, ty_args =
match sargs, ty_args with
- | sargs, Cstr_tuple l -> sargs, l
- | [{pexp_desc = Pexp_record (fields, None)}], Cstr_record l ->
- (* TODO: check arity *)
- let l =
- List.map
- (fun {Types.ld_id; ld_type; _} ->
- let id = Ident.name ld_id in
- let (_, e) =
- try
- List.find
- (function
- | ({txt=Longident.Lident s}, _) when s = id -> true
- | _ -> false
- )
- fields
- with Not_found ->
- raise(Error(loc, env, Label_missing [Ident.create id]))
- in
- e, ld_type
- )
- l
- in
- List.split l
-
- | _, Cstr_record _ ->
- assert false (* TODO: error message *)
+ | sargs, Cstr_tuple l -> env, sargs, l
+ | _, Cstr_record _ -> assert false (* TODO: error message *)
in
let ty_args0, ty_res =
match instance_list env (ty_res :: ty_args) with
@@ -3308,7 +3284,7 @@ and type_construct env loc lid sarg ty_expected attrs =
in
let texp = {texp with exp_type = ty_res} in
if not separate then unify_exp env texp (instance env ty_expected);
- let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
+ let args = List.map2 (fun e (t,t0) -> type_argument arg_env e t t0) sargs
(List.combine ty_args ty_args0) in
if constr.cstr_private = Private then
raise(Error(loc, env, Private_type ty_res));
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 1304350db..1faf6c217 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -133,6 +133,12 @@ module StringSet =
let compare (x:t) y = compare x y
end)
+module StringMap =
+ Map.Make(struct
+ type t = string
+ let compare (x:t) y = compare x y
+ end)
+
let make_params sdecl =
try
List.map
@@ -144,6 +150,29 @@ let make_params sdecl =
with Already_bound loc ->
raise(Error(loc, Repeated_parameter))
+let freevars kind =
+ let open Ast_mapper in
+ let vars = ref StringMap.empty in
+ let bound = ref StringSet.empty in
+ let super = default_mapper in
+ let typ m ct =
+ match ct.ptyp_desc with
+ | Ptyp_var s ->
+ if not (StringSet.mem s !bound) then
+ vars := StringMap.add s ct.ptyp_loc !vars;
+ ct
+ | Ptyp_poly (sl, t) ->
+ let old_bound = !bound in
+ List.iter (fun s -> bound := StringSet.add s !bound) sl;
+ ignore (m.typ m t);
+ bound := old_bound;
+ ct
+ | _ -> super.typ m ct
+ in
+ let mapper = {super with typ} in
+ ignore (mapper.type_kind mapper kind);
+ StringMap.bindings !vars
+
let transl_labels env fixed lbls =
let all_labels = ref StringSet.empty in
List.iter
@@ -174,7 +203,7 @@ let transl_labels env fixed lbls =
lbls, lbls'
-let transl_declaration env sdecl id =
+let transl_declaration env tags inlined sdecl id =
(* Bind type parameters *)
reset_type_variables();
Ctype.begin_def ();
@@ -200,7 +229,7 @@ let transl_declaration env sdecl id =
(List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) cstrs)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
- let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
+ let make_cstr ({pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} as pcd) =
let name = Ident.create lid.txt in
let transl_args fixed =
match args with
@@ -236,25 +265,30 @@ let transl_declaration env sdecl id =
widen z;
args, Some cty, Some ret_type
in
- (name, lid, args, cty, ret_type, loc, attrs)
+ (name, lid, args, cty, ret_type, loc, attrs, List.memq pcd inlined)
in
let cstrs = List.map make_cstr cstrs in
- Ttype_variant (List.map (fun (name, lid, (targs, _), res, _, loc, attrs) ->
+ Ttype_variant (List.map (fun (name, lid, (targs, _), res, _, loc, attrs, _) ->
{cd_id = name; cd_name = lid; cd_args = targs; cd_res = res;
cd_loc = loc; cd_attributes = attrs}
) cstrs),
- Type_variant (List.map (fun (name, name_loc, (_, args), _, option, loc, attrs) ->
+ Type_variant (List.map (fun (name, name_loc, (_, args), _, option, loc, attrs, inlined) ->
{Types.cd_id = name; cd_args = args;
cd_res = option;
- cd_loc = loc; cd_attributes = attrs}
+ cd_loc = loc; cd_attributes = attrs;
+ cd_inlined = inlined;
+ }
) cstrs)
| Ptype_record lbls ->
let lbls, lbls' = transl_labels env true lbls in
let rep =
- if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
- then Record_float
- else Record_regular in
+ try
+ Record_regular (List.assq sdecl tags)
+ with Not_found ->
+ if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+ then Record_float
+ else Record_regular 0 in
Ttype_record lbls, Type_record(lbls', rep)
in
let (tman, man) = match sdecl.ptype_manifest with
@@ -940,6 +974,55 @@ let transl_type_decl env sdecl_list =
fixed_types
@ sdecl_list
in
+ (* Add fake record declarations for record constructor arguments *)
+ let extras = ref [] in
+ let inlined = ref [] in
+ let rewrite_case tag sdecl pcd =
+ match pcd.pcd_args with
+ | Pcstr_record lbls ->
+ let name = sdecl.ptype_name.txt ^ "#" ^ pcd.pcd_name.txt in
+ let ptype_kind = Ptype_record lbls in
+ let params = freevars ptype_kind in
+ let decl =
+ {
+ ptype_name = mkloc name pcd.pcd_name.loc;
+ ptype_params = List.map (fun (s, loc) -> Some (mkloc s loc), Invariant) params;
+ ptype_cstrs = sdecl.ptype_cstrs;
+ ptype_kind;
+ ptype_private = sdecl.ptype_private;
+ ptype_manifest = None;
+ ptype_attributes = [];
+ ptype_loc = pcd.pcd_loc;
+ } in
+ extras := (decl, !tag) :: !extras;
+ incr tag;
+ let params =
+ List.map (fun (s, loc) -> Ast_helper.Typ.var ~loc s) params
+ in
+ let lid = mknoloc (Longident.Lident name) in
+ let pcd_args = Pcstr_tuple [ Ast_helper.Typ.constr lid params ] in
+ let pcd = {pcd with pcd_args} in
+ inlined := pcd :: !inlined;
+ pcd
+ | Pcstr_tuple [] -> pcd
+ | Pcstr_tuple _ -> incr tag; pcd
+ in
+ let sdecl_list =
+ List.map
+ (fun sdecl ->
+ let ptype_kind =
+ match sdecl.ptype_kind with
+ | Ptype_variant cstrs ->
+ let cstrs = List.map (rewrite_case (ref 0) sdecl) cstrs in
+ Ptype_variant cstrs
+ | x -> x
+ in
+ {sdecl with ptype_kind}
+ )
+ sdecl_list
+ in
+ let sdecl_list = sdecl_list @ List.map fst !extras in
+
(* Create identifiers. *)
let id_list =
List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list
@@ -978,7 +1061,7 @@ let transl_type_decl env sdecl_list =
id, Some slot
in
let transl_declaration name_sdecl (id, slot) =
- current_slot := slot; transl_declaration temp_env name_sdecl id in
+ current_slot := slot; transl_declaration temp_env !extras !inlined name_sdecl id in
let tdecls =
List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
let decls =
diff --git a/typing/types.ml b/typing/types.ml
index 06b3df0ad..f63eeea5e 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -127,7 +127,7 @@ and label_description =
}
and record_representation =
- Record_regular (* All fields are boxed / tagged *)
+ Record_regular of int (* All fields are boxed / tagged *)
| Record_float (* All fields are floats *)
(* Constructor descriptions *)
@@ -146,6 +146,7 @@ type constructor_description =
cstr_private: private_flag; (* Read-only constructor? *)
cstr_loc: Location.t;
cstr_attributes: Parsetree.attributes;
+ cstr_inlined: bool;
}
and constructor_tag =
@@ -160,6 +161,7 @@ and constructor_declaration =
cd_res: type_expr option;
cd_loc: Location.t;
cd_attributes: Parsetree.attributes;
+ cd_inlined: bool;
}
and constructor_arguments =
diff --git a/typing/types.mli b/typing/types.mli
index 9b41395db..66a3b2224 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -125,7 +125,7 @@ and label_description =
}
and record_representation =
- Record_regular (* All fields are boxed / tagged *)
+ Record_regular of int (* All fields are boxed / tagged *)
| Record_float (* All fields are floats *)
(* Constructor descriptions *)
@@ -144,6 +144,7 @@ type constructor_description =
cstr_private: private_flag; (* Read-only constructor? *)
cstr_loc: Location.t;
cstr_attributes: Parsetree.attributes;
+ cstr_inlined: bool;
}
and constructor_tag =
@@ -158,6 +159,7 @@ and constructor_declaration =
cd_res: type_expr option;
cd_loc: Location.t;
cd_attributes: Parsetree.attributes;
+ cd_inlined: bool;
}
and constructor_arguments =
diff --git a/utils/config.mlp b/utils/config.mlp
index e16ef2998..867b19fc6 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -49,7 +49,7 @@ let mkexe = "%%MKEXE%%"
let mkmaindll = "%%MKMAINDLL%%"
let exec_magic_number = "Caml1999X010"
-and cmi_magic_number = "Caml1999I016"
+and cmi_magic_number = "Caml1999I017"
and cmo_magic_number = "Caml1999O008"
and cma_magic_number = "Caml1999A009"
and cmx_magic_number = "Caml1999Y012"
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-25 08:15:38 +0000