[m-rev.] for review: Fix codegen for subtype field names in high-level data grades.
Peter Wang
novalazy at gmail.com
Tue Apr 30 17:08:05 AEST 2024
Fix a bug where the compiler generated incorrect code in C# and Java
grades when a subtype type definition did not repeat the field names of
its base type. Subtypes use the same data represention with their base
type, so in target code we must use the names of fields from the
base type instead of the subtype.
compiler/hlds_data.m:
Add a field to ctor_arg_repn to tell if a constructor argument
belongs to a subtype, and if so, the field name of the corresponding
constructor argument in the base type (if any).
compiler/du_type_layout.m:
Fill in the field appropriately for the ctor_arg_repn of a subtype
constructor argument.
Conform to changes elsewhere.
compiler/ml_code_util.m:
Make ml_gen_hld_field_name use the field name from the base type
if generating the field name for a subtype constructor argument.
compiler/ml_type_gen.m:
Pass MaybeBaseTypeCtor to ml_gen_hld_field_name.
compiler/add_special_pred.m:
compiler/equiv_type_hlds.m:
compiler/hlds_out_type_table.m:
compiler/ml_unify_gen_deconstruct.m:
compiler/ml_unify_gen_util.m:
compiler/structure_reuse.direct.choose_reuse.m:
compiler/type_ctor_info.m:
Conform to changes.
compiler/mlds.m:
Add comment.
compiler/tag_switch_util.m:
Delete comment about the bug that this change fixes.
tests/hard_coded/Mmakefile:
tests/hard_coded/subtype_field_names.exp:
tests/hard_coded/subtype_field_names.m:
Add test case.
NEWS.md:
Announce change.
diff --git a/NEWS.md b/NEWS.md
index 2526d9c59..0a681d18f 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1220,6 +1220,10 @@ Changes to the Mercury language
Changes to the Mercury compiler
-------------------------------
+* We have fixed a bug where the compiler generated incorrect code in
+ C# and Java grades when a subtype type definition did not repeat the field
+ names of its base type.
+
* We have fixed a bug where `--warn-unused-imports` did not warn about
unused modules that are also imported by an ancestor of the current module.
diff --git a/compiler/add_special_pred.m b/compiler/add_special_pred.m
index d34c779ef..f7288dca2 100644
--- a/compiler/add_special_pred.m
+++ b/compiler/add_special_pred.m
@@ -542,7 +542,8 @@ make_tuple_args_and_repns_loop(Context, [ArgType | ArgTypes], ArgNum,
[CtorArg | CtorArgs], [CtorArgRepn | CtorArgRepns]) :-
CtorArg = ctor_arg(no, ArgType, Context),
ArgPosWidth = apw_full(arg_only_offset(ArgNum), cell_offset(ArgNum)),
- CtorArgRepn = ctor_arg_repn(no, ArgType, ArgPosWidth, Context),
+ CtorArgRepn = ctor_arg_repn(no, no_base_ctor_arg, ArgType, ArgPosWidth,
+ Context),
make_tuple_args_and_repns_loop(Context, ArgTypes, ArgNum + 1,
CtorArgs, CtorArgRepns).
diff --git a/compiler/du_type_layout.m b/compiler/du_type_layout.m
index 64d7adbc7..f6fb17d69 100644
--- a/compiler/du_type_layout.m
+++ b/compiler/du_type_layout.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1993-2012 The University of Melbourne.
-% Copyright (C) 2015, 2017-2023 The Mercury team.
+% Copyright (C) 2015, 2017-2024 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -725,6 +725,8 @@ check_and_record_du_notag(TypeCtor, Context, Ctors, MaybeCanon,
MaybeDuRepn = have_errors([Spec])
;
MaybeCanon = canon,
+ % We can only get here for a non-subtype du type.
+ MaybeBaseCtorArg = no_base_ctor_arg,
% XXX TYPE_REPN The apw_full is a *lie*
% if RepnArgType is a 64 bit float on a 32 bit platform.
% XXX TYPE_REPN Since the ArgPosWidth of the only argument
@@ -732,8 +734,8 @@ check_and_record_du_notag(TypeCtor, Context, Ctors, MaybeCanon,
% it would be practical to use a CtorArgRepn that does not have
% this field.
ArgPosWidth = apw_full(arg_only_offset(0), cell_offset(0)),
- CtorArgRepn = ctor_arg_repn(MaybeFieldName, RepnArgType,
- ArgPosWidth, ArgContext),
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg,
+ RepnArgType, ArgPosWidth, ArgContext),
CtorTag = no_tag,
CtorRepn = ctor_repn(Ordinal, no_exist_constraints, CtorSymName,
CtorTag, [CtorArgRepn], 1, CtorContext),
@@ -993,9 +995,12 @@ record_high_level_data_ctor_args(_, _, [], []).
record_high_level_data_ctor_args(CurAOWordNum, CurCellWordNum,
[CtorArg | CtorArgs], [CtorArgRepn | CtorArgRepns]) :-
CtorArg = ctor_arg(MaybeFieldName, ArgType, ArgContext),
+ % We can only get here for a non-subtype du type.
+ MaybeBaseCtorArg = no_base_ctor_arg,
ArgRepn = apw_full(arg_only_offset(CurAOWordNum),
cell_offset(CurCellWordNum)),
- CtorArgRepn = ctor_arg_repn(MaybeFieldName, ArgType, ArgRepn, ArgContext),
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg,
+ ArgType, ArgRepn, ArgContext),
record_high_level_data_ctor_args(CurAOWordNum + 1, CurCellWordNum + 1,
CtorArgs, CtorArgRepns).
@@ -1181,6 +1186,8 @@ record_local_ctor_args(ArgOnlyOffset, CellOffset, SeenNonDummyArg0,
ArgRepns = [HeadArgRepn | TailArgRepns]
then
HeadCtorArg = ctor_arg(MaybeFieldName, _ArgType, Context),
+ % We can only get here for a non-subtype du type.
+ MaybeBaseCtorArg = no_base_ctor_arg,
(
HeadArgRepn = local_partial(Shift, FillKindSize),
ArgShift = uint.cast_to_int(Shift),
@@ -1212,8 +1219,8 @@ record_local_ctor_args(ArgOnlyOffset, CellOffset, SeenNonDummyArg0,
),
SeenNonDummyArg = SeenNonDummyArg0
),
- HeadCtorArgRepn = ctor_arg_repn(MaybeFieldName, HeadRepnArgType,
- ArgPosWidth, Context),
+ HeadCtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg,
+ HeadRepnArgType, ArgPosWidth, Context),
record_local_ctor_args(ArgOnlyOffset, CellOffset, SeenNonDummyArg,
TailCtorArgs, TailRepnArgTypes, TailArgRepns, TailCtorArgRepns),
CtorArgRepns = [HeadCtorArgRepn | TailCtorArgRepns]
@@ -1252,12 +1259,14 @@ record_direct_arg_ctors([DirectArgCtor | DirectArgCtors], !CtorOrdRepnMap) :-
expect(unify(CtorArity, 1), $pred, "CtorArity != 1"),
CtorTag = direct_arg_tag(Ptag),
CtorArg = ctor_arg(MaybeFieldName, _Type, ArgContext),
+ % We can only get here when checking a non-subtype du type.
+ MaybeBaseCtorArg = no_base_ctor_arg,
% The CtorArgRepn, and therefore the ArgPosWidth, will never be used
% for direct_arg_tag functors. The CtorArgRepn we construct here is
% designed to be the same as what the decide_type_repns_old constructs.
ArgPosWidth = apw_full(arg_only_offset(0), cell_offset(0)),
- CtorArgRepn =
- ctor_arg_repn(MaybeFieldName, ArgType, ArgPosWidth, ArgContext),
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg, ArgType,
+ ArgPosWidth, ArgContext),
CtorRepn = ctor_repn(Ordinal, MaybeExistConstraints, CtorSymName, CtorTag,
[CtorArgRepn], CtorArity, CtorContext),
map.det_insert(Ordinal, CtorRepn, !CtorOrdRepnMap),
@@ -1345,8 +1354,8 @@ record_remote_ctor_args(CtorArgs, RepnArgTypes, ArgRepns, CtorArgRepns) :-
HeadArgRepn = remote_none_nowhere,
ArgPosWidth = apw_none_nowhere
),
- HeadCtorArgRepn = ctor_arg_repn(MaybeFieldName, HeadRepnArgType,
- ArgPosWidth, Context),
+ HeadCtorArgRepn = ctor_arg_repn(MaybeFieldName, no_base_ctor_arg,
+ HeadRepnArgType, ArgPosWidth, Context),
record_remote_ctor_args(TailCtorArgs, TailRepnArgTypes, TailArgRepns,
TailCtorArgRepns),
CtorArgRepns = [HeadCtorArgRepn | TailCtorArgRepns]
@@ -1952,17 +1961,19 @@ add_repn_to_foreign_enum_ctor(TypeCtor, ConsTagMap, Ctor, CtorRepn,
% All function symbols of a foreign enum type should have arity zero.
% If any have a nonzero arity, our caller will generate an error message,
% and won't proceed to code generation.
- ArgRepns = list.map(add_dummy_repn_to_ctor_arg, Args),
+ ArgRepns = list.map(add_dummy_repn_to_foreign_enum_ctor_arg, Args),
CtorRepn = ctor_repn(Ordinal, MaybeExistConstraints, SymName, ConsTag,
ArgRepns, Arity, Context),
insert_ctor_repn_into_map(CtorRepn, !CtorRepnMap).
-:- func add_dummy_repn_to_ctor_arg(constructor_arg) = constructor_arg_repn.
+:- func add_dummy_repn_to_foreign_enum_ctor_arg(constructor_arg) =
+ constructor_arg_repn.
-add_dummy_repn_to_ctor_arg(ConsArg) = ConsArgRepn :-
+add_dummy_repn_to_foreign_enum_ctor_arg(ConsArg) = ConsArgRepn :-
ConsArg = ctor_arg(MaybeFieldName, Type, Context),
DummyWidth = apw_full(arg_only_offset(-3), cell_offset(-3)),
- ConsArgRepn = ctor_arg_repn(MaybeFieldName, Type, DummyWidth, Context).
+ ConsArgRepn = ctor_arg_repn(MaybeFieldName, no_base_ctor_arg, Type,
+ DummyWidth, Context).
%---------------------%
@@ -2053,10 +2064,13 @@ decide_simple_type_notag(_ModuleInfo, Params, TypeCtor, TypeDefn0, BodyDu0,
SingleCtorTag = no_tag,
SingleArg = ctor_arg(MaybeSingleArgFieldName, SingleArgType,
SingleArgContext),
+ % The representation of subtypes is figured out later.
+ MaybeBaseCtorArg = no_base_ctor_arg,
% XXX TYPE_REPN The apw_full is a *lie*
% if the arg type is a 64 bit float on a 32 bit platform.
- SingleArgRepn = ctor_arg_repn(MaybeSingleArgFieldName, SingleArgType,
- apw_full(arg_only_offset(0), cell_offset(0)), SingleArgContext),
+ SingleArgPosWidth = apw_full(arg_only_offset(0), cell_offset(0)),
+ SingleArgRepn = ctor_arg_repn(MaybeSingleArgFieldName, MaybeBaseCtorArg,
+ SingleArgType, SingleArgPosWidth, SingleArgContext),
SingleCtorRepn = ctor_repn(0u32, no_exist_constraints,
SingleCtorSymName, SingleCtorTag, [SingleArgRepn], 1,
SingleCtorContext),
@@ -2888,7 +2902,9 @@ decide_complex_du_ctor_remote_args_loop(ModuleInfo, Params, ComponentTypeMap,
ArgRepns = WordArgRepns ++ TailArgRepns
;
ArgsPackables = [],
- Arg = ctor_arg(ArgName, ArgType, ArgContext),
+ Arg = ctor_arg(MaybeFieldName, ArgType, ArgContext),
+ % This predicate only deals with non-subtype du types.
+ MaybeBaseCtorArg = no_base_ctor_arg,
deref_eqv_types(ModuleInfo, ArgType, DerefArgType),
( if
DerefArgType = builtin_type(BuiltinType),
@@ -2918,7 +2934,8 @@ decide_complex_du_ctor_remote_args_loop(ModuleInfo, Params, ComponentTypeMap,
NextAOWordNum = CurAOWordNum + 1,
NextCellWordNum = CurCellWordNum + 1
),
- HeadArgRepn = ctor_arg_repn(ArgName, ArgType, ArgPosWidth, ArgContext),
+ HeadArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg, ArgType,
+ ArgPosWidth, ArgContext),
decide_complex_du_ctor_remote_args_loop(ModuleInfo, Params,
ComponentTypeMap, NextAOWordNum, NextCellWordNum,
Args, TailArgRepns),
@@ -3052,8 +3069,11 @@ decide_packed_arg_word_loop(TreatAsFirst, ArgOnlyOffset, CellOffset,
),
NextShift = CurShift
),
- Arg = ctor_arg(ArgName, ArgType, ArgContext),
- ArgRepn = ctor_arg_repn(ArgName, ArgType, ArgPosWidth, ArgContext).
+ Arg = ctor_arg(MaybeFieldName, ArgType, ArgContext),
+ % This predicate only deals with non-subtype du types.
+ MaybeBaseCtorArg = no_base_ctor_arg,
+ ArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg, ArgType,
+ ArgPosWidth, ArgContext).
%---------------------------------------------------------------------------%
@@ -3704,7 +3724,8 @@ make_subtype_type_repn(TypeCtor, OoMCtors, BaseRepn, Repn) :-
SingleFunctorName, _ConsTag, [SingleArgRepn], 1, _Context)
then
SingleArgRepn = ctor_arg_repn(MaybeSingleArgFieldName,
- SingleArgType, _SingleArgPosWidth, _SingleArgContext),
+ _MaybeBaseCtorArg, SingleArgType, _SingleArgPosWidth,
+ _SingleArgContext),
(
MaybeSingleArgFieldName = no,
MaybeSingleArgName = no
@@ -3781,9 +3802,12 @@ search_ctor_repn_by_unqual_name([CtorRepn | CtorRepns], UnqualName, Arity,
make_subtype_constructor_arg_repn(CtorArg, BaseCtorArgRepn, CtorArgRepn) :-
CtorArg = ctor_arg(MaybeFieldName, ArgType, Context),
- BaseCtorArgRepn = ctor_arg_repn(_MaybeBaseFieldName, _BaseArgType,
- ArgPosWidth, _BaseContext),
- CtorArgRepn = ctor_arg_repn(MaybeFieldName, ArgType, ArgPosWidth, Context).
+ BaseCtorArgRepn = ctor_arg_repn(MaybeBaseFieldName, BaseMaybeBaseCtorArg,
+ _BaseArgType, ArgPosWidth, _BaseContext),
+ expect(unify(BaseMaybeBaseCtorArg, no_base_ctor_arg), $pred,
+ "BaseMaybeBaseCtorArg != no_base_ctor_arg"),
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName,
+ base_ctor_arg(MaybeBaseFieldName), ArgType, ArgPosWidth, Context).
:- pred has_matching_constructor(list(constructor)::in, sym_name_arity::in)
is semidet.
@@ -4213,7 +4237,8 @@ inform_about_any_suboptimal_packing(Params, CtorSymName, CtorContext,
record_subword_args_and_count_their_words([], _, !SubWords, !NumWords).
record_subword_args_and_count_their_words([ArgRepn | ArgRepns], CurArgNum,
!SubWords, !NumWords) :-
- ArgRepn = ctor_arg_repn(MaybeFieldName, _Type, PosWidth, _Context),
+ ArgRepn = ctor_arg_repn(MaybeFieldName, _MaybeBaseCtorArg, _Type, PosWidth,
+ _Context),
(
( PosWidth = apw_full(_, _)
; PosWidth = apw_double(_, _, _)
@@ -4756,7 +4781,7 @@ show_decisions_for_ctor_args(Stream, ForDevelopers, TypeCtorStr, CtorStr,
io.format(Stream, " CTOR_ARG %s %s arg %d: ",
[s(TypeCtorStr), s(CtorStr), i(ArgNum)], !IO)
),
- CtorArgRepn = ctor_arg_repn(_, _, ArgPosWidth, _),
+ CtorArgRepn = ctor_arg_repn(_, _, _, ArgPosWidth, _),
(
ArgPosWidth = apw_full(_, CellOffset),
expect(unify(ArgsLocn, args_remote), $pred, "apw_full not remote"),
diff --git a/compiler/equiv_type_hlds.m b/compiler/equiv_type_hlds.m
index d1ee98aae..787bbdf02 100644
--- a/compiler/equiv_type_hlds.m
+++ b/compiler/equiv_type_hlds.m
@@ -280,7 +280,8 @@ replace_in_ctor_repn(TypeEqvMap, CtorRepn0, CtorRepn, !CtorNameToRepnMap,
replace_in_ctor_arg_repn(TypeEqvMap, CtorArgRepn0, CtorArgRepn,
!TVarSet, !EquivTypeInfo) :-
- CtorArgRepn0 = ctor_arg_repn(Name, Type0, Width, Context),
+ CtorArgRepn0 = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg,
+ Type0, Width, Context),
replace_in_type(TypeEqvMap, Type0, Type, Changed,
!TVarSet, !EquivTypeInfo),
(
@@ -288,7 +289,8 @@ replace_in_ctor_arg_repn(TypeEqvMap, CtorArgRepn0, CtorArgRepn,
CtorArgRepn = CtorArgRepn0
;
Changed = changed,
- CtorArgRepn = ctor_arg_repn(Name, Type, Width, Context)
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg,
+ Type, Width, Context)
).
%-----------------------------------------------------------------------------%
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index 4ba19cdf5..d53bd3362 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -982,11 +982,20 @@ set_type_defn_prev_errors(X, !Defn) :-
:- type constructor_arg_repn
---> ctor_arg_repn(
car_field_name :: maybe(ctor_field_name),
+ % car_maybe_base_arg says whether this constructor argument
+ % belongs to a subtype. If so, it must have a corresponding
+ % constructor argument in the base type, which may or may not
+ % have a field name.
+ car_maybe_base_arg :: maybe_base_ctor_arg,
car_type :: mer_type,
car_pos_width :: arg_pos_width,
car_context :: prog_context
).
+:- type maybe_base_ctor_arg
+ ---> no_base_ctor_arg
+ ; base_ctor_arg(maybe(ctor_field_name)).
+
:- type du_type_kind
---> du_type_kind_mercury_enum
; du_type_kind_foreign_enum(
diff --git a/compiler/hlds_out_type_table.m b/compiler/hlds_out_type_table.m
index 6162bb8d9..acfca01e7 100644
--- a/compiler/hlds_out_type_table.m
+++ b/compiler/hlds_out_type_table.m
@@ -590,7 +590,8 @@ format_ctor_args(TVarSet, IndentStr, AnyFieldName,
format_ctor_arg_repns(TVarSet, IndentStr, AnyFieldName,
CurArgNum, HeadArgRepn, TailArgRepns, !State) :-
- HeadArgRepn = ctor_arg_repn(MaybeFieldName, Type, ArgPosWidth, _Context),
+ HeadArgRepn = ctor_arg_repn(MaybeFieldName, _MaybeBaseCtorArg, Type,
+ ArgPosWidth, _Context),
string.builder.append_string(IndentStr, !State),
(
AnyFieldName = no
@@ -639,7 +640,7 @@ does_any_arg_have_a_field_name([Arg | Args]) = SomeArgHasFieldName :-
does_any_arg_repn_have_a_field_name([]) = no.
does_any_arg_repn_have_a_field_name([ArgRepn | ArgRepns])
= SomeArgHasFieldName :-
- ArgRepn = ctor_arg_repn(MaybeFieldName, _, _, _),
+ ArgRepn = ctor_arg_repn(MaybeFieldName, _, _, _, _),
(
MaybeFieldName = yes(_),
SomeArgHasFieldName = yes
diff --git a/compiler/ml_code_util.m b/compiler/ml_code_util.m
index 766854c38..83c705fec 100644
--- a/compiler/ml_code_util.m
+++ b/compiler/ml_code_util.m
@@ -235,14 +235,21 @@
%
% Routines for dealing with fields.
%
-
- % Given the user-specified field name, if any, and the argument number
- % (starting from one), generate an MLDS field name for the target language
- % type that represents the function symbol's cell when we are generating
- % code with --high-level-data.
+ % ml_gen_hld_field_name(MaybeFieldName, MaybeBaseCtorArg, ArgNum) =
+ % FieldName:
%
-:- func ml_gen_hld_field_name(maybe(ctor_field_name), int) =
- mlds_field_var_name.
+ % Generate an MLDS field name for the target language type that represents
+ % the function symbol's cell when we are generating code with
+ % --high-level-data.
+ %
+ % MaybeFieldName is the user-specified field name (if any).
+ % MaybeBaseCtorArg tells if this is a field in a subtype, and if so,
+ % the field name of the corresponding constructor argument in the base type
+ % (if any).
+ % ArgNum is the argument number (starting from one).
+ %
+:- func ml_gen_hld_field_name(maybe(ctor_field_name), maybe_base_ctor_arg, int)
+ = mlds_field_var_name.
% Succeed iff the specified type must be boxed when used as a field.
% XXX Currently we box such types even for the other MLDS based back-ends
@@ -958,15 +965,27 @@ ml_gen_public_field_decl_flags =
% Code for dealing with fields.
%
-ml_gen_hld_field_name(MaybeFieldName, ArgNum) = FieldVarName :-
- % If the programmer specified a field name, we use that,
- % otherwise we just use `F' followed by the field number.
+ml_gen_hld_field_name(MaybeFieldName, MaybeBaseCtorArg, ArgNum) =
+ FieldVarName :-
+ % Subtypes share the data representation with their base types.
+ % If this is the field of a subtype, we must translate the reference to the
+ % corresponding constructor arg in the base type (which may or may not
+ % have a field name).
(
- MaybeFieldName = yes(ctor_field_name(QualifiedFieldName,
+ MaybeBaseCtorArg = no_base_ctor_arg,
+ FieldNameToUse = MaybeFieldName
+ ;
+ MaybeBaseCtorArg = base_ctor_arg(MaybeBaseFieldName),
+ FieldNameToUse = MaybeBaseFieldName
+ ),
+ % Use the field name if we have one, otherwise we just use `F' followed by
+ % the field number.
+ (
+ FieldNameToUse = yes(ctor_field_name(QualifiedFieldName,
_FieldNameCtxt)),
FieldName = unqualify_name(QualifiedFieldName)
;
- MaybeFieldName = no,
+ FieldNameToUse = no,
FieldName = "F" ++ string.int_to_string(ArgNum)
),
FieldVarName = fvn_du_ctor_field_hld(FieldName).
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index 3f8b056de..809aa19be 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -844,7 +844,7 @@ ml_gen_hld_du_ctor_typeclass_info_field(ModuleInfo, Context, _Constraint,
Defn, FieldInfo, !ArgNum) :-
Type = typeclass_info_type,
ml_gen_hld_du_ctor_field_gen(ModuleInfo, Context, !.ArgNum,
- no, Type, aw_full_word, Defn, FieldInfo),
+ no, no_base_ctor_arg, Type, aw_full_word, Defn, FieldInfo),
!:ArgNum = !.ArgNum + 1.
:- pred ml_gen_hld_du_ctor_type_info_field(module_info::in,
@@ -858,7 +858,7 @@ ml_gen_hld_du_ctor_type_info_field(ModuleInfo, Context, TypeVar,
% and won't be used in any other way.
Type = build_type_info_type(type_variable(TypeVar, kind_star)),
ml_gen_hld_du_ctor_field_gen(ModuleInfo, Context, !.ArgNum,
- no, Type, aw_full_word, Defn, FieldInfo),
+ no, no_base_ctor_arg, Type, aw_full_word, Defn, FieldInfo),
!:ArgNum = !.ArgNum + 1.
:- pred ml_gen_hld_du_ctor_field(module_info::in, prog_context::in,
@@ -867,21 +867,24 @@ ml_gen_hld_du_ctor_type_info_field(ModuleInfo, Context, TypeVar,
ml_gen_hld_du_ctor_field(ModuleInfo, Context, ArgRepn, Defn, FieldInfo,
!ArgNum) :-
- ArgRepn = ctor_arg_repn(MaybeFieldName, Type, PosWidth, _Context),
+ ArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg, Type, PosWidth,
+ _Context),
Width = arg_pos_width_to_width_only(PosWidth),
ml_gen_hld_du_ctor_field_gen(ModuleInfo, Context, !.ArgNum,
- MaybeFieldName, Type, Width, Defn, FieldInfo),
+ MaybeFieldName, MaybeBaseCtorArg, Type, Width, Defn, FieldInfo),
!:ArgNum = !.ArgNum + 1.
%---------------------%
:- pred ml_gen_hld_du_ctor_field_gen(module_info::in, prog_context::in,
- int::in, maybe(ctor_field_name)::in, mer_type::in, arg_width::in,
- mlds_field_var_defn::out, mlds_field_info::out) is det.
+ int::in, maybe(ctor_field_name)::in, maybe_base_ctor_arg::in, mer_type::in,
+ arg_width::in, mlds_field_var_defn::out, mlds_field_info::out) is det.
ml_gen_hld_du_ctor_field_gen(ModuleInfo, Context, ArgNum,
- MaybeFieldName, Type, Width, FieldVarDefn, FieldInfo) :-
- FieldVarName = ml_gen_hld_field_name(MaybeFieldName, ArgNum),
+ MaybeFieldName, MaybeBaseCtorArg, Type, Width, FieldVarDefn,
+ FieldInfo) :-
+ FieldVarName = ml_gen_hld_field_name(MaybeFieldName, MaybeBaseCtorArg,
+ ArgNum),
DeclFlags = ml_gen_public_field_decl_flags,
( if ml_must_box_field_type(ModuleInfo, Type, Width) then
MLDS_Type = mlds_generic_type
diff --git a/compiler/ml_unify_gen_deconstruct.m b/compiler/ml_unify_gen_deconstruct.m
index 044535dce..d3bafe5d6 100644
--- a/compiler/ml_unify_gen_deconstruct.m
+++ b/compiler/ml_unify_gen_deconstruct.m
@@ -654,8 +654,9 @@ ml_gen_dynamic_deconstruct_arg(FieldGen, ArgVar, CtorArgRepn, ArgMode,
FieldId = ml_field_offset(ml_const(mlconst_int(CellOffsetInt)))
;
FieldVia = field_via_name(FieldQualifier, ClassPtrType),
- MaybeFieldName = CtorArgRepn ^ car_field_name,
- FieldName = ml_gen_hld_field_name(MaybeFieldName, ArgNum),
+ CtorArgRepn = ctor_arg_repn(MaybeFieldName, MaybeBaseCtorArg, _, _, _),
+ FieldName = ml_gen_hld_field_name(MaybeFieldName, MaybeBaseCtorArg,
+ ArgNum),
QualifiedFieldName =
qual_field_var_name(FieldQualifier, type_qual, FieldName),
FieldId = ml_field_named(QualifiedFieldName, ClassPtrType)
diff --git a/compiler/ml_unify_gen_util.m b/compiler/ml_unify_gen_util.m
index a46b1435d..3dc626682 100644
--- a/compiler/ml_unify_gen_util.m
+++ b/compiler/ml_unify_gen_util.m
@@ -319,7 +319,8 @@ allocate_consecutive_full_word_ctor_arg_repns_boxed(CurOffset,
[Var | Vars], [VarArgRepn | VarArgRepns]) :-
Type = ml_make_boxed_type,
ArgPosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
- ArgRepn = ctor_arg_repn(no, Type, ArgPosWidth, dummy_context),
+ ArgRepn = ctor_arg_repn(no, no_base_ctor_arg, Type, ArgPosWidth,
+ dummy_context),
VarArgRepn = Var - ArgRepn,
allocate_consecutive_full_word_ctor_arg_repns_boxed(CurOffset + 1,
Vars, VarArgRepns).
@@ -333,7 +334,8 @@ allocate_consecutive_full_word_ctor_arg_repns_lookup(Info, CurOffset,
[Var | Vars], [VarArgRepn | VarArgRepns]) :-
ml_variable_type_direct(Info, Var, Type),
ArgPosWidth = apw_full(arg_only_offset(CurOffset), cell_offset(CurOffset)),
- ArgRepn = ctor_arg_repn(no, Type, ArgPosWidth, dummy_context),
+ ArgRepn = ctor_arg_repn(no, no_base_ctor_arg, Type, ArgPosWidth,
+ dummy_context),
VarArgRepn = Var - ArgRepn,
allocate_consecutive_full_word_ctor_arg_repns_lookup(Info, CurOffset + 1,
Vars, VarArgRepns).
diff --git a/compiler/mlds.m b/compiler/mlds.m
index abb799a84..bf7d1da44 100644
--- a/compiler/mlds.m
+++ b/compiler/mlds.m
@@ -2340,7 +2340,8 @@
% When compiling with --high-level-data, we generate a type
% in the target language for each data constructor in a
% discriminated union type. This is the name of one of the fields
- % of this type.
+ % of this type. For a subtype, this has to be the name of a field
+ % in the base type.
% NOTE: See the XXX on the code that turns these variables
% into strings.
diff --git a/compiler/structure_reuse.direct.choose_reuse.m b/compiler/structure_reuse.direct.choose_reuse.m
index 72a755644..a23dc30af 100644
--- a/compiler/structure_reuse.direct.choose_reuse.m
+++ b/compiler/structure_reuse.direct.choose_reuse.m
@@ -1034,7 +1034,7 @@ cons_has_normal_fields(ModuleInfo, ConsId) :-
all [ArgRepn] (
list.member(ArgRepn, ConsArgRepns)
=>
- ArgRepn = ctor_arg_repn(_, _, apw_full(_, _), _)
+ ArgRepn = ctor_arg_repn(_, _, _, apw_full(_, _), _)
)
;
ConsId = tuple_cons(_)
diff --git a/compiler/tag_switch_util.m b/compiler/tag_switch_util.m
index be7b5a6c2..7b8bab2ad 100644
--- a/compiler/tag_switch_util.m
+++ b/compiler/tag_switch_util.m
@@ -203,11 +203,6 @@
:- type whole_ptag_info(CaseRep) =< whole_ptags_info(CaseRep)
---> whole_ptags_info(
- % XXX The field names here duplicate the field names
- % in the supertype. When targeting Java or C#, which use
- % the high level data representation, these field names
- % (which are otherwise unnecessary) are needed to avoid
- % the generation of incorrect code.
wpi_head_ptag :: ptag,
wpi_tail_ptags :: empty_ptag_list,
wpi_num_functors :: uint,
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index 9dae1a689..b0a1eb9f6 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2012 The University of Melbourne.
-% Copyright (C) 2014-2021 The Mercury team.
+% Copyright (C) 2014-2021, 2024 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -407,9 +407,9 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
LayoutIndexable = IndexableByEnumValue
;
DuTypeKind = du_type_kind_notag(FunctorName, ArgType,
- MaybeArgName),
+ MaybeArgFieldName),
make_notag_details(ModuleInfo, TypeArity, MaybeSuperType,
- FunctorName, ArgType, MaybeArgName, EqualityAxioms,
+ FunctorName, ArgType, MaybeArgFieldName, EqualityAxioms,
Details),
LayoutIndexable = no
;
@@ -900,7 +900,8 @@ get_du_rep(ConsTag, DuRep) :-
generate_du_arg_info(NumUnivTVars, ExistTVars, ConsArgRepn, ArgInfo,
!FunctorSubtypeInfo) :-
- ConsArgRepn = ctor_arg_repn(MaybeCtorFieldName, ArgType, ArgWidth, _Ctxt),
+ ConsArgRepn = ctor_arg_repn(MaybeCtorFieldName, _MaybeBaseCtorArg,
+ ArgType, ArgWidth, _Ctxt),
(
MaybeCtorFieldName = yes(ctor_field_name(SymName, _)),
ArgName = unqualify_name(SymName),
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index ca4a7bfdc..1fcd2f52c 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -429,6 +429,7 @@ ORDINARY_PROGS = \
string_well_formed \
string_well_formed_utf8 \
subtype_abstract \
+ subtype_field_names \
subtype_order \
subtype_pack \
subtype_rtti \
diff --git a/tests/hard_coded/subtype_field_names.exp b/tests/hard_coded/subtype_field_names.exp
new file mode 100644
index 000000000..73b2f1641
--- /dev/null
+++ b/tests/hard_coded/subtype_field_names.exp
@@ -0,0 +1,2 @@
+foo(111, lemon, "str")
+foo(222, lemon, "str")
diff --git a/tests/hard_coded/subtype_field_names.m b/tests/hard_coded/subtype_field_names.m
new file mode 100644
index 000000000..48c654784
--- /dev/null
+++ b/tests/hard_coded/subtype_field_names.m
@@ -0,0 +1,74 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_field_names.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module int.
+
+:- type fruit
+ ---> apple
+ ; banana
+ ; lemon
+ ; orange.
+
+:- type citrus =< fruit
+ ---> lemon
+ ; orange.
+
+:- type foo(T)
+ ---> foo(
+ field_a :: int,
+ field_b :: fruit,
+ T % no field name in base type but present in subtype
+ ).
+
+ % This subtype has field names that differ from the base type.
+:- type sub_foo1(T) =< foo(T)
+ ---> foo(
+ sub_field1 :: int,
+ citrus, % no field name in subtype but present in base type
+ sub_field3 :: T
+ ).
+
+ % This subtype repeats some field names from the base type, but referring
+ % to different arguments (obviously a bad idea).
+ %
+:- type sub_foo2(T) =< foo(T)
+ ---> foo(
+ field_b :: int,
+ field_c :: citrus,
+ field_a :: T
+ ).
+
+:- pred test_sub_foo1(citrus::in, sub_foo1(T)::in, sub_foo1(T)::out) is det.
+:- pragma no_inline(pred(test_sub_foo1/3)).
+
+test_sub_foo1(B, Foo0, Foo) :-
+ Foo0 = foo(A, _, C),
+ Foo = foo(A, B, C).
+
+:- pred test_sub_foo2(citrus::in, sub_foo2(T)::in, sub_foo2(T)::out) is det.
+:- pragma no_inline(pred(test_sub_foo2/3)).
+
+test_sub_foo2(Fruit, Foo0, Foo) :-
+ Foo = Foo0 ^ field_c := Fruit.
+
+main(!IO) :-
+ F0 = foo(111, orange, "str"),
+ test_sub_foo1(lemon, F0, F),
+ io.print_line(F, !IO),
+
+ G0 = foo(222, orange, "str"),
+ test_sub_foo2(lemon, G0, G),
+ io.print_line(G, !IO).
--
2.44.0
More information about the reviews
mailing list