[m-rev.] for review: Make subtypes share low-level data representation with base type.
Peter Wang
novalazy at gmail.com
Thu Mar 25 13:59:08 AEDT 2021
Make subtypes share data representation with base type when using
low-level data. High-level data grades are unchanged, so subtypes
are still represented with distinct classes from their base types.
----------------
compiler/prog_data.m:
Add abstract_subtype option for type_details_abstract.
Correct XXX comment.
compiler/prog_item.m:
Add type item_type_repn_info_subtype.
Add tcrepn_is_subtype_of option for type_ctor_repn_info.
compiler/equiv_type.m:
Replace equivalences in tcrepn_is_subtype_of.
compiler/module_qual.qualify_items.m:
Module qualify in tcrepn_is_subtype_of.
compiler/prog_type.m:
Rename some predicates that can only work on non-subtype du types.
Update comments.
compiler/check_parse_tree_type_defns.m:
Classify subtype type definitions as std_mer_type_du_subtype
instead of std_mer_type_du_all_plain_constants or
std_mer_type_du_not_all_plain_constants.
Update some comments.
compiler/du_type_layout.m:
Add two sub-passes to handle subtypes.
compiler/comp_unit_interface.m:
Extend this module to handle subtype type definitions,
analogous to the way equivalence type definitions are handled.
Rename some predicates to clarify that they must not be used
to test subtypes.
Record an abstract version of a subtype type definition using
the abstract_subtype option in type_details_abstract.
This allows the super type ctor of the subtype to be known,
and hence the base type ctor, when a subtype is abstract exported.
Update comments.
compiler/decide_type_repn.m:
Extend this module to handle subtype type definitions.
Generate type_representation items for subtype type definitions
which include the super type ctor of the subtype.
compiler/parse_tree_out.m:
Write out abstract_subtype as
"where type_is_abstract_subtype(Name/Arity)" on type definitions.
compiler/parse_type_defn.m:
Parse "type_is_abstract_subtype(Name/Arity)" declarations.
compiler/parse_tree_out_type_repn.m:
Write type_representation items with "is_subtype_of(TypeCtor/Arity)".
compiler/parse_type_repn.m:
Parse "is_subtype_of(TypeCtor/Arity)" in type_representation items.
compiler/add_type.m:
compiler/convert_parse_tree.m:
compiler/opt_debug.m:
compiler/type_util.m:
Conform to changes.
Update comments.
compiler/direct_arg_in_out.m:
Delete XXX, nothing to do.
compiler/parse_util.m:
Rename overly specific variable.
----------------
runtime/mercury_type_info.h:
Add a flag in MR_TypeCtorInfo to indicate if the enum/du layout
array may be indexed by an enum value or du ptag value.
Subtypes break the invariant that the layout array contains entries
for every enum/ptag value from 0 up to the maximum value.
The presence of the flag MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE tells
the runtime that it can directly index the layout array instead of
searching through it (which is the common case, for non-subtypes).
Add a field MR_du_ptag to MR_DuPtagLayout. This is necessary to find
an entry for a given primary tag value in a MR_DuPtagLayout array.
Add a field MR_du_ptag_flags to MR_DuPtagLayout, currently with one
possible flag MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE.
As with primary tags, subtypes break the invariant that the
sectag_alternatives array contains entries for every secondary tag
value from 0 up to the maximum value. The presence of the flag tells
the runtime that it can directly index the sectag_alternatives array
(which is the common case, for non-subtypes).
The two fields added to MR_DuPtagLayout occupy space that was
previously padding, so the size of MR_DuPtagLayout is unchanged.
In MR_EnumFunctorDesc, replace the MR_enum_functor_ordinal field by
MR_enum_functor_value, i.e. the integer value representing the
functor in memory. Storing *both* the functor ordinal and enum value
would increase the size of the MR_EnumFunctorDesc struct, and would
be redundant in the common case of non-subtype enums (both fields
would contain equal values). We forgo having the functor ordinal
directly available, at the cost of needing to search through an
MR_EnumFunctorDesc array when a functor ordinal is required for a
subtype enum, which should be rare.
compiler/rtti.m:
Swap enum "functor ordinal" and "value" in places.
Use a type 'enum_value' to try to ensure we do not mix up enum
functor ordinals and enum values.
Add code to encode the MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE flag.
Add code to encode the MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE
flag.
compiler/rtti_out.m:
Write out "enum_ordinal_ordered_tables" ordered by functor ordinals
instead of "enum_value_ordered_tables" ordered by enum values.
Output the enum value for MR_EnumFunctorDesc instead of functor
ordinal.
Output the MR_du_ptag and MR_du_ptag_flags fields for
MR_DuPtagLayout.
Relax sanity check on primary tags. A subtype may not necessarily
use ptag 0, and may skip ptag values.
compiler/rtti_to_mlds.m:
Generate "enum_ordinal_ordered_tables" instead of
"enum_value_ordered_tables".
Fill in the enum value for a MR_EnumFunctorDesc instead of
the functor ordinal.
compiler/type_ctor_info.m:
Add predicate to generate the MR_du_ptag_flags field.
Add the MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE flag to type_ctor_infos
when appropriate.
Bump the type_ctor_info_rtti_version.
----------------
runtime/mercury_ml_expand_body.h:
Search through an enum layout array to find the matching enum value,
unless the array can be indexed.
Search through a ptag layout array to find the matching ptag value,
unless the array can be indexed.
Search through a sectag_alternatives array to find the matching
secondary tag value, unless the array can be indexed.
Factor out the code to search through a foreign enum layout array
into a separate macro.
runtime/mercury_construct.c:
runtime/mercury_construct.h:
Add a functor_ordinal field to the MR_Construct_Info_Struct.
This will hold the functor ordinal now that it is not available in
MR_EnumFunctorDesc.
Make MR_get_functors_check_range take an argument to indicate if the
functor_ordinal field needs to be filled in properly. Most callers
do not need the field.
library/construct.m:
Conform to changes to MR_get_functors_check_range and
MR_EnumFunctorDesc.
-------------------
runtime/mercury_dotnet.cs.in:
Modify RTTI classes for C# backend, analogous to the changes for the
C runtime.
Add methods to index/search through enum layout arrays, ptag layout
arrays, and sectag_alternatives arrays.
java/runtime/DuPtagLayout.java:
java/runtime/EnumFunctorDesc.java:
java/runtime/TypeCtorInfo_Struct.java:
Modify RTTI classes for Java backend, analogous to the changes for the
C runtime.
Add methods to index/search through enum layout arrays, ptag layout
arrays, and sectag_alternatives arrays.
library/rtti_implementation.m:
Conform to MR_EnumFunctorDesc field change.
Index or search through the enum layout array or ptag layout array
based on the MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE flag.
Index or search through the sectag_alternatives array depending on
the MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE flag.
Add separator lines.
Slightly reorder some code.
----------------
tests/hard_coded/Mercury.options:
tests/hard_coded/Mmakefile:
tests/hard_coded/subtype_pack.m:
tests/hard_coded/subtype_pack_2.m:
tests/hard_coded/subtype_pack.exp:
tests/hard_coded/subtype_rtti.m:
tests/hard_coded/subtype_rtti.exp:
tests/hard_coded/subtype_rtti.exp2:
Add test cases.
diff --git a/compiler/add_type.m b/compiler/add_type.m
index bffa3a76a..bbc1ef6f8 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -642,11 +642,17 @@ check_for_dummy_type_with_unify_compare(TypeStatus, TypeCtor, DetailsDu,
% zero-arity constructor are dummy types. Dummy types are not allowed
% to have user-defined equality or comparison.
- % XXX SUBTYPE Do not consider a subtype to be a dummy type
- % unless the base type is a dummy type.
-
- DetailsDu = type_details_du(_MaybeSuperType, Ctors, MaybeCanonical,
+ DetailsDu = type_details_du(MaybeSuperType, Ctors, MaybeCanonical,
_MaybeDirectArg),
+ (
+ MaybeSuperType = no
+ ;
+ MaybeSuperType = yes(_)
+ % XXX SUBTYPE A subtype with a single zero-arity constructor
+ % is not necessarily a dummy type, so this check will incorrectly
+ % prevent such a subtype from having user-defined equality or
+ % comparison (however unlikely that would be).
+ ),
Ctors = one_or_more(Ctor, []),
Ctor ^ cons_args = [],
MaybeCanonical = noncanon(_),
@@ -812,6 +818,7 @@ get_body_is_solver_type(Body, IsSolverType) :-
; Details = abstract_dummy_type
; Details = abstract_notag_type
; Details = abstract_type_fits_in_n_bits(_)
+ ; Details = abstract_subtype(_)
),
IsSolverType = non_solver_type
)
diff --git a/compiler/check_parse_tree_type_defns.m b/compiler/check_parse_tree_type_defns.m
index 38e5e2c16..33cc4638b 100644
--- a/compiler/check_parse_tree_type_defns.m
+++ b/compiler/check_parse_tree_type_defns.m
@@ -2,6 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2011 The University of Melbourne.
+% Copyright (C) 2019-2021 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.
%-----------------------------------------------------------------------------%
@@ -40,7 +41,7 @@
%
% Given the type and foreign enum definitions in both the interface
% and implementation sections of a module, and the type constructors
- % are is defined in that module, check for each type constructors
+ % that are defined in that module, check for each type constructor
% whether the definitions of that type constructor are consistent
% with one another.
%
@@ -115,19 +116,25 @@
% The equivalence type definition.
item_type_defn_info_eqv
)
+ ; std_mer_type_du_subtype(
+ std_du_type_status,
+
+ % The discriminated union type definition, which is a subtype.
+ item_type_defn_info_du
+ )
; std_mer_type_du_all_plain_constants(
std_du_type_status,
- % The discriminated union type definition, which represents
- % either a direct dummy type or an enum.
+ % The discriminated union type definition (not a subtype),
+ % which represents either a direct dummy type or an enum.
item_type_defn_info_du,
% The first functor name in the type, and any later functor
% names. If there are no later functor names, then the type
% is a direct dummy type, and must satisfy the requirements
- % of du_type_is_dummy; if there are, then the type is an
+ % of non_sub_du_type_is_dummy; if there are, then the type is an
% enum type, and must satisfy the requirements of
- % du_type_is_enum. (Function symbols that do not meet
+ % non_sub_du_type_is_enum. (Function symbols that do not meet
% the relevant requirements may be constants but we
% don't consider them *plain* constants.)
string,
@@ -146,8 +153,9 @@
; std_mer_type_du_not_all_plain_constants(
std_du_type_status,
- % The discriminated union type definition, which represents
- % a type *other* than a direct dummy type or an enum.
+ % The discriminated union type definition (not a subtype),
+ % which represents a type *other* than a direct dummy type or
+ % an enum.
item_type_defn_info_du,
% For each of our target foreign languages, this field
@@ -158,7 +166,7 @@
; std_mer_type_abstract(
std_abs_type_status,
- % The abstract declaration of the type.
+ % The abstract declaration of the type (not a subtype).
item_type_defn_info_abstract,
% For each of our target foreign languages, this field
@@ -179,8 +187,8 @@
---> std_du_type_mer_ft_exported
% Both the Mercury and any foreign type definitions are exported.
% Any foreign enum definitions are private, as they have to be.
- % This status is not applicable to equivalence types, since they
- % may not have foreign type definitions.
+ % This status is not applicable to equivalence types or subtypes,
+ % since they may not have foreign type definitions.
; std_du_type_mer_exported
% The Mercury definition is exported. Any foreign type definitions
% and/or foreign enum definitions are private.
@@ -531,23 +539,26 @@ check_type_ctor_defns(InsistOnDefn, ModuleName,
% we will have to disable users' ability to specify MaybeDirectArgs
% in source code.
DetailsDu = DuDefn ^ td_ctor_defn,
- DetailsDu = type_details_du(_MaybeSuperType, OoMCtors, _MaybeCanonical,
+ DetailsDu = type_details_du(MaybeSuperType, OoMCtors, _MaybeCanonical,
_MaybeDirectArgs),
OoMCtors = one_or_more(HeadCtor, TailCtors),
+ (
+ MaybeSuperType = no,
( if
ctor_is_constant(HeadCtor, HeadName0),
ctors_are_all_constants(TailCtors, TailNames0)
then
(
TailNames0 = [],
- ( if du_type_is_dummy(DetailsDu) then
- MaybeOnlyConstants = only_plain_constants(HeadName0, [])
+ ( if non_sub_du_type_is_dummy(DetailsDu) then
+ MaybeOnlyConstants =
+ only_plain_constants(HeadName0, [])
else
MaybeOnlyConstants = not_only_plain_constants
)
;
TailNames0 = [_ | _],
- ( if du_type_is_enum(DetailsDu, _NumFunctors) then
+ ( if non_sub_du_type_is_enum(DetailsDu, _NumFunctors) then
MaybeOnlyConstants =
only_plain_constants(HeadName0, TailNames0)
else
@@ -559,10 +570,12 @@ check_type_ctor_defns(InsistOnDefn, ModuleName,
),
(
MaybeOnlyConstants = not_only_plain_constants,
- list.foldl(non_enum_du_report_any_foreign_enum(TypeCtor, DuDefn),
+ list.foldl(
+ non_enum_du_report_any_foreign_enum(TypeCtor, DuDefn),
ImpEnums, !Specs),
- CheckedStdDefn = std_mer_type_du_not_all_plain_constants(Status,
- DuDefn, ChosenMaybeDefnCJCs)
+ CheckedStdDefn =
+ std_mer_type_du_not_all_plain_constants(Status, DuDefn,
+ ChosenMaybeDefnCJCs)
;
MaybeOnlyConstants = only_plain_constants(HeadName, TailNames),
decide_du_repn_foreign_only_constants(TypeCtor,
@@ -571,6 +584,14 @@ check_type_ctor_defns(InsistOnDefn, ModuleName,
MaybeDefnOrEnumCJCs, !Specs),
CheckedStdDefn = std_mer_type_du_all_plain_constants(Status,
DuDefn, HeadName, TailNames, MaybeDefnOrEnumCJCs)
+ )
+ ;
+ MaybeSuperType = yes(_),
+ % A subtype's representation depends on its base type, not only on
+ % its own constructors.
+ list.foldl(non_enum_du_report_any_foreign_enum(TypeCtor, DuDefn),
+ ImpEnums, !Specs),
+ CheckedStdDefn = std_mer_type_du_subtype(Status, DuDefn)
),
CheckedDefn = checked_defn_std(CheckedStdDefn),
@@ -1574,8 +1595,13 @@ add_type_ctor_to_field_name_map(TypeCtor, CheckedDefn, !FieldNameMap) :-
_, _, _)
)
;
- CheckedStdDefn = std_mer_type_du_not_all_plain_constants(_Status,
- DuDefn, _MaybeDefnCJCs),
+ (
+ CheckedStdDefn =
+ std_mer_type_du_not_all_plain_constants(_Status,
+ DuDefn, _MaybeDefnCJCs)
+ ;
+ CheckedStdDefn = std_mer_type_du_subtype(_Status, DuDefn)
+ ),
DetailsDu = DuDefn ^ td_ctor_defn,
DetailsDu = type_details_du(_MaybeSuperType, OoMCtors,
_MaybeCanonical, _MaybeDirectArgs),
diff --git a/compiler/comp_unit_interface.m b/compiler/comp_unit_interface.m
index faf240fc2..8274b3b6f 100644
--- a/compiler/comp_unit_interface.m
+++ b/compiler/comp_unit_interface.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2016, 2018-2021 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.
%---------------------------------------------------------------------------%
@@ -129,6 +129,7 @@
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_mutable.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module bool.
:- import_module cord.
@@ -1115,16 +1116,25 @@ accumulate_modules_from_type(Type, !Modules) :-
% XXX TYPE_REPN Shouldn't boxing make the size of the foreign type
% immaterial?
%
- % - If the definition defines an enum type, and there is a definition
- % of the same type_ctor in the interface, we include the type_ctor in
- % AbsExpEnumTypeCtors. This is so that when we abstract export
- % the type_ctor, we can record that its size is less than one word.
+ % - If the definition defines a subtype, and there is any definitions of
+ % that same type_ctor in the interface, then include the type_ctor in
+ % AbsExpEqvLhsTypeCtors, and the type_ctors of any supertype or
+ % equivalence types up to the base type. We include these type_ctors in
+ % NeededImpTypeCtors because the representation of subtypes must be the
+ % same as that of their base types.
+ %
+ % - If the definition defines an enum type (not a subtype), and there is a
+ % definition of the same type_ctor in the interface, we include the
+ % type_ctor in AbsExpEnumTypeCtors. This is so that when we abstract
+ % export the type_ctor, we can record that its size is less than one
+ % word.
% XXX TYPE_REPN Again, this info should be in a type_repn item.
%
- % - If the definition defines a dummy type, we include the type_ctor in
- % DirectDummyTypeCtors. XXX ITEM_LIST Presumably (by me -zs) this is
- % so that when we abstract export them, we can record that it needs
- % no storage. XXX However, we currently include dummy types in the
+ % - If the definition defines a dummy type (not a subtype), we include the
+ % type_ctor in DirectDummyTypeCtors.
+ % XXX ITEM_LIST Presumably (by me -zs) this is so that when we abstract
+ % export them, we can record that it needs no storage.
+ % XXX However, we currently include dummy types in the
% implementation section of the .int file unchanged, and we do so
% even if the type is not mentioned in the interface section at all.
% XXX TYPE_REPN Again, this info should be in a type_repn item.
@@ -1132,9 +1142,9 @@ accumulate_modules_from_type(Type, !Modules) :-
% The first pass ignores all other type definitions.
%
% The second pass processes the type_ctors in AbsExpEqvLhsTypeCtors,
- % i.e. the abstract exported type_ctors which have an equivalence type
- % or foreign type definition in the implementation section. Its job
- % is to compute three sets.
+ % i.e. the abstract exported type_ctors which have an equivalence type,
+ % foreign type, or subtype definition in the implementation section.
+ % Its job is to compute three sets.
%
% - The first set is AbsExpEqvRhsTypeCtors, the set of type_ctors
% that occur in any (partial or full) expansion of an equivalence type
@@ -1152,10 +1162,11 @@ accumulate_modules_from_type(Type, !Modules) :-
% - The second set is DuArgTypeCtors, the set of type_ctors that occur
% on the right hand side (i.e. among the field argument types) of
% a discriminated union definition of a type_ctor that is in
- % AbsExpEqvLhsTypeCtors, which should happen only that type_ctor
- % also has foreign language definitions (since we put a type_ctor
- % into AbsExpEqvLhsTypeCtors only if it has either an equivalence
- % or a foreign language definition). If these type_ctors are not
+ % AbsExpEqvLhsTypeCtors, which should happen only when that type_ctor
+ % also has foreign language definitions or a subtype definition
+ % (since we put a type_ctor into AbsExpEqvLhsTypeCtors only if it has
+ % either an equivalence definition, foreign language definition,
+ % or subtype definition). If these type_ctors are not
% otherwise included in the .int file, this will cause our caller
% to include an abstract declaration of these type_ctors in the
% .int file, to disambiguate the references to these types
@@ -1196,13 +1207,18 @@ accumulate_modules_from_type(Type, !Modules) :-
get_requirements_of_imp_exported_types(IntTypesMap, ImpTypesMap,
BothTypesMap, NeededImpTypeCtors, ModulesNeededByTypeDefns) :-
+ % XXX may want to rename AbsExpEqvLhsTypeCtors as it also includes
+ % foreign types and subtypes
map.foldl3(
accumulate_abs_imp_exported_type_lhs(IntTypesMap, BothTypesMap),
- ImpTypesMap, set.init, AbsExpEqvLhsTypeCtors,
- set.init, AbsExpEnumTypeCtors, set.init, DirectDummyTypeCtors),
+ ImpTypesMap,
+ set.init, AbsExpEqvLhsTypeCtors,
+ set.init, AbsExpEnumTypeCtors,
+ set.init, DirectDummyTypeCtors),
set.fold3(accumulate_abs_imp_exported_type_rhs(ImpTypesMap),
AbsExpEqvLhsTypeCtors,
- set.init, AbsExpEqvRhsTypeCtors, set.init, DuArgTypeCtors,
+ set.init, AbsExpEqvRhsTypeCtors,
+ set.init, DuArgTypeCtors,
set.init, ModulesNeededByTypeDefns),
NeededImpTypeCtors = set.union_list([AbsExpEqvLhsTypeCtors,
AbsExpEqvRhsTypeCtors, AbsExpEnumTypeCtors, DirectDummyTypeCtors,
@@ -1251,7 +1267,8 @@ accumulate_abs_imp_exported_type_lhs(IntTypesMap, BothTypesMap,
accumulate_abs_imp_exported_type_lhs_in_defn(IntTypesMap, BothTypesMap,
TypeCtor, ImpItemTypeDefnInfo, !AbsExpEqvLhsTypeCtors,
!AbsExpEnumTypeCtors, !DirectDummyTypeCtors) :-
- ImpItemTypeDefnInfo = item_type_defn_info(_, _, ImpTypeDefn, _, _, _),
+ ImpItemTypeDefnInfo = item_type_defn_info(_, _, ImpTypeDefn, TVarSet,
+ _, _),
(
ImpTypeDefn = parse_tree_eqv_type(_),
( if map.search(IntTypesMap, TypeCtor, _) then
@@ -1278,12 +1295,13 @@ accumulate_abs_imp_exported_type_lhs_in_defn(IntTypesMap, BothTypesMap,
)
;
ImpTypeDefn = parse_tree_du_type(DetailsDu),
- DetailsDu = type_details_du(_MaybeSuperType, OoMCtors, MaybeEqCmp,
+ DetailsDu = type_details_du(MaybeSuperType, OoMCtors, MaybeEqCmp,
MaybeDirectArgCtors),
- % XXX SUBTYPE Type representation of subtype depends on base type.
+ (
+ MaybeSuperType = no,
( if
map.search(IntTypesMap, TypeCtor, _),
- du_type_is_enum(DetailsDu, _NumFunctors)
+ non_sub_du_type_is_enum(DetailsDu, _NumFunctors)
then
set.insert(TypeCtor, !AbsExpEnumTypeCtors)
else if
@@ -1294,21 +1312,99 @@ accumulate_abs_imp_exported_type_lhs_in_defn(IntTypesMap, BothTypesMap,
% defined in another module, we will NOT include TypeCtor in
% !DirectDummyTypeCtors, since we won't know enough about
% the contents of the other module.
- % XXX SUBTYPE Do not consider a subtype to be a dummy type
- % unless the base type is a dummy type.
- constructor_list_represents_dummy_type(BothTypesMap, OoMCtors,
- MaybeEqCmp, MaybeDirectArgCtors)
+ non_sub_du_constructor_list_represents_dummy_type(BothTypesMap,
+ TVarSet, OoMCtors, MaybeEqCmp, MaybeDirectArgCtors)
then
set.insert(TypeCtor, !DirectDummyTypeCtors)
else
true
)
+ ;
+ MaybeSuperType = yes(SuperType),
+ ( if map.search(IntTypesMap, TypeCtor, _) then
+ set.insert(TypeCtor, !AbsExpEqvLhsTypeCtors),
+ ( if type_to_ctor(SuperType, SuperTypeCtor) then
+ set.singleton_set(TypeCtor, Seen0),
+ accumulate_eqv_and_supertypes(BothTypesMap,
+ SuperTypeCtor, !AbsExpEqvLhsTypeCtors, Seen0, _Seen)
+ else
+ true
+ )
+ else
+ true
+ )
+ )
;
( ImpTypeDefn = parse_tree_abstract_type(_)
; ImpTypeDefn = parse_tree_solver_type(_)
)
).
+ % Accumulate all supertype and equivalence type ctors leading to the
+ % base type ctor. The base type ctor does not need to be included.
+ %
+:- pred accumulate_eqv_and_supertypes(type_defn_map::in, type_ctor::in,
+ set(type_ctor)::in, set(type_ctor)::out,
+ set(type_ctor)::in, set(type_ctor)::out) is det.
+
+accumulate_eqv_and_supertypes(BothTypesMap, TypeCtor, !AbsExpEqvLhsTypeCtors,
+ !Seen) :-
+ % Check for circular types.
+ ( if set.insert_new(TypeCtor, !Seen) then
+ set.insert(TypeCtor, !AbsExpEqvLhsTypeCtors),
+ ( if map.search(BothTypesMap, TypeCtor, ItemTypeDefnInfos) then
+ one_or_more.foldl2(
+ accumulate_eqv_and_supertypes_in_defn(BothTypesMap, TypeCtor),
+ ItemTypeDefnInfos, !AbsExpEqvLhsTypeCtors, !Seen)
+ else
+ true
+ )
+ else
+ true
+ ).
+
+:- pred accumulate_eqv_and_supertypes_in_defn(type_defn_map::in,
+ type_ctor::in, item_type_defn_info::in,
+ set(type_ctor)::in, set(type_ctor)::out,
+ set(type_ctor)::in, set(type_ctor)::out) is det.
+
+accumulate_eqv_and_supertypes_in_defn(BothTypesMap, TypeCtor, ItemTypeDefnInfo,
+ !AbsExpEqvLhsTypeCtors, !Seen) :-
+ ItemTypeDefnInfo = item_type_defn_info(_, _, TypeDefn, _, _, _),
+ (
+ TypeDefn = parse_tree_eqv_type(DetailsEqv),
+ set.insert(TypeCtor, !AbsExpEqvLhsTypeCtors),
+ DetailsEqv = type_details_eqv(RhsType),
+ ( if type_to_ctor(RhsType, RhsTypeCtor) then
+ accumulate_eqv_and_supertypes(BothTypesMap, RhsTypeCtor,
+ !AbsExpEqvLhsTypeCtors, !Seen)
+ else
+ true
+ )
+ ;
+ TypeDefn = parse_tree_du_type(DetailsDu),
+ DetailsDu = type_details_du(MaybeSuperType, _, _, _),
+ (
+ MaybeSuperType = no
+ % This is the base type.
+ ;
+ MaybeSuperType = yes(SuperType),
+ % Not yet at the base type.
+ set.insert(TypeCtor, !AbsExpEqvLhsTypeCtors),
+ ( if type_to_ctor(SuperType, SuperTypeCtor) then
+ accumulate_eqv_and_supertypes(BothTypesMap, SuperTypeCtor,
+ !AbsExpEqvLhsTypeCtors, !Seen)
+ else
+ true
+ )
+ )
+ ;
+ ( TypeDefn = parse_tree_foreign_type(_)
+ ; TypeDefn = parse_tree_abstract_type(_)
+ ; TypeDefn = parse_tree_solver_type(_)
+ )
+ ).
+
:- pred accumulate_abs_imp_exported_type_rhs(type_defn_map::in, type_ctor::in,
set(type_ctor)::in, set(type_ctor)::out,
set(type_ctor)::in, set(type_ctor)::out,
@@ -1363,7 +1459,7 @@ accumulate_abs_eqv_type_rhs_in_defn(ImpTypesMap, ImpItemTypeDefnInfo,
!AbsExpEqvRhsTypeCtors, set.init, _, !ModulesNeededByTypeDefns)
;
ImpTypeDefn = parse_tree_du_type(DetailsDu),
- DetailsDu = type_details_du(MaybeSuperType, OoMCtors, _, _),
+ DetailsDu = type_details_du(_MaybeSuperType, OoMCtors, _, _),
% There must exist a foreign type alternative to this type.
% XXX ITEM_LIST I (zs) would like to see a proof argument for that,
% since I don't think it is true. Unfortunately, we cannot check it
@@ -1373,17 +1469,7 @@ accumulate_abs_eqv_type_rhs_in_defn(ImpTypesMap, ImpItemTypeDefnInfo,
% inside all the argument types of all the data constructors, and the
% modules that define them.
ctors_to_user_type_ctor_set(one_or_more_to_list(OoMCtors),
- set.init, RhsTypeCtors0),
- (
- MaybeSuperType = no,
- RhsTypeCtors = RhsTypeCtors0
- ;
- MaybeSuperType = yes(SuperType),
- % If the type is a subtype then we also require the type_ctor of
- % the supertype, and all the type_ctors inside the argument types
- % of the supertype, and the modules that define them.
- type_to_user_type_ctor_set(SuperType, RhsTypeCtors0, RhsTypeCtors)
- ),
+ set.init, RhsTypeCtors),
set.union(RhsTypeCtors, !DuArgTypeCtors),
set.fold(accumulate_modules_used_by_type_ctor, RhsTypeCtors,
!ModulesNeededByTypeDefns)
@@ -1471,26 +1557,28 @@ ctor_args_to_user_type_ctor_set([Arg | Args], !TypeCtors) :-
% and so when importing or exporting procedures to/from C, we don't include
% arguments with these types.
%
- % See the documentation for `type_util.check_dummy_type' for the definition
+ % See the documentation for `type_util.is_type_a_dummy' for the definition
% of a dummy type.
%
- % NOTE: changes here may require changes to `type_util.check_dummy_type'.
+ % NOTE: changes here may require changes to `type_util.is_type_a_dummy'.
%
-:- pred constructor_list_represents_dummy_type(type_defn_map::in,
- one_or_more(constructor)::in, maybe_canonical::in,
+ % This predicate can only be used to test non-subtype du types.
+ %
+:- pred non_sub_du_constructor_list_represents_dummy_type(type_defn_map::in,
+ tvarset::in, one_or_more(constructor)::in, maybe_canonical::in,
maybe(list(sym_name_arity))::in) is semidet.
-constructor_list_represents_dummy_type(TypeDefnMap,
+non_sub_du_constructor_list_represents_dummy_type(TypeDefnMap, TVarSet,
OoMCtors, MaybeCanonical, MaybeDirectArgCtors) :-
- constructor_list_represents_dummy_type_2(TypeDefnMap,
+ non_sub_du_constructor_list_represents_dummy_type_2(TypeDefnMap, TVarSet,
OoMCtors, MaybeCanonical, MaybeDirectArgCtors, []).
-:- pred constructor_list_represents_dummy_type_2(type_defn_map::in,
- one_or_more(constructor)::in, maybe_canonical::in,
+:- pred non_sub_du_constructor_list_represents_dummy_type_2(type_defn_map::in,
+ tvarset::in, one_or_more(constructor)::in, maybe_canonical::in,
maybe(list(sym_name_arity))::in, list(mer_type)::in) is semidet.
-constructor_list_represents_dummy_type_2(TypeDefnMap, OoMCtors,
- canon, no, CoveredTypes) :-
+non_sub_du_constructor_list_represents_dummy_type_2(TypeDefnMap, TVarSet,
+ OoMCtors, canon, no, CoveredTypes) :-
OoMCtors = one_or_more(Ctor, []),
Ctor = ctor(_Ordinal, MaybeExistConstraints, _Name, CtorArgs, _Arity,
_Context),
@@ -1501,12 +1589,15 @@ constructor_list_represents_dummy_type_2(TypeDefnMap, OoMCtors,
;
% A constructor with a single dummy argument.
CtorArgs = [ctor_arg(_, ArgType, _)],
- ctor_arg_is_dummy_type(TypeDefnMap, ArgType, CoveredTypes) = yes
+ ctor_arg_is_dummy_type(TypeDefnMap, TVarSet, ArgType, CoveredTypes)
+ = yes
).
-:- func ctor_arg_is_dummy_type(type_defn_map, mer_type, list(mer_type)) = bool.
+:- func ctor_arg_is_dummy_type(type_defn_map, tvarset, mer_type,
+ list(mer_type)) = bool.
-ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :-
+ctor_arg_is_dummy_type(TypeDefnMap, TVarSet, Type, CoveredTypes0)
+ = IsDummyType :-
(
Type = defined_type(SymName, TypeArgs, _Kind),
( if list.member(Type, CoveredTypes0) then
@@ -1522,18 +1613,8 @@ ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :-
;
% Can we find a definition of the type that tells us
% it is a dummy type?
- one_or_more_map.search(TypeDefnMap, TypeCtor,
- ItemTypeDefnInfos),
- one_or_more.member(ItemTypeDefnInfo, ItemTypeDefnInfos),
- TypeDefn = ItemTypeDefnInfo ^ td_ctor_defn,
- TypeDefn = parse_tree_du_type(DetailsDu),
- % XXX SUBTYPE Do not consider a subtype to be a dummy type
- % unless the base type is a dummy type.
- DetailsDu = type_details_du(_MaybeSuperType, OoMCtors,
- MaybeEqCmp, MaybeDirectArgCtors),
- constructor_list_represents_dummy_type_2(TypeDefnMap,
- OoMCtors, MaybeEqCmp, MaybeDirectArgCtors,
- [Type | CoveredTypes0])
+ ctor_arg_is_dummy_type_by_some_type_defn(TypeDefnMap,
+ TVarSet, Type, TypeCtor, TypeArgs, CoveredTypes0)
)
then
IsDummyType = yes
@@ -1554,6 +1635,71 @@ ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :-
unexpected($pred, "kinded_type")
).
+:- pred ctor_arg_is_dummy_type_by_some_type_defn(type_defn_map::in,
+ tvarset::in, mer_type::in, type_ctor::in, list(mer_type)::in,
+ list(mer_type)::in) is semidet.
+
+ctor_arg_is_dummy_type_by_some_type_defn(TypeDefnMap, TVarSet, Type, TypeCtor,
+ TypeArgs, CoveredTypes0) :-
+ one_or_more_map.search(TypeDefnMap, TypeCtor, ItemTypeDefnInfos),
+ one_or_more.member(ItemTypeDefnInfo, ItemTypeDefnInfos),
+ ItemTypeDefnInfo = item_type_defn_info(_TypeCtor, TypeDefnTypeParams,
+ TypeDefn, TypeDefnTVarSet, _Context, _SeqNum),
+ TypeDefn = parse_tree_du_type(DetailsDu),
+ DetailsDu = type_details_du(MaybeSuperType, OoMCtors, MaybeEqCmp,
+ MaybeDirectArgCtors),
+ (
+ MaybeSuperType = no,
+ non_sub_du_constructor_list_represents_dummy_type_2(TypeDefnMap,
+ TVarSet, OoMCtors, MaybeEqCmp, MaybeDirectArgCtors,
+ [Type | CoveredTypes0])
+ ;
+ MaybeSuperType = yes(SuperType0),
+ % A subtype can only be a dummy type if the base type is a dummy type.
+ merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs, TypeDefnTVarSet,
+ TypeDefnTypeParams, SuperType0, SuperType),
+ get_base_type(TypeDefnMap, TVarSet, SuperType, BaseType, set.init),
+ ctor_arg_is_dummy_type(TypeDefnMap, TVarSet, BaseType, CoveredTypes0)
+ = yes
+ ).
+
+:- pred merge_tvarsets_and_subst_type_args(tvarset::in, list(mer_type)::in,
+ tvarset::in, list(type_param)::in, mer_type::in, mer_type::out) is det.
+
+merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs,
+ TVarSet0, TypeParams0, Type0, Type) :-
+ tvarset_merge_renaming(TVarSet, TVarSet0, _MergedTVarSet, Renaming),
+ apply_variable_renaming_to_tvar_list(Renaming, TypeParams0, TypeParams),
+ map.from_corresponding_lists(TypeParams, TypeArgs, TSubst),
+ apply_variable_renaming_to_type(Renaming, Type0, Type1),
+ apply_rec_subst_to_type(TSubst, Type1, Type).
+
+:- pred get_base_type(type_defn_map::in, tvarset::in, mer_type::in,
+ mer_type::out, set(mer_type)::in) is nondet.
+
+get_base_type(TypeDefnMap, TVarSet, Type, BaseType, SeenTypes0):-
+ Type = defined_type(SymName, TypeArgs, _Kind),
+ % Check for circular types.
+ set.insert_new(Type, SeenTypes0, SeenTypes1),
+ Arity = list.length(TypeArgs),
+ TypeCtor = type_ctor(SymName, Arity),
+ one_or_more_map.search(TypeDefnMap, TypeCtor, ItemTypeDefnInfos),
+ one_or_more.member(ItemTypeDefnInfo, ItemTypeDefnInfos),
+ ItemTypeDefnInfo = item_type_defn_info(_TypeCtor, TypeDefnTypeParams,
+ TypeDefn, TypeDefnTVarSet, _Context, _SeqNum),
+ TypeDefn = parse_tree_du_type(DetailsDu),
+ DetailsDu = type_details_du(MaybeSuperType, _OoMCtors, _MaybeEqCmp,
+ _MaybeDirectArgCtors),
+ (
+ MaybeSuperType = no,
+ BaseType = Type
+ ;
+ MaybeSuperType = yes(SuperType0),
+ merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs,
+ TypeDefnTVarSet, TypeDefnTypeParams, SuperType0, SuperType),
+ get_base_type(TypeDefnMap, TVarSet, SuperType, BaseType, SeenTypes1)
+ ).
+
%---------------------%
% Given a type constructor's type definitions from the implementation
@@ -1622,9 +1768,23 @@ maybe_add_maybe_abstract_type_defns(BothTypesMap, IntTypesMap, NeededTypeCtors,
is_pure_abstract_type_defn(ImpItemTypeDefnInfo) :-
ImpItemTypeDefnInfo ^ td_ctor_defn = parse_tree_abstract_type(Details),
+ require_complete_switch [Details]
+ (
+ Details = abstract_type_general
+ ;
+ Details = abstract_type_fits_in_n_bits(_),
+ fail
+ ;
+ Details = abstract_subtype(_),
+ fail
+ ;
+ ( Details = abstract_dummy_type
+ ; Details = abstract_notag_type
+ ; Details = abstract_solver_type
+ )
% XXX ITEM_LIST This test may do the wrong thing for
% abstract_{dummy,notag,solver}_types, once we start generating them.
- Details \= abstract_type_fits_in_n_bits(_).
+ ).
:- pred make_imp_types_abstract(type_defn_map::in,
one_or_more(item_type_defn_info)::in,
@@ -1661,22 +1821,23 @@ make_imp_type_abstract(BothTypesMap, !ImpItemTypeDefnInfo) :-
% that are relevant to type representation (such as "is dummy",
% "fits in n bits", "is equivalent to ...") in a type_repn item,
% and then make the type definition abstract.
- !.ImpItemTypeDefnInfo = item_type_defn_info(_, _, TypeDefn0, _, _, _),
+ !.ImpItemTypeDefnInfo = item_type_defn_info(_, _, TypeDefn0, TVarSet,
+ _, _),
(
TypeDefn0 = parse_tree_du_type(DetailsDu0),
- DetailsDu0 = type_details_du(_MaybeSuperType, OoMCtors, MaybeEqCmp,
+ DetailsDu0 = type_details_du(MaybeSuperType, OoMCtors, MaybeEqCmp,
MaybeDirectArgCtors),
+ (
+ MaybeSuperType = no,
( if
- % XXX SUBTYPE Do not consider a subtype to be a dummy type unless
- % the base type is a dummy type.
- constructor_list_represents_dummy_type(BothTypesMap,
- OoMCtors, MaybeEqCmp, MaybeDirectArgCtors)
+ non_sub_du_constructor_list_represents_dummy_type(BothTypesMap,
+ TVarSet, OoMCtors, MaybeEqCmp, MaybeDirectArgCtors)
then
% Leave dummy types alone.
true
else
- ( if du_type_is_enum(DetailsDu0, NumFunctors) then
- num_bits_needed_for_n_values(NumFunctors, NumBits),
+ ( if non_sub_du_type_is_enum(DetailsDu0, NumFunctors) then
+ num_bits_needed_for_n_dense_values(NumFunctors, NumBits),
DetailsAbs = abstract_type_fits_in_n_bits(NumBits)
else
DetailsAbs = abstract_type_general
@@ -1684,6 +1845,13 @@ make_imp_type_abstract(BothTypesMap, !ImpItemTypeDefnInfo) :-
TypeDefn = parse_tree_abstract_type(DetailsAbs),
!ImpItemTypeDefnInfo ^ td_ctor_defn := TypeDefn
)
+ ;
+ MaybeSuperType = yes(SuperType),
+ type_to_ctor_det(SuperType, SuperTypeCtor),
+ DetailsAbs = abstract_subtype(SuperTypeCtor),
+ TypeDefn = parse_tree_abstract_type(DetailsAbs),
+ !ImpItemTypeDefnInfo ^ td_ctor_defn := TypeDefn
+ )
;
TypeDefn0 = parse_tree_eqv_type(_)
% XXX TYPE_REPN We currently leave the type definition alone.
@@ -2281,18 +2449,24 @@ dummy_solver_type = DetailsSolver :-
is det.
make_du_type_abstract(DetailsDu, DetailsAbstract) :-
- % XXX SUBTYPE Type representation of subtype depends on base type.
- DetailsDu = type_details_du(_MaybeSuperType, Ctors, MaybeCanonical,
+ DetailsDu = type_details_du(MaybeSuperType, Ctors, MaybeCanonical,
_MaybeDirectArgCtors),
- ( if du_type_is_enum(DetailsDu, NumFunctors) then
- num_bits_needed_for_n_values(NumFunctors, NumBits),
+ (
+ MaybeSuperType = no,
+ ( if non_sub_du_type_is_enum(DetailsDu, NumFunctors) then
+ num_bits_needed_for_n_dense_values(NumFunctors, NumBits),
DetailsAbstract = abstract_type_fits_in_n_bits(NumBits)
- else if du_type_is_notag(Ctors, MaybeCanonical) then
+ else if non_sub_du_type_is_notag(Ctors, MaybeCanonical) then
DetailsAbstract = abstract_notag_type
- else if du_type_is_dummy(DetailsDu) then
+ else if non_sub_du_type_is_dummy(DetailsDu) then
DetailsAbstract = abstract_dummy_type
else
DetailsAbstract = abstract_type_general
+ )
+ ;
+ MaybeSuperType = yes(SuperType),
+ type_to_ctor_det(SuperType, SuperTypeCtor),
+ DetailsAbstract = abstract_subtype(SuperTypeCtor)
).
:- pred delete_uc_preds_from_du_type(type_details_du::in,
diff --git a/compiler/convert_parse_tree.m b/compiler/convert_parse_tree.m
index a920702b7..86ce8a9c3 100644
--- a/compiler/convert_parse_tree.m
+++ b/compiler/convert_parse_tree.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2019 The Mercury team.
+% Copyright (C) 2019-2021 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.
%---------------------------------------------------------------------------%
@@ -1767,6 +1767,7 @@ add_type_defn_to_map(TypeDefnInfo, !TypeDefnMap) :-
; DetailsAbstract = abstract_type_fits_in_n_bits(_)
; DetailsAbstract = abstract_dummy_type
; DetailsAbstract = abstract_notag_type
+ ; DetailsAbstract = abstract_subtype(_)
),
!:AbstractStdDefns = !.AbstractStdDefns ++ [AbstractDefnInfo]
)
diff --git a/compiler/decide_type_repn.m b/compiler/decide_type_repn.m
index b21828251..6a1a8e90c 100644
--- a/compiler/decide_type_repn.m
+++ b/compiler/decide_type_repn.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2019 The University of Melbourne.
+% Copyright (C) 2019-2021 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.
%---------------------------------------------------------------------------%
@@ -42,27 +42,33 @@
%
% .int3 now:
% input: type_defns in source module
-% output: type_repns for simple types in interface and all? eqv types
+% output: type_repns for simple types in interface, subtypes in interface,
+% and all? eqv types
%
% .int2 now:
% input: type_defns in source module
-% output: type_repns for simple types in interface and all? eqv types
+% output: type_repns for simple types in interface, subtypes in interface,
+% and all? eqv types
%
% .int2 later:
% input: type_defns in source module
-% type_repns for simple/eqv types in direct/indirect imported .int3s
-% output: type_repns for simple types in interface and all? eqv types
+% type_repns for simple/eqv/subtypes types in direct/indirect
+% imported .int3s
+% output: type_repns for simple types in interface, subtypes in interface,
+% and all? eqv types
%
% .int1 later:
% input: type_defns in source module
-% type_repns for simple/eqv types in direct/indirect imported .int3s
+% type_repns for simple/eqv/subtypes types in direct/indirect
+% imported .int3s
% output: type_repns for all types that appear in interface
% (possibly for all types, in the interface or not, since
% .opt files may expose private types)
%
% .int0 later:
% input: type_defns in source module
-% type_repns for simple/eqv types in direct/indirect imported .int3s
+% type_repns for simple/eqv/subtypes types in direct/indirect
+% imported .int3s
% output: type_repns for all types
%
%---------------------------------------------------------------------------%
@@ -186,16 +192,21 @@
decide_repns_for_simple_types_for_int3(_ModuleName, TypeCtorCheckedMap,
!:Int3RepnMap) :-
map.init(EqvRepnMap0),
+ map.init(SubtypeMap0),
map.init(SimpleDuMap0),
WordAlignedTypeCtorsC0 = set_tree234.init,
ExportedTypes0 = set_tree234.init,
- map.foldl4(decide_simple_type_repns_stage_1, TypeCtorCheckedMap,
- EqvRepnMap0, EqvRepnMap, SimpleDuMap0, SimpleDuMap,
+ map.foldl5(decide_simple_type_repns_stage_1, TypeCtorCheckedMap,
+ EqvRepnMap0, EqvRepnMap,
+ SubtypeMap0, SubtypeMap,
+ SimpleDuMap0, SimpleDuMap,
WordAlignedTypeCtorsC0, WordAlignedTypeCtorsC,
ExportedTypes0, ExportedTypes),
map.init(!:Int3RepnMap),
map.foldl(add_eqv_repn_item, EqvRepnMap, !Int3RepnMap),
+ map.foldl(maybe_add_subtype_repn_item(ExportedTypes),
+ SubtypeMap, !Int3RepnMap),
map.foldl(maybe_add_simple_du_repn_item(ExportedTypes),
SimpleDuMap, !Int3RepnMap),
set_tree234.foldl(maybe_add_word_aligned_repn_item(ExportedTypes),
@@ -205,6 +216,8 @@ decide_repns_for_simple_types_for_int3(_ModuleName, TypeCtorCheckedMap,
:- type eqv_repn_map == map(type_ctor, item_type_repn_info_eqv).
+:- type subtype_repn_map == map(type_ctor, item_type_repn_info_subtype).
+
:- type simple_du_map == map(type_ctor, simple_du_repn).
:- type simple_du_repn
@@ -222,12 +235,15 @@ decide_repns_for_simple_types_for_int3(_ModuleName, TypeCtorCheckedMap,
:- pred decide_simple_type_repns_stage_1(
type_ctor::in, type_ctor_checked_defn::in,
- eqv_repn_map::in, eqv_repn_map::out, simple_du_map::in, simple_du_map::out,
+ eqv_repn_map::in, eqv_repn_map::out,
+ subtype_repn_map::in, subtype_repn_map::out,
+ simple_du_map::in, simple_du_map::out,
word_aligned_type_ctors_c::in, word_aligned_type_ctors_c::out,
set_tree234(type_ctor)::in, set_tree234(type_ctor)::out) is det.
decide_simple_type_repns_stage_1(TypeCtor, CheckedDefn,
- !EqvRepnMap, !SimpleDuMap, !WordAlignedTypeCtorsC, !ExportedTypes) :-
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC,
+ !ExportedTypes) :-
% The structure of this logic must match the structure of the logic
% in decide_all_type_repns_stage_2.
(
@@ -252,6 +268,32 @@ decide_simple_type_repns_stage_1(TypeCtor, CheckedDefn,
EqvRepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
EqvType, TVarSet, term.dummy_context_init, -1),
map.det_insert(TypeCtor, EqvRepnItem, !EqvRepnMap)
+ ;
+ StdDefn = std_mer_type_du_subtype(DuStatus, DuDefn),
+ (
+ ( DuStatus = std_du_type_mer_exported
+ ; DuStatus = std_du_type_abstract_exported
+ ),
+ set_tree234.insert(TypeCtor, !ExportedTypes)
+ ;
+ DuStatus = std_du_type_mer_ft_exported,
+ unexpected($pred, "subtype with foreign type")
+ ;
+ DuStatus = std_du_type_all_private
+ ),
+ DuDefn = item_type_defn_info(TypeCtorSymName, TypeParams,
+ DetailsDu, TVarSet, _Context, _SeqNum),
+ DetailsDu = type_details_du(MaybeSuperType, _, _, _),
+ (
+ MaybeSuperType = yes(SuperType),
+ type_to_ctor_det(SuperType, SuperTypeCtor)
+ ;
+ MaybeSuperType = no,
+ unexpected($pred, "no supertype")
+ ),
+ SubtypeRepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
+ SuperTypeCtor, TVarSet, term.dummy_context_init, -1),
+ map.det_insert(TypeCtor, SubtypeRepnItem, !SubtypeMap)
;
StdDefn = std_mer_type_du_all_plain_constants(DuStatus, DuDefn,
HeadName, TailNames, MaybeDefnOrEnumCJCsE),
@@ -264,6 +306,7 @@ decide_simple_type_repns_stage_1(TypeCtor, CheckedDefn,
;
DuStatus = std_du_type_all_private
),
+ expect_not(du_defn_is_subtype(DuDefn), $pred, "type is subtype"),
decide_type_repns_stage_1_du_all_plain_constants(TypeCtor, DuDefn,
HeadName, TailNames, MaybeDefnOrEnumCJCsE, !SimpleDuMap)
;
@@ -278,6 +321,7 @@ decide_simple_type_repns_stage_1(TypeCtor, CheckedDefn,
;
DuStatus = std_du_type_all_private
),
+ expect_not(du_defn_is_subtype(DuDefn), $pred, "type is subtype"),
decide_type_repns_stage_1_du_not_all_plain_constants(TypeCtor,
DuDefn, MaybeDefnCJCsE, !SimpleDuMap, !WordAlignedTypeCtorsC)
;
@@ -318,6 +362,13 @@ maybe_mark_type_ctor_as_word_aligned_for_c(TypeCtor, MaybeDefnCJCsE,
%---------------------%
+:- pred du_defn_is_subtype(item_type_defn_info_du::in) is semidet.
+
+du_defn_is_subtype(DuDefn) :-
+ DuDefn = item_type_defn_info(_, _, DetailsDu, _, _, _),
+ DetailsDu = type_details_du(MaybeSuperType, _, _, _),
+ MaybeSuperType = yes(_).
+
:- pred decide_type_repns_stage_1_du_all_plain_constants(type_ctor::in,
item_type_defn_info_du::in, string::in, list(string)::in,
c_j_cs_maybe_defn_or_enum::in,
@@ -327,8 +378,11 @@ decide_type_repns_stage_1_du_all_plain_constants(TypeCtor, DuDefn,
HeadName, TailNames, MaybeDefnOrEnumCJCsE, !SimpleDuMap) :-
decide_type_repns_foreign_defns_or_enums(MaybeDefnOrEnumCJCsE,
EnumForeignRepns),
- DuDefn = item_type_defn_info(_TypeCtorSymName, TypeParams, _DetailsDu,
+ DuDefn = item_type_defn_info(_TypeCtorSymName, TypeParams, DetailsDu,
TVarSet, _Context, _SeqNum),
+ DetailsDu = type_details_du(MaybeSuperType, _, _, _),
+ (
+ MaybeSuperType = no,
(
TailNames = [],
% The type has exactly one data constructor.
@@ -341,7 +395,12 @@ decide_type_repns_stage_1_du_all_plain_constants(TypeCtor, DuDefn,
EnumForeignRepns),
SimpleDuRepn = sdr_enum(TypeParams, TVarSet, EnumRepn)
),
- map.det_insert(TypeCtor, SimpleDuRepn, !SimpleDuMap).
+ map.det_insert(TypeCtor, SimpleDuRepn, !SimpleDuMap)
+ ;
+ MaybeSuperType = yes(_)
+ % We cannot decide the representation of a subtype independently
+ % of its base type, which may not even be in the same module.
+ ).
:- pred decide_type_repns_stage_1_du_not_all_plain_constants(type_ctor::in,
item_type_defn_info_du::in, c_j_cs_maybe_defn::in,
@@ -353,9 +412,10 @@ decide_type_repns_stage_1_du_not_all_plain_constants(TypeCtor, DuDefn,
decide_type_repns_foreign_defns(MaybeDefnCJCsE, ForeignTypeRepns),
DuDefn = item_type_defn_info(_TypeCtorSymName, TypeParams, DetailsDu,
TVarSet, _Context, _SeqNum),
- % XXX SUBTYPE Type representation of subtype depends on base type.
- DetailsDu = type_details_du(_MaybeSuperType, OoMCtors, MaybeCanonical,
+ DetailsDu = type_details_du(MaybeSuperType, OoMCtors, MaybeCanonical,
_MaybeDirectArgs),
+ (
+ MaybeSuperType = no,
OoMCtors = one_or_more(HeadCtor, TailCtors),
(
TailCtors = [],
@@ -393,8 +453,13 @@ decide_type_repns_stage_1_du_not_all_plain_constants(TypeCtor, DuDefn,
)
;
TailCtors = [_ | _]
- % The type has exactly two or more data constructors.
+ % The type has two or more data constructors.
% This means that it need not be word aligned.
+ )
+ ;
+ MaybeSuperType = yes(_)
+ % We cannot decide the representation of a subtype independently
+ % of its base type, which may not even be in the same module.
).
%---------------------------------------------------------------------------%
@@ -498,6 +563,33 @@ add_eqv_repn_item(TypeCtor, EqvRepnItem, !RepnMap) :-
tcrepn_is_eqv_to(EqvType), TVarSet, term.dummy_context_init, -1),
map.det_insert(TypeCtor, RepnItem, !RepnMap).
+%------------------%
+
+:- pred maybe_add_subtype_repn_item(set_tree234(type_ctor)::in,
+ type_ctor::in, item_type_repn_info_subtype::in,
+ type_ctor_repn_map::in, type_ctor_repn_map::out) is det.
+
+maybe_add_subtype_repn_item(ExportedTypes, TypeCtor, SubtypeRepnItem,
+ !RepnMap) :-
+ ( if set_tree234.member(TypeCtor, ExportedTypes) then
+ add_subtype_repn_item(TypeCtor, SubtypeRepnItem, !RepnMap)
+ else
+ true
+ ).
+
+:- pred add_subtype_repn_item(type_ctor::in, item_type_repn_info_subtype::in,
+ type_ctor_repn_map::in, type_ctor_repn_map::out) is det.
+
+add_subtype_repn_item(TypeCtor, SubtypeRepnItem, !RepnMap) :-
+ SubtypeRepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
+ SuperTypeCtor, TVarSet, _Context, _SeqNum),
+ RepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
+ tcrepn_is_subtype_of(SuperTypeCtor), TVarSet,
+ term.dummy_context_init, -1),
+ map.det_insert(TypeCtor, RepnItem, !RepnMap).
+
+%------------------%
+
:- pred maybe_add_simple_du_repn_item(set_tree234(type_ctor)::in,
type_ctor::in, simple_du_repn::in,
type_ctor_repn_map::in, type_ctor_repn_map::out) is det.
@@ -530,6 +622,8 @@ add_simple_du_repn_item(TypeCtor, SimpleDuRepn, !RepnMap) :-
tcrepn_du(DuRepn), TVarSet, term.context_init, -1),
map.det_insert(TypeCtor, Item, !RepnMap).
+%------------------%
+
:- pred maybe_add_word_aligned_repn_item(set_tree234(type_ctor)::in,
type_ctor::in, type_ctor_repn_map::in, type_ctor_repn_map::out) is det.
@@ -553,14 +647,19 @@ maybe_add_word_aligned_repn_item(ExportedTypes, TypeCtor, !RepnMap) :-
decide_repns_for_all_types_for_int1(Globals, _ModuleName, TypeCtorCheckedMap,
DirectSpecMap, IndirectSpecMap, !:Int1RepnMap, Specs) :-
- map.foldl3_values(record_type_repns_in_direct_int_spec,
- DirectSpecMap, map.init, EqvRepnMap0, map.init, SimpleDuMap0,
- set_tree234.init, WordAlignedTypeCtorsC0),
- map.foldl3_values(record_type_repns_in_indirect_int_spec,
- IndirectSpecMap, EqvRepnMap0, EqvRepnMap1, SimpleDuMap0, SimpleDuMap1,
+ map.foldl4_values(record_type_repns_in_direct_int_spec,
+ DirectSpecMap, map.init, EqvRepnMap0, map.init, SubtypeMap0,
+ map.init, SimpleDuMap0, set_tree234.init, WordAlignedTypeCtorsC0),
+ map.foldl4_values(record_type_repns_in_indirect_int_spec,
+ IndirectSpecMap,
+ EqvRepnMap0, EqvRepnMap1,
+ SubtypeMap0, SubtypeMap1,
+ SimpleDuMap0, SimpleDuMap1,
WordAlignedTypeCtorsC0, WordAlignedTypeCtorsC1),
- map.foldl4(decide_simple_type_repns_stage_1, TypeCtorCheckedMap,
- EqvRepnMap1, EqvRepnMap, SimpleDuMap1, SimpleDuMap,
+ map.foldl5(decide_simple_type_repns_stage_1, TypeCtorCheckedMap,
+ EqvRepnMap1, EqvRepnMap,
+ SubtypeMap1, SubtypeMap,
+ SimpleDuMap1, SimpleDuMap,
WordAlignedTypeCtorsC1, WordAlignedTypeCtorsC,
set_tree234.init, _ExportedTypes),
@@ -570,7 +669,7 @@ decide_repns_for_all_types_for_int1(Globals, _ModuleName, TypeCtorCheckedMap,
EqvRepnMap, EqvMap),
map.foldl2(
decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap,
- WordAlignedTypeCtorsC, SimpleDuMap),
+ SubtypeMap, WordAlignedTypeCtorsC, SimpleDuMap),
TypeCtorCheckedMap, !Int1RepnMap, [], Specs).
:- pred item_type_repn_info_eqv_to_eqv_type_body(item_type_repn_info_eqv::in,
@@ -584,53 +683,61 @@ item_type_repn_info_eqv_to_eqv_type_body(ItemTypeRepnInfoEqv, EqvBody) :-
%---------------------------------------------------------------------------%
:- pred record_type_repns_in_direct_int_spec(direct_int_spec::in,
- eqv_repn_map::in, eqv_repn_map::out, simple_du_map::in, simple_du_map::out,
+ eqv_repn_map::in, eqv_repn_map::out,
+ subtype_repn_map::in, subtype_repn_map::out,
+ simple_du_map::in, simple_du_map::out,
word_aligned_type_ctors_c::in, word_aligned_type_ctors_c::out) is det.
record_type_repns_in_direct_int_spec(DirectIntSpec,
- !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC) :-
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC) :-
(
DirectIntSpec = direct_int1(_, _),
unexpected($pred, "direct_int1")
;
DirectIntSpec = direct_int3(ParseTreeInt3, _ReadWhy3),
record_type_repns_in_parse_tree_int3(ParseTreeInt3,
- !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC)
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC)
).
:- pred record_type_repns_in_indirect_int_spec(indirect_int_spec::in,
- eqv_repn_map::in, eqv_repn_map::out, simple_du_map::in, simple_du_map::out,
+ eqv_repn_map::in, eqv_repn_map::out,
+ subtype_repn_map::in, subtype_repn_map::out,
+ simple_du_map::in, simple_du_map::out,
word_aligned_type_ctors_c::in, word_aligned_type_ctors_c::out) is det.
record_type_repns_in_indirect_int_spec(IndirectIntSpec,
- !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC) :-
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC) :-
(
IndirectIntSpec = indirect_int2(_, _),
unexpected($pred, "direct_int2")
;
IndirectIntSpec = indirect_int3(ParseTreeInt3, _ReadWhy3),
record_type_repns_in_parse_tree_int3(ParseTreeInt3,
- !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC)
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC)
).
:- pred record_type_repns_in_parse_tree_int3(parse_tree_int3::in,
- eqv_repn_map::in, eqv_repn_map::out, simple_du_map::in, simple_du_map::out,
+ eqv_repn_map::in, eqv_repn_map::out,
+ subtype_repn_map::in, subtype_repn_map::out,
+ simple_du_map::in, simple_du_map::out,
word_aligned_type_ctors_c::in, word_aligned_type_ctors_c::out) is det.
record_type_repns_in_parse_tree_int3(ParseTreeInt3,
- !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC) :-
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC) :-
ModuleName = ParseTreeInt3 ^ pti3_module_name,
TypeRepns = ParseTreeInt3 ^ pti3_int_type_repns,
- map.foldl3(record_type_repn_in_parse_tree_int3(ModuleName),
- TypeRepns, !SimpleDuMap, !EqvRepnMap, !WordAlignedTypeCtorsC).
+ map.foldl4(record_type_repn_in_parse_tree_int3(ModuleName),
+ TypeRepns, !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC).
:- pred record_type_repn_in_parse_tree_int3(module_name::in,
type_ctor::in, item_type_repn_info::in,
- eqv_repn_map::in, eqv_repn_map::out, simple_du_map::in, simple_du_map::out,
+ eqv_repn_map::in, eqv_repn_map::out,
+ subtype_repn_map::in, subtype_repn_map::out,
+ simple_du_map::in, simple_du_map::out,
word_aligned_type_ctors_c::in, word_aligned_type_ctors_c::out) is det.
record_type_repn_in_parse_tree_int3(ModuleName, TypeCtor0, ItemTypeRepnInfo,
- !EqvRepnMap, !SimpleDuMap, !WordAlignedTypeCtorsC) :-
+ !EqvRepnMap, !SubtypeMap, !SimpleDuMap, !WordAlignedTypeCtorsC) :-
ItemTypeRepnInfo = item_type_repn_info(TypeCtorSymName0, TypeParams,
RepnInfo, TVarSet, _Context, _SeqNum),
TypeCtor0 = type_ctor(SymName0, Arity),
@@ -670,6 +777,16 @@ record_type_repn_in_parse_tree_int3(ModuleName, TypeCtor0, ItemTypeRepnInfo,
EqvRepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
EqvType, TVarSet, term.dummy_context_init, -1),
map.det_insert(TypeCtor, EqvRepnItem, !EqvRepnMap)
+ ;
+ RepnInfo = tcrepn_is_subtype_of(SuperType),
+ TypeCtorName = unqualify_name(TypeCtorSymName0),
+ TypeCtorSymName = qualified(ModuleName, TypeCtorName),
+ RepnTypeCtor = type_ctor(TypeCtorSymName, list.length(TypeParams)),
+ expect(unify(TypeCtor, RepnTypeCtor), $pred,
+ "TypeCtor != RepnTypeCtor"),
+ SubtypeRepnItem = item_type_repn_info(TypeCtorSymName, TypeParams,
+ SuperType, TVarSet, term.dummy_context_init, -1),
+ map.det_insert(TypeCtor, SubtypeRepnItem, !SubtypeMap)
;
RepnInfo = tcrepn_foreign(_),
unexpected($pred, "unexpected tc_repn_foreign")
@@ -683,17 +800,18 @@ record_type_repn_in_parse_tree_int3(ModuleName, TypeCtor0, ItemTypeRepnInfo,
% generate a type_repn item for every type defined in the module.
%
% - dereference all eqv types
+ % - generate type repns for subtypes
% - convert simple du types to generic type repns
% - decide all complex types and generate type repns
%
:- pred decide_all_type_repns_stage_2(base_params::in,
- eqv_repn_map::in, type_eqv_map::in,
+ eqv_repn_map::in, type_eqv_map::in, subtype_repn_map::in,
set_tree234(type_ctor)::in, simple_du_map::in,
type_ctor::in, type_ctor_checked_defn::in,
type_ctor_repn_map::in, type_ctor_repn_map::out,
list(error_spec)::in, list(error_spec)::out) is det.
-decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap,
+decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap, SubtypeMap,
WordAlignedTypeCtorsC, SimpleDuMap, TypeCtor, CheckedDefn,
!Int1RepnMap, !Specs) :-
% The structure of this logic must match the structure of the logic
@@ -711,6 +829,10 @@ decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap,
replace_in_type_repn_eqv(EqvMap,
EqvRepnItem0, EqvRepnItem, !Specs),
add_eqv_repn_item(TypeCtor, EqvRepnItem, !Int1RepnMap)
+ ;
+ StdDefn = std_mer_type_du_subtype(_, _),
+ map.lookup(SubtypeMap, TypeCtor, SubtypeRepnItem),
+ add_subtype_repn_item(TypeCtor, SubtypeRepnItem, !Int1RepnMap)
;
StdDefn = std_mer_type_du_all_plain_constants(_, _, _, _, _),
map.lookup(SimpleDuMap, TypeCtor, SimpleDuRepn),
@@ -718,7 +840,7 @@ decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap,
;
StdDefn = std_mer_type_du_not_all_plain_constants(_DuStatus,
DuDefn, MaybeDefnCJCsE),
- decide_type_repns_stage_2_du_gen(BaseParams, EqvMap,
+ decide_type_repns_stage_2_du_gen(BaseParams, EqvMap, SubtypeMap,
WordAlignedTypeCtorsC, SimpleDuMap, TypeCtor,
DuDefn, MaybeDefnCJCsE, !Int1RepnMap, !Specs)
;
@@ -737,12 +859,12 @@ decide_all_type_repns_stage_2(BaseParams, EqvRepnMap, EqvMap,
%---------------------------------------------------------------------------%
:- pred decide_type_repns_stage_2_du_gen(base_params::in, type_eqv_map::in,
- set_tree234(type_ctor)::in, simple_du_map::in, type_ctor::in,
- item_type_defn_info_du::in, c_j_cs_maybe_defn::in,
+ subtype_repn_map::in, set_tree234(type_ctor)::in, simple_du_map::in,
+ type_ctor::in, item_type_defn_info_du::in, c_j_cs_maybe_defn::in,
type_ctor_repn_map::in, type_ctor_repn_map::out,
list(error_spec)::in, list(error_spec)::out) is det.
-decide_type_repns_stage_2_du_gen(BaseParams, EqvMap,
+decide_type_repns_stage_2_du_gen(BaseParams, EqvMap, SubtypeMap,
WordAlignedTypeCtorsC, SimpleDuMap, TypeCtor, DuDefn, MaybeDefnCJCsE,
!Int1RepnMap, !Specs) :-
decide_type_repns_foreign_defns(MaybeDefnCJCsE, RepnCJCsE),
@@ -754,12 +876,12 @@ decide_type_repns_stage_2_du_gen(BaseParams, EqvMap,
expect(unify(TypeCtorSymName, SymName), $pred, "sym_name mismatch"),
expect(unify(NumTypeParams, Arity), $pred, "arity mismatch"),
- % XXX SUBTYPE Type representation of subtype depends on base type.
- DetailsDu = type_details_du(_MaybeSuperType, OoMCtors0, MaybeCanonical,
+ DetailsDu = type_details_du(MaybeSuperType, OoMCtors0, MaybeCanonical,
_MaybeDirectArgs),
+ expect(unify(MaybeSuperType, no), $pred, "type is subtype"),
OoMCtors0 = one_or_more(HeadCtor0, TailCtors0),
- expand_eqv_cnotag_types_in_constructor(EqvMap, SimpleDuMap, TVarSet,
- HeadCtor0, HeadCtor, !Specs),
+ expand_eqv_sub_of_notag_types_in_constructor(EqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, HeadCtor0, HeadCtor, !Specs),
(
TailCtors0 = [],
% The type has exactly one data constructor.
@@ -769,8 +891,8 @@ decide_type_repns_stage_2_du_gen(BaseParams, EqvMap,
;
TailCtors0 = [_ | _],
% The type has two or more data constructors.
- expand_eqv_cnotag_types_in_constructors(EqvMap, SimpleDuMap, TVarSet,
- TailCtors0, TailCtors, !Specs),
+ expand_eqv_sub_of_notag_types_in_constructors(EqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, TailCtors0, TailCtors, !Specs),
decide_type_repns_stage_2_du_gen_more_functors(BaseParams,
WordAlignedTypeCtorsC, SimpleDuMap, TypeCtor, TypeParams,
TVarSet, [HeadCtor | TailCtors], RepnCJCsE, !Int1RepnMap)
@@ -2186,32 +2308,32 @@ is_direct_arg_ctor_for_c(WordAlignedTypeCtorsC, ClassifiedCtor) :-
%---------------------------------------------------------------------------%
- % XXX ARG_PACK Think about whether visibility differences hould limit
+ % XXX ARG_PACK Think about whether visibility differences should limit
% the type expansion process.
%
-:- pred expand_eqv_cnotag_types_in_constructors(type_eqv_map::in,
- simple_du_map::in, tvarset::in,
+:- pred expand_eqv_sub_of_notag_types_in_constructors(type_eqv_map::in,
+ subtype_repn_map::in, simple_du_map::in, tvarset::in,
list(constructor)::in, list(constructor)::out,
list(error_spec)::in, list(error_spec)::out) is det.
-expand_eqv_cnotag_types_in_constructors(_, _, _, [], [], !Specs).
-expand_eqv_cnotag_types_in_constructors(EqvMap, SimpleDuMap, TVarSet,
- [Ctor0 | Ctors0], [Ctor | Ctors], !Specs) :-
- expand_eqv_cnotag_types_in_constructor(EqvMap, SimpleDuMap, TVarSet,
- Ctor0, Ctor, !Specs),
- expand_eqv_cnotag_types_in_constructors(EqvMap, SimpleDuMap, TVarSet,
- Ctors0, Ctors, !Specs).
+expand_eqv_sub_of_notag_types_in_constructors(_, _, _, _, [], [], !Specs).
+expand_eqv_sub_of_notag_types_in_constructors(EqvMap, SubtypeMap, SimpleDuMap,
+ TVarSet, [Ctor0 | Ctors0], [Ctor | Ctors], !Specs) :-
+ expand_eqv_sub_of_notag_types_in_constructor(EqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, Ctor0, Ctor, !Specs),
+ expand_eqv_sub_of_notag_types_in_constructors(EqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, Ctors0, Ctors, !Specs).
-:- pred expand_eqv_cnotag_types_in_constructor(type_eqv_map::in,
- simple_du_map::in, tvarset::in,
+:- pred expand_eqv_sub_of_notag_types_in_constructor(type_eqv_map::in,
+ subtype_repn_map::in, simple_du_map::in, tvarset::in,
constructor::in, constructor::out,
list(error_spec)::in, list(error_spec)::out) is det.
-expand_eqv_cnotag_types_in_constructor(EqvMap, SimpleDuMap, TVarSet,
- Ctor0, Ctor, !Specs) :-
+expand_eqv_sub_of_notag_types_in_constructor(EqvMap, SubtypeMap, SimpleDuMap,
+ TVarSet, Ctor0, Ctor, !Specs) :-
Args0 = Ctor0 ^ cons_args,
- expand_eqv_cnotag_types_in_constructor_args(EqvMap, SimpleDuMap, TVarSet,
- Args0, Args, no_change, Changed, !Specs),
+ expand_eqv_sub_of_notag_types_in_constructor_args(EqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, Args0, Args, no_change, Changed, !Specs),
% Don't allocate memory if we don't have to. Many constructors
% have no constructors containing no equivalence types.
(
@@ -2222,20 +2344,21 @@ expand_eqv_cnotag_types_in_constructor(EqvMap, SimpleDuMap, TVarSet,
Ctor = Ctor0 ^ cons_args := Args
).
-:- pred expand_eqv_cnotag_types_in_constructor_args(type_eqv_map::in,
- simple_du_map::in, tvarset::in,
+:- pred expand_eqv_sub_of_notag_types_in_constructor_args(type_eqv_map::in,
+ subtype_repn_map::in, simple_du_map::in, tvarset::in,
list(constructor_arg)::in, list(constructor_arg)::out,
maybe_changed::in, maybe_changed::out,
list(error_spec)::in, list(error_spec)::out) is det.
-expand_eqv_cnotag_types_in_constructor_args(_, _, _, [], [], !Changed, !Specs).
-expand_eqv_cnotag_types_in_constructor_args(TypeEqvMap, SimpleDuMap,
- TVarSet, [Arg0 | Args0], [Arg | Args], !Changed, !Specs) :-
+expand_eqv_sub_of_notag_types_in_constructor_args(_, _, _, _, [], [],
+ !Changed, !Specs).
+expand_eqv_sub_of_notag_types_in_constructor_args(TypeEqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, [Arg0 | Args0], [Arg | Args], !Changed, !Specs) :-
Arg0 = ctor_arg(MaybeFieldName, ArgType0, Context),
- expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap,
+ expand_eqv_sub_of_notag_type_fixpoint(TypeEqvMap, SubtypeMap, SimpleDuMap,
TVarSet, Context, 100, ArgType0, ArgType, ArgTypeChanged, !Specs),
% Don't allocate memory if we don't have to. Most argument types
- % contain no equivalence types.
+ % need no expansion.
(
ArgTypeChanged = no_change,
Arg = Arg0
@@ -2244,22 +2367,23 @@ expand_eqv_cnotag_types_in_constructor_args(TypeEqvMap, SimpleDuMap,
!:Changed = changed,
Arg = ctor_arg(MaybeFieldName, ArgType, Context)
),
- expand_eqv_cnotag_types_in_constructor_args(TypeEqvMap, SimpleDuMap,
- TVarSet, Args0, Args, !Changed, !Specs).
+ expand_eqv_sub_of_notag_types_in_constructor_args(TypeEqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet, Args0, Args, !Changed, !Specs).
-:- pred expand_eqv_cnotag_type_fixpoint(type_eqv_map::in, simple_du_map::in,
- tvarset::in, prog_context::in, int::in, mer_type::in, mer_type::out,
- maybe_changed::out, list(error_spec)::in, list(error_spec)::out) is det.
+:- pred expand_eqv_sub_of_notag_type_fixpoint(type_eqv_map::in,
+ subtype_repn_map::in, simple_du_map::in, tvarset::in, prog_context::in,
+ int::in, mer_type::in, mer_type::out, maybe_changed::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap, TVarSet0, Context,
- IterationsLeft, Type0, Type, Changed, !Specs) :-
+expand_eqv_sub_of_notag_type_fixpoint(TypeEqvMap, SubtypeMap, SimpleDuMap,
+ TVarSet0, Context, IterationsLeft, Type0, Type, Changed, !Specs) :-
% Each fixpoint iteration, we try to expand Type0 as either
- % a notag type or as an equivalence type. If we succeed with either,
- % we may not have arrived at a fixpoint yet, so we recurse.
- % If we succeed with neither, then we *have* arrived at a fixpoint,
+ % a notag type, an equivalence type, or subtype. If we succeed with any
+ % of the three, we may not have arrived at a fixpoint yet, so we recurse.
+ % If we succeed with none, then we *have* arrived at a fixpoint,
% and therefore we stop.
%
- % It is possible to construct pairs of notag types and equivalence types
+ % It is possible to construct notag types, equivalence types and subtypes
% that would cause us to never find the fixpoint, instead of iterating
% forever. This should never happen with natural inputs, but only with
% with inputs that has been specially crafted for this purpose,
@@ -2271,9 +2395,8 @@ expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap, TVarSet0, Context,
Changed = no_change,
Type = Type0
else if
- type_to_ctor_and_args(Type0, TypeCtor0, ArgTypes0),
-
% Is the Mercury definition of Type0 a notag type?
+ type_to_ctor_and_args(Type0, TypeCtor0, ArgTypes0),
map.search(SimpleDuMap, TypeCtor0, SimpleDuRepn),
SimpleDuRepn = sdr_notag(NotagParams0, NotagTVarSet0, NotagRepn),
% Is the Mercury definition of Type0 overridden by a foreign
@@ -2294,16 +2417,39 @@ expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap, TVarSet0, Context,
% an internal compiler error, not a user error.
map.from_corresponding_lists(NotagParams1, ArgTypes0, ParamsSubst),
apply_subst_to_type(ParamsSubst, NotagFunctorArgType1, Type1),
- expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap, TVarSet1,
- Context, IterationsLeft - 1, Type1, Type, _Changed, !Specs),
+ expand_eqv_sub_of_notag_type_fixpoint(TypeEqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet1, Context, IterationsLeft - 1, Type1, Type,
+ _Changed, !Specs),
+ Changed = changed
+ else if
+ % Is the Mercury definition of Type0 a subtype?
+ type_to_ctor_and_args(Type0, TypeCtor0, _ArgTypes0),
+ map.search(SubtypeMap, TypeCtor0, SubtypeRepn0),
+ SubtypeRepn0 =
+ item_type_repn_info(_TypeCtorSymName, _TypeParams, SuperTypeCtor,
+ _TypeTVarSet, _Context, _SeqNum)
+ then
+ % We do not have the arguments of the super type, only the type ctor.
+ % However, we can just substitute new type variables for the type
+ % parameters because the result (Type) is only going to be used for
+ % deciding type representations, and the representation of a type ctor
+ % does not depend on the types bound to its parameters.
+ SuperTypeCtor = type_ctor(_, SuperTypeCtorArity),
+ varset.new_vars(SuperTypeCtorArity, NewTypeVars, TVarSet0, TVarSet1),
+ var_list_to_type_list(map.init, NewTypeVars, NewTypeArgs),
+ construct_type(SuperTypeCtor, NewTypeArgs, SuperType),
+ expand_eqv_sub_of_notag_type_fixpoint(TypeEqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet1, Context, IterationsLeft - 1, SuperType, Type,
+ _Changed, !Specs),
Changed = changed
else
replace_in_type_report_circular_eqvs(TypeEqvMap, TVarSet0, Context,
Type0, Type1, Changed, !Specs),
(
Changed = changed,
- expand_eqv_cnotag_type_fixpoint(TypeEqvMap, SimpleDuMap, TVarSet0,
- Context, IterationsLeft - 1, Type1, Type, _Changed, !Specs)
+ expand_eqv_sub_of_notag_type_fixpoint(TypeEqvMap, SubtypeMap,
+ SimpleDuMap, TVarSet0, Context, IterationsLeft - 1,
+ Type1, Type, _Changed, !Specs)
;
Changed = no_change,
Type = Type0
diff --git a/compiler/direct_arg_in_out.m b/compiler/direct_arg_in_out.m
index f7268cff7..a5ea1dd2c 100644
--- a/compiler/direct_arg_in_out.m
+++ b/compiler/direct_arg_in_out.m
@@ -335,8 +335,7 @@ is_direct_arg_in_out_posn(ModuleInfo, VarTypes, Var, Mode, IsDAIO) :-
then
get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, _MaybeSuperType, _, MaybeRepn, _),
- % XXX SUBTYPE Type representation of subtype depends on base type.
+ TypeBody = hlds_du_type(_, _, _, MaybeRepn, _),
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
diff --git a/compiler/du_type_layout.m b/compiler/du_type_layout.m
index f80b1be0f..ac52d7986 100644
--- a/compiler/du_type_layout.m
+++ b/compiler/du_type_layout.m
@@ -2,6 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1993-2012 The University of Melbourne.
+% Copyright (C) 2015, 2017-2021 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.
%---------------------------------------------------------------------------%
@@ -132,6 +133,7 @@
:- import_module one_or_more.
:- import_module pair.
:- import_module require.
+:- import_module set.
:- import_module string.
:- import_module term.
:- import_module uint.
@@ -153,19 +155,36 @@ decide_type_repns(!ModuleInfo, !Specs, !IO) :-
module_info_get_type_table(!.ModuleInfo, TypeTable0),
get_all_type_ctor_defns(TypeTable0, TypeCtorsTypeDefns0),
+ % Pass 1.
map.init(ComponentTypeMap0),
map.init(NoTagTypeMap0),
- list.map_foldl3(
+ list.foldl5(
decide_if_simple_du_type(!.ModuleInfo, Params,
TypeCtorToForeignEnumMap),
- TypeCtorsTypeDefns0, TypeCtorsTypeDefns1,
- ComponentTypeMap0, ComponentTypeMap,
- NoTagTypeMap0, NoTagTypeMap, !Specs),
+ TypeCtorsTypeDefns0,
+ [], NonSubTypeCtorsTypeDefns1,
+ [], SubTypeCtorsTypeDefns1,
+ ComponentTypeMap0, ComponentTypeMap1,
+ NoTagTypeMap0, NoTagTypeMap1, !Specs),
+
+ % Pass 1b.
+ list.foldl2(add_if_subtype_of_simple_du_type_to_maps(TypeTable0),
+ SubTypeCtorsTypeDefns1,
+ ComponentTypeMap1, ComponentTypeMap,
+ NoTagTypeMap1, NoTagTypeMap),
+
module_info_set_no_tag_types(NoTagTypeMap, !ModuleInfo),
+ % Pass 2.
list.map_foldl(
decide_if_complex_du_type(!.ModuleInfo, Params, ComponentTypeMap),
- TypeCtorsTypeDefns1, TypeCtorsTypeDefns, !Specs),
+ NonSubTypeCtorsTypeDefns1, NonSubTypeCtorsTypeDefns2, !Specs),
+
+ % Pass 2b.
+ list.map_foldl(decide_if_subtype(TypeTable0, NonSubTypeCtorsTypeDefns2),
+ SubTypeCtorsTypeDefns1, SubTypeCtorsTypeDefns2, !Specs),
+
+ TypeCtorsTypeDefns = SubTypeCtorsTypeDefns2 ++ NonSubTypeCtorsTypeDefns2,
set_all_type_ctor_defns(TypeCtorsTypeDefns, SortedTypeCtorsTypeDefns,
TypeTable),
module_info_set_type_table(TypeTable, !ModuleInfo),
@@ -239,22 +258,27 @@ add_special_pred_decl_defns_for_types_maybe_lazily(
:- pred decide_if_simple_du_type(module_info::in, decide_du_params::in,
type_ctor_to_foreign_enums_map::in,
- pair(type_ctor, hlds_type_defn)::in, pair(type_ctor, hlds_type_defn)::out,
+ pair(type_ctor, hlds_type_defn)::in,
+ assoc_list(type_ctor, hlds_type_defn)::in,
+ assoc_list(type_ctor, hlds_type_defn)::out,
+ assoc_list(type_ctor, hlds_type_defn)::in,
+ assoc_list(type_ctor, hlds_type_defn)::out,
component_type_map::in, component_type_map::out,
no_tag_type_table::in, no_tag_type_table::out,
list(error_spec)::in, list(error_spec)::out) is det.
decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap,
- TypeCtorTypeDefn0, TypeCtorTypeDefn,
+ TypeCtorTypeDefn0, !NonSubTypeCtorTypeDefns, !SubTypeCtorsTypeDefns,
!ComponentTypeMap, !NoTagTypeMap, !Specs) :-
TypeCtorTypeDefn0 = TypeCtor - TypeDefn0,
get_type_defn_body(TypeDefn0, Body0),
(
- % XXX SUBTYPE Type representation of subtype depends on base type.
- Body0 = hlds_du_type(OoMCtors, _MaybeSuperType, MaybeCanonical,
+ Body0 = hlds_du_type(OoMCtors, MaybeSuperType, MaybeCanonical,
MaybeRepn0, MaybeForeign),
OoMCtors = one_or_more(HeadCtor, TailCtors),
expect(unify(MaybeRepn0, no), $pred, "MaybeRepn0 != no"),
+ (
+ MaybeSuperType = no,
( if
map.search(TypeCtorToForeignEnumMap, TypeCtor, TCFE),
TCFE = type_ctor_foreign_enums(_LangContextMap,
@@ -295,6 +319,12 @@ decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap,
else
% Figure out the representation of these types in the second pass.
TypeCtorTypeDefn = TypeCtorTypeDefn0
+ ),
+ cons(TypeCtorTypeDefn, !NonSubTypeCtorTypeDefns)
+ ;
+ MaybeSuperType = yes(_),
+ % Figure out the representation of subtypes in later passes.
+ cons(TypeCtorTypeDefn0, !SubTypeCtorsTypeDefns)
)
;
Body0 = hlds_foreign_type(ForeignType),
@@ -302,18 +332,30 @@ decide_if_simple_du_type(ModuleInfo, Params, TypeCtorToForeignEnumMap,
ForeignType, !ComponentTypeMap, !Specs),
% There are no questions of representation to figure out.
- TypeCtorTypeDefn = TypeCtorTypeDefn0
+ cons(TypeCtorTypeDefn0, !NonSubTypeCtorTypeDefns)
;
Body0 = hlds_abstract_type(AbstractDetails),
- add_abstract_if_packable(TypeCtor, AbstractDetails, !ComponentTypeMap),
- TypeCtorTypeDefn = TypeCtorTypeDefn0
+ (
+ ( AbstractDetails = abstract_type_fits_in_n_bits(_)
+ ; AbstractDetails = abstract_dummy_type
+ ; AbstractDetails = abstract_notag_type
+ ; AbstractDetails = abstract_type_general
+ ; AbstractDetails = abstract_solver_type
+ ),
+ add_abstract_if_packable(TypeCtor, AbstractDetails,
+ !ComponentTypeMap),
+ cons(TypeCtorTypeDefn0, !NonSubTypeCtorTypeDefns)
+ ;
+ AbstractDetails = abstract_subtype(_),
+ cons(TypeCtorTypeDefn0, !SubTypeCtorsTypeDefns)
+ )
;
% XXX TYPE_REPN Enter type equivalences into ComponentTypeMap.
( Body0 = hlds_eqv_type(_)
; Body0 = hlds_solver_type(_)
),
% There are no questions of representation to figure out.
- TypeCtorTypeDefn = TypeCtorTypeDefn0
+ cons(TypeCtorTypeDefn0, !NonSubTypeCtorTypeDefns)
).
%---------------------%
@@ -614,11 +656,201 @@ add_abstract_if_packable(TypeCtor, AbstractDetails, !ComponentTypeMap) :-
AbstractDetails = abstract_dummy_type,
ComponentKind = packable(packable_dummy),
map.det_insert(TypeCtor, ComponentKind, !ComponentTypeMap)
+ ;
+ AbstractDetails = abstract_notag_type,
+ % XXX Enter information into NoTagTypeMap?
+ % We do not yet generate "where type_is_abstract_notag_type" so I think
+ % this is unreachable. The `where' block mechanism, along with this
+ % module (du_type_layout.m) are intended to be replaced by the
+ % `:- type_representation' mechanism anyway.
+ sorry($pred, "abstract_notag_type")
+ ;
+ ( AbstractDetails = abstract_type_general
+ ; AbstractDetails = abstract_subtype(_)
+ ; AbstractDetails = abstract_solver_type
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+%
+% Pass 1b.
+%
+
+ % After deciding the representation of simple du types, transfer
+ % information in component_type_map and no_tag_type_table to
+ % any subtypes of those simple du types.
+ %
+:- pred add_if_subtype_of_simple_du_type_to_maps(type_table::in,
+ pair(type_ctor, hlds_type_defn)::in,
+ component_type_map::in, component_type_map::out,
+ no_tag_type_table::in, no_tag_type_table::out) is det.
+
+add_if_subtype_of_simple_du_type_to_maps(OldTypeTable, TypeCtorTypeDefn,
+ !ComponentTypeMap, !NoTagTypeMap) :-
+ TypeCtorTypeDefn = TypeCtor - TypeDefn,
+ get_type_defn_body(TypeDefn, Body),
+ (
+ Body = hlds_du_type(Ctors, MaybeSuperType, _MaybeCanonical,
+ MaybeRepn, _MaybeForeign),
+ (
+ MaybeSuperType = yes(SuperType),
+ expect(unify(MaybeRepn, no), $pred, "MaybeRepn != no"),
+ ( if
+ type_to_ctor(SuperType, SuperTypeCtor),
+ get_base_type_ctor(OldTypeTable, SuperTypeCtor, BaseTypeCtor)
+ then
+ maybe_copy_component_kind_from_base(BaseTypeCtor, TypeCtor,
+ !ComponentTypeMap),
+ get_type_defn_tparams(TypeDefn, TypeParams),
+ maybe_copy_no_tag_type_from_base(BaseTypeCtor,
+ TypeCtor, TypeParams, yes(Ctors), !NoTagTypeMap)
+ else
+ true
+ )
+ ;
+ MaybeSuperType = no,
+ unexpected($pred, "not subtype")
+ )
+ ;
+ Body = hlds_abstract_type(AbstractDetails),
+ (
+ AbstractDetails = abstract_subtype(SuperTypeCtor),
+ ( if
+ get_base_type_ctor(OldTypeTable, SuperTypeCtor, BaseTypeCtor)
+ then
+ maybe_copy_component_kind_from_base(BaseTypeCtor, TypeCtor,
+ !ComponentTypeMap),
+ get_type_defn_tparams(TypeDefn, TypeParams),
+ maybe_copy_no_tag_type_from_base(BaseTypeCtor, TypeCtor,
+ TypeParams, no, !NoTagTypeMap)
+ else
+ true
+ )
;
( AbstractDetails = abstract_type_general
+ ; AbstractDetails = abstract_type_fits_in_n_bits(_)
+ ; AbstractDetails = abstract_dummy_type
; AbstractDetails = abstract_notag_type
; AbstractDetails = abstract_solver_type
+ ),
+ unexpected($pred, "not subtype")
)
+ ;
+ ( Body = hlds_foreign_type(_)
+ ; Body = hlds_eqv_type(_)
+ ; Body = hlds_solver_type(_)
+ ),
+ unexpected($pred, "not subtype")
+ ).
+
+:- pred get_base_type_ctor(type_table::in, type_ctor::in, type_ctor::out)
+ is semidet.
+
+get_base_type_ctor(TypeTable, TypeCtor, BaseTypeCtor) :-
+ set.init(Seen0),
+ get_base_type_ctor_loop(TypeTable, TypeCtor, BaseTypeCtor, Seen0).
+
+:- pred get_base_type_ctor_loop(type_table::in, type_ctor::in, type_ctor::out,
+ set(type_ctor)::in) is semidet.
+
+get_base_type_ctor_loop(TypeTable, TypeCtor, BaseTypeCtor, Seen0) :-
+ % Check for circularities.
+ set.insert_new(TypeCtor, Seen0, Seen1),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
+ get_type_defn_body(TypeDefn, TypeBody),
+ require_complete_switch [TypeBody]
+ (
+ TypeBody = hlds_du_type(_, MaybeSuperType, _, _, _),
+ (
+ MaybeSuperType = no,
+ BaseTypeCtor = TypeCtor
+ ;
+ MaybeSuperType = yes(SuperType),
+ type_to_ctor(SuperType, SuperTypeCtor),
+ get_base_type_ctor_loop(TypeTable, SuperTypeCtor, BaseTypeCtor,
+ Seen1)
+ )
+ ;
+ TypeBody = hlds_abstract_type(AbstractDetails),
+ require_complete_switch [AbstractDetails]
+ (
+ ( AbstractDetails = abstract_type_general
+ ; AbstractDetails = abstract_type_fits_in_n_bits(_)
+ ; AbstractDetails = abstract_dummy_type
+ ; AbstractDetails = abstract_notag_type
+ ),
+ BaseTypeCtor = TypeCtor
+ ;
+ AbstractDetails = abstract_subtype(SuperTypeCtor),
+ get_base_type_ctor_loop(TypeTable, SuperTypeCtor, BaseTypeCtor,
+ Seen1)
+ ;
+ AbstractDetails = abstract_solver_type,
+ unexpected($pred, "base type is abstract solver type")
+ )
+ ;
+ TypeBody = hlds_eqv_type(EqvType),
+ type_to_ctor(EqvType, EqvTypeCtor),
+ get_base_type_ctor_loop(TypeTable, EqvTypeCtor, BaseTypeCtor, Seen1)
+ ;
+ TypeBody = hlds_foreign_type(_),
+ unexpected($pred, "base type is foreign type")
+ ;
+ TypeBody = hlds_solver_type(_),
+ unexpected($pred, "base type is solver type")
+ ).
+
+:- pred maybe_copy_component_kind_from_base(type_ctor::in, type_ctor::in,
+ component_type_map::in, component_type_map::out) is det.
+
+maybe_copy_component_kind_from_base(BaseTypeCtor, TypeCtor,
+ !ComponentTypeMap) :-
+ ( if map.search(!.ComponentTypeMap, BaseTypeCtor, ComponentKind) then
+ map.det_insert(TypeCtor, ComponentKind, !ComponentTypeMap)
+ else
+ true
+ ).
+
+:- pred maybe_copy_no_tag_type_from_base(type_ctor::in,
+ type_ctor::in, list(type_param)::in, maybe(one_or_more(constructor))::in,
+ no_tag_type_table::in, no_tag_type_table::out) is det.
+
+maybe_copy_no_tag_type_from_base(BaseTypeCtor, TypeCtor, TypeParams0,
+ MaybeCtors, !NoTagTypeMap) :-
+ ( if map.search(!.NoTagTypeMap, BaseTypeCtor, BaseNoTagType) then
+ BaseNoTagType = no_tag_type(BaseTypeParams, BaseCtorName, BaseArgType),
+ (
+ MaybeCtors = no,
+ % A subtype must have the same constructor name as the base type,
+ % but possibly a different module name.
+ TypeCtor = type_ctor(TypeCtorSymName, _TypeCtorArity),
+ det_sym_name_get_module_name(TypeCtorSymName, ModuleName),
+ UnqualCtorName = unqualify_name(BaseCtorName),
+ CtorName = qualified(ModuleName, UnqualCtorName),
+ % We do not have the actual argument type in the abstract subtype
+ % so just use the argument type from the base type.
+ TypeParams = BaseTypeParams,
+ ArgType = BaseArgType
+ ;
+ MaybeCtors = yes(Ctors),
+ Ctors = one_or_more(Ctor, TailCtors),
+ expect(unify(TailCtors, []), $pred,
+ "subtype of notag type has multiple ctors"),
+ Ctor = ctor(_Ordinal, _MaybeExist, CtorName, CtorArgs, _NumArgs,
+ _Context),
+ ( if CtorArgs = [CtorArgPrime] then
+ CtorArg = CtorArgPrime
+ else
+ unexpected($pred,
+ "subtype of notag type has wrong number of ctor args")
+ ),
+ CtorArg = ctor_arg(_MaybeFieldName, ArgType, _ArgContext),
+ TypeParams = TypeParams0
+ ),
+ NoTagType = no_tag_type(TypeParams, CtorName, ArgType),
+ map.det_insert(TypeCtor, NoTagType, !NoTagTypeMap)
+ else
+ true
).
%---------------------------------------------------------------------------%
@@ -637,9 +869,9 @@ decide_if_complex_du_type(ModuleInfo, Params, ComponentTypeMap,
TypeCtorTypeDefn0 = TypeCtor - TypeDefn0,
get_type_defn_body(TypeDefn0, Body0),
(
- % XXX SUBTYPE Type representation of subtype depends on base type.
- Body0 = hlds_du_type(Ctors, _MaybeSuperType, _MaybeCanonical,
+ Body0 = hlds_du_type(Ctors, MaybeSuperType, _MaybeCanonical,
MaybeRepn0, _MaybeForeign),
+ expect(unify(MaybeSuperType, no), $pred, "subtype not separated out"),
(
MaybeRepn0 = yes(_),
% We have already decided this type's representation
@@ -1425,6 +1657,7 @@ may_pack_arg_type(Params, ComponentTypeMap, ArgType, PackableKind) :-
% XXX ARG_PACK Make this code dereference eqv types,
% subject to all types involved having the same visibility.
type_to_ctor(ArgType, ArgTypeCtor),
+
( if map.search(ComponentTypeMap, ArgTypeCtor, ComponentKind) then
ComponentKind = packable(PackableKind),
(
@@ -1875,6 +2108,205 @@ take_local_packable_functors_constant_sectag_bits(ArgPackBits,
NonPackedFunctors = [PackableFunctor | PackableFunctors]
).
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+%
+% Pass 2b.
+%
+
+ % After deciding the representation of simple and complex du types,
+ % use that to derive the representation of subtypes.
+ %
+:- pred decide_if_subtype(type_table::in,
+ assoc_list(type_ctor, hlds_type_defn)::in,
+ pair(type_ctor, hlds_type_defn)::in, pair(type_ctor, hlds_type_defn)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+decide_if_subtype(OldTypeTable, NonSubTypeCtorsTypeDefns,
+ TypeCtorTypeDefn0, TypeCtorTypeDefn, !Specs) :-
+ TypeCtorTypeDefn0 = TypeCtor - TypeDefn0,
+ get_type_defn_body(TypeDefn0, Body0),
+ (
+ Body0 = hlds_du_type(Ctors, MaybeSuperType, _MaybeCanonical,
+ MaybeRepn0, _MaybeForeign),
+ (
+ MaybeSuperType = yes(SuperType),
+ expect(unify(MaybeRepn0, no), $pred,
+ "type representation already decided for subtype"),
+ ( if
+ type_to_ctor(SuperType, SuperTypeCtor),
+ get_base_type_ctor(OldTypeTable, SuperTypeCtor, BaseTypeCtor),
+ search_du_type_repn(NonSubTypeCtorsTypeDefns,
+ BaseTypeCtor, BaseRepn)
+ then
+ make_subtype_type_repn(TypeCtor, Ctors, BaseRepn, Repn),
+ Body = Body0 ^ du_type_repn := yes(Repn),
+ set_type_defn_body(Body, TypeDefn0, TypeDefn),
+ TypeCtorTypeDefn = TypeCtor - TypeDefn
+ else
+ unexpected($pred, "missing base type representation")
+ )
+ ;
+ MaybeSuperType = no,
+ unexpected($pred, "not subtype")
+ )
+ ;
+ Body0 = hlds_abstract_type(AbstractDetails),
+ (
+ AbstractDetails = abstract_subtype(_),
+ TypeCtorTypeDefn = TypeCtorTypeDefn0
+ ;
+ ( AbstractDetails = abstract_type_fits_in_n_bits(_)
+ ; AbstractDetails = abstract_dummy_type
+ ; AbstractDetails = abstract_notag_type
+ ; AbstractDetails = abstract_type_general
+ ; AbstractDetails = abstract_solver_type
+ ),
+ unexpected($pred, "not subtype")
+ )
+ ;
+ ( Body0 = hlds_foreign_type(_)
+ ; Body0 = hlds_eqv_type(_)
+ ; Body0 = hlds_solver_type(_)
+ ),
+ unexpected($pred, "not subtype")
+ ).
+
+:- pred search_du_type_repn(assoc_list(type_ctor, hlds_type_defn)::in,
+ type_ctor::in, du_type_repn::out) is semidet.
+
+search_du_type_repn(TypeDefns, TypeCtor, DuTypeRepn) :-
+ assoc_list.search(TypeDefns, TypeCtor, TypeRepn),
+ get_type_defn_body(TypeRepn, TypeBody),
+ TypeBody ^ du_type_repn = yes(DuTypeRepn).
+
+:- pred make_subtype_type_repn(type_ctor::in, one_or_more(constructor)::in,
+ du_type_repn::in, du_type_repn::out) is det.
+
+make_subtype_type_repn(TypeCtor, OoMCtors, BaseRepn, Repn) :-
+ BaseRepn = du_type_repn(BaseCtorRepns, _BaseCtorRepnMap,
+ _BaseCheaperTagTest, BaseDuTypeKind, MaybeBaseDirectArgFunctors),
+
+ Ctors = one_or_more_to_list(OoMCtors),
+ list.map_foldl(make_subtype_ctor_repn(BaseCtorRepns),
+ Ctors, CtorRepns, map.init, CtorRepnMap),
+
+ compute_cheaper_tag_test(TypeCtor, CtorRepns, CheaperTagTest),
+
+ (
+ BaseDuTypeKind = du_type_kind_mercury_enum,
+ % The subtype must be an enum even if it has only one constructor as
+ % the term may be upcast. This breaks an assumption for non-subtypes.
+ DuTypeKind = du_type_kind_mercury_enum
+ ;
+ BaseDuTypeKind = du_type_kind_foreign_enum(_),
+ unexpected($pred, "du_type_kind_foreign_enum")
+ ;
+ BaseDuTypeKind = du_type_kind_direct_dummy,
+ DuTypeKind = du_type_kind_direct_dummy
+ ;
+ BaseDuTypeKind = du_type_kind_notag(SingleFunctorName, _BaseArgType,
+ _MaybeBaseArgName),
+ ( if
+ CtorRepns = [SingleCtorRepn],
+ SingleCtorRepn = ctor_repn(_Ordinal, _MaybeExist,
+ SingleFunctorName, _ConsTag, [SingleArgRepn], 1, _Context)
+ then
+ SingleArgRepn = ctor_arg_repn(MaybeSingleArgFieldName,
+ SingleArgType, _SingleArgPosWidth, _SingleArgContext),
+ (
+ MaybeSingleArgFieldName = no,
+ MaybeSingleArgName = no
+ ;
+ MaybeSingleArgFieldName =
+ yes(ctor_field_name(SingleArgSymName, _FieldContext)),
+ MaybeSingleArgName = yes(unqualify_name(SingleArgSymName))
+ ),
+ DuTypeKind = du_type_kind_notag(SingleFunctorName, SingleArgType,
+ MaybeSingleArgName)
+ else
+ unexpected($pred, "wrong ctor for notag subtype")
+ )
+ ;
+ BaseDuTypeKind = du_type_kind_general,
+ DuTypeKind = du_type_kind_general
+ ),
+
+ (
+ MaybeBaseDirectArgFunctors = no,
+ MaybeDirectArgFunctors = no
+ ;
+ MaybeBaseDirectArgFunctors = yes(BaseDirectArgFunctors),
+ list.filter(has_matching_constructor(Ctors),
+ BaseDirectArgFunctors, DirectArgFunctors),
+ MaybeDirectArgFunctors = yes(DirectArgFunctors)
+ ),
+
+ Repn = du_type_repn(CtorRepns, CtorRepnMap, CheaperTagTest, DuTypeKind,
+ MaybeDirectArgFunctors).
+
+:- pred make_subtype_ctor_repn(list(constructor_repn)::in,
+ constructor::in, constructor_repn::out,
+ ctor_name_to_repn_map::in, ctor_name_to_repn_map::out) is det.
+
+make_subtype_ctor_repn(BaseCtorRepns, Ctor, CtorRepn, !CtorRepnMap) :-
+ Ctor = ctor(Ordinal, MaybeExistConstraints, CtorName, CtorArgs, CtorArity,
+ Context),
+ UnqualCtorName = unqualify_name(CtorName),
+ ( if
+ search_ctor_repn_by_unqual_name(BaseCtorRepns, UnqualCtorName,
+ CtorArity, BaseCtorRepn)
+ then
+ BaseCtorRepn = ctor_repn(_BaseOrdinal, _BaseMaybeExistConstraints,
+ _BaseCtorName, BaseCtorTag, BaseCtorArgRepns, _BaseCtorArity,
+ _BaseContext),
+ CtorTag = BaseCtorTag,
+ list.map_corresponding(make_subtype_constructor_arg_repn,
+ CtorArgs, BaseCtorArgRepns, CtorArgRepns),
+ CtorRepn = ctor_repn(Ordinal, MaybeExistConstraints, CtorName,
+ CtorTag, CtorArgRepns, CtorArity, Context),
+ insert_ctor_repn_into_map(CtorRepn, !CtorRepnMap)
+ else
+ unexpected($pred, "missing base ctor type repn")
+ ).
+
+:- pred search_ctor_repn_by_unqual_name(list(constructor_repn)::in,
+ string::in, int::in, constructor_repn::out) is semidet.
+
+search_ctor_repn_by_unqual_name([CtorRepn | CtorRepns], UnqualName, Arity,
+ MatchingCtorRepn) :-
+ ( if
+ unqualify_name(CtorRepn ^ cr_name) = UnqualName,
+ CtorRepn ^ cr_num_args = Arity
+ then
+ MatchingCtorRepn = CtorRepn
+ else
+ search_ctor_repn_by_unqual_name(CtorRepns, UnqualName, Arity,
+ MatchingCtorRepn)
+ ).
+
+:- pred make_subtype_constructor_arg_repn(constructor_arg::in,
+ constructor_arg_repn::in, constructor_arg_repn::out) is det.
+
+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).
+
+:- pred has_matching_constructor(list(constructor)::in, sym_name_arity::in)
+ is semidet.
+
+has_matching_constructor(Ctors, SymNameArity) :-
+ list.any_true(is_matching_constructor(SymNameArity), Ctors).
+
+:- pred is_matching_constructor(sym_name_arity::in, constructor::in)
+ is semidet.
+
+is_matching_constructor(SymNameArity, Ctor) :-
+ SymNameArity = sym_name_arity(SymName, Arity),
+ Ctor = ctor(_Ordinal, _MaybeExist, SymName, _Args, Arity, _Context).
+
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
%
@@ -1932,7 +2364,6 @@ is_direct_arg_ctor(ComponentTypeMap, TypeCtorModule, TypeStatus,
% (mercury_deep_copy_body.h), and maybe during some other
% operations.
- % XXX SUBTYPE Type representation of subtype depends on base type.
get_type_defn_body(ArgTypeDefn, ArgTypeDefnBody),
ArgTypeDefnBody = hlds_du_type(_ArgCtors, _ArgMaybeSuperType,
_ArgMaybeUserEqComp, _ArgMaybeRepn, ArgMaybeForeign),
diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m
index 96ccc8764..0968e0934 100644
--- a/compiler/equiv_type.m
+++ b/compiler/equiv_type.m
@@ -2,6 +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.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -161,13 +162,14 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.prog_mode.
-:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
+:- import_module parse_tree.prog_util.
:- import_module assoc_list.
:- import_module bool.
@@ -1124,6 +1126,28 @@ replace_in_type_repn_info(ModuleName, MaybeRecord, TypeEqvMap,
CircTypes = []
),
TypeRepn = tcrepn_is_eqv_to(Type)
+ ;
+ TypeRepn0 = tcrepn_is_subtype_of(SuperTypeCtor0),
+ % Construct a type from the type ctor, substituting 'void' for any type
+ % parameters, so that we can call replace_in_type_maybe_record_use_2.
+ % We do not care about the type arguments so we can drop them again
+ % afterwards.
+ SuperTypeCtor0 = type_ctor(_, SuperTypeCtorArity),
+ list.duplicate(SuperTypeCtorArity, void_type, VoidTypes),
+ construct_type(SuperTypeCtor0, VoidTypes, SuperType0),
+ TypeCtor = type_ctor(SymName, Arity),
+ replace_in_type_maybe_record_use_2(MaybeRecord, TypeEqvMap, [TypeCtor],
+ SuperType0, SuperType, _, Circ, TVarSet0, TVarSet,
+ UsedTypeCtors0, UsedTypeCtors, !UsedModules),
+ type_to_ctor_det(SuperType, SuperTypeCtor),
+ set.to_sorted_list(Circ, CircTypes),
+ (
+ CircTypes = [_ | _],
+ !:Specs = [report_circular_eqv_type(TypeCtor, Context) | !.Specs]
+ ;
+ CircTypes = []
+ ),
+ TypeRepn = tcrepn_is_subtype_of(SuperTypeCtor)
;
( TypeRepn0 = tcrepn_is_word_aligned_ptr
; TypeRepn0 = tcrepn_du(_)
diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m
index 7e533d92d..2824479f1 100644
--- a/compiler/module_qual.qualify_items.m
+++ b/compiler/module_qual.qualify_items.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2021 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.
%---------------------------------------------------------------------------%
@@ -560,6 +560,14 @@ module_qualify_item_type_repn(ModuleName, InInt,
ErrorContext = mqec_type_repn(Context, TypeCtor),
qualify_type(InInt, ErrorContext, EqvType0, EqvType, !Info, !Specs),
RepInfo = tcrepn_is_eqv_to(EqvType)
+ ;
+ RepInfo0 = tcrepn_is_subtype_of(SuperTypeCtor0),
+ list.length(ArgTVars, TypeCtorArity),
+ TypeCtor = type_ctor(TypeCtorSymName, TypeCtorArity),
+ ErrorContext = mqec_type_repn(Context, TypeCtor),
+ qualify_type_ctor(InInt, ErrorContext, SuperTypeCtor0, SuperTypeCtor,
+ !Info, !Specs),
+ RepInfo = tcrepn_is_subtype_of(SuperTypeCtor)
),
ItemTypeRepnInfo = item_type_repn_info(TypeCtorSymName, ArgTVars,
RepInfo, TVarSet, Context, SeqNum).
diff --git a/compiler/opt_debug.m b/compiler/opt_debug.m
index 20d1e7c0e..ad287e984 100644
--- a/compiler/opt_debug.m
+++ b/compiler/opt_debug.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
-% Copyright (C) 2013-2018 The Mercury team.
+% Copyright (C) 2013-2021 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.
%-----------------------------------------------------------------------------%
@@ -590,8 +590,8 @@ dump_rtti_name(RttiName) = Str :-
RttiName = type_ctor_enum_name_ordered_table,
Str = "enum_name_ordered_table"
;
- RttiName = type_ctor_enum_value_ordered_table,
- Str = "enum_value_ordered_table"
+ RttiName = type_ctor_enum_ordinal_ordered_table,
+ Str = "enum_ordinal_ordered_table"
;
RttiName = type_ctor_foreign_enum_name_ordered_table,
Str = "foreign_enum_name_ordered_table"
diff --git a/compiler/parse_tree_out.m b/compiler/parse_tree_out.m
index 13c7f4bfd..5f3b8b153 100644
--- a/compiler/parse_tree_out.m
+++ b/compiler/parse_tree_out.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2021 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.
%---------------------------------------------------------------------------%
@@ -1292,6 +1292,7 @@ mercury_output_item_type_defn(Info, Stream, ItemTypeDefn, !IO) :-
; DetailsAbstract = abstract_dummy_type
; DetailsAbstract = abstract_notag_type
; DetailsAbstract = abstract_type_fits_in_n_bits(_)
+ ; DetailsAbstract = abstract_subtype(_)
),
IsSolverType = non_solver_type
;
@@ -1314,6 +1315,9 @@ mercury_output_item_type_defn(Info, Stream, ItemTypeDefn, !IO) :-
% XXX TYPE_REPN The same concern applies here, but these
% kinds of abstract types are not yet generated anywhere,
% so we don't have anything to do for them.
+ ;
+ DetailsAbstract = abstract_subtype(SuperTypeCtor),
+ mercury_output_where_abstract_subtype(Stream, SuperTypeCtor, !IO)
;
( DetailsAbstract = abstract_type_general
; DetailsAbstract = abstract_solver_type
@@ -1560,6 +1564,18 @@ mercury_output_where_abstract_enum_type(Stream, NumBits, !IO) :-
io.write_int(Stream, NumBits, !IO),
io.write_string(Stream, ")", !IO).
+:- pred mercury_output_where_abstract_subtype(io.text_output_stream::in,
+ type_ctor::in, io::di, io::uo) is det.
+
+mercury_output_where_abstract_subtype(Stream, TypeCtor, !IO) :-
+ io.write_string(Stream, "\n\twhere\t", !IO),
+ io.write_string(Stream, "type_is_abstract_subtype(", !IO),
+ TypeCtor = type_ctor(SymName, Arity),
+ mercury_output_sym_name(SymName, Stream, !IO),
+ io.write_string(Stream, "/", !IO),
+ io.write_int(Stream, Arity, !IO),
+ io.write_string(Stream, ")", !IO).
+
%---------------------%
%
% Predicates needed to output discriminated union types.
diff --git a/compiler/parse_tree_out_type_repn.m b/compiler/parse_tree_out_type_repn.m
index 12006be10..837a395b3 100644
--- a/compiler/parse_tree_out_type_repn.m
+++ b/compiler/parse_tree_out_type_repn.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015, 2020-2021 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.
%---------------------------------------------------------------------------%
@@ -84,6 +84,14 @@ mercury_output_item_type_repn(Info, Stream, ItemTypeRepn, !IO) :-
io.write_string(Stream, " is_eqv_to(", !IO),
mercury_output_type(TVarSet, print_num_only, EqvType, Stream, !IO),
io.write_string(Stream, ")", !IO)
+ ;
+ RepnInfo = tcrepn_is_subtype_of(SuperTypeCtor),
+ io.write_string(Stream, " is_subtype_of(", !IO),
+ SuperTypeCtor = type_ctor(SuperTypeCtorSymName, SuperTypeArity),
+ mercury_output_sym_name(SuperTypeCtorSymName, Stream, !IO),
+ io.write_string(Stream, "/", !IO),
+ io.write_int(Stream, SuperTypeArity, !IO),
+ io.write_string(Stream, ")", !IO)
;
RepnInfo = tcrepn_is_word_aligned_ptr,
io.write_string(Stream, " is_word_aligned_ptr", !IO)
diff --git a/compiler/parse_type_defn.m b/compiler/parse_type_defn.m
index 87e8adb55..40001c61f 100644
--- a/compiler/parse_type_defn.m
+++ b/compiler/parse_type_defn.m
@@ -2,6 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------e
% Copyright (C) 2008-2011 The University of Melbourne.
+% Copyright (C) 2016-2021 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.
%---------------------------------------------------------------------------%
@@ -798,8 +799,9 @@ parse_eqv_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Context, SeqNum,
% This can be
%
% - an abstract enumeration type,
- % - an abstract dummy type,
- % - an abstract notag type, or
+ % - an abstract dummy type (NYI),
+ % - an abstract notag type (NYI),
+ % - an abstract subtype, or
% - a solver type.
%
:- pred parse_where_block_type_defn(module_name::in, varset::in, term::in,
@@ -876,6 +878,30 @@ parse_where_type_is_abstract(ModuleName, VarSet, HeadTerm, BodyTerm,
phase_term_to_parse_tree, Context, Pieces),
MaybeTypeDefn = error1([Spec])
)
+ else if
+ BodyTerm = term.functor(term.atom(AttrName), Args, _),
+ AttrName = "type_is_abstract_subtype"
+ then
+ ( if Args = [Arg] then
+ ( if parse_unqualified_name_and_arity(Arg, SymName, Arity) then
+ TypeCtor = type_ctor(SymName, Arity),
+ TypeDefn0 = parse_tree_abstract_type(
+ abstract_subtype(TypeCtor)),
+ MaybeTypeDefn = ok1(TypeDefn0)
+ else
+ Pieces = [words("Error: the argument of"), quote(AttrName),
+ words("is not a symbol name and arity."), nl],
+ Spec = simplest_spec($pred, severity_error,
+ phase_term_to_parse_tree, Context, Pieces),
+ MaybeTypeDefn = error1([Spec])
+ )
+ else
+ Pieces = [words("Error:"), quote(AttrName),
+ words("should have exactly one argument."), nl],
+ Spec = simplest_spec($pred, severity_error,
+ phase_term_to_parse_tree, Context, Pieces),
+ MaybeTypeDefn = error1([Spec])
+ )
else
Pieces = [words("Error: invalid"), quote("where ..."),
words("attribute for abstract non-solver type."), nl],
diff --git a/compiler/parse_type_repn.m b/compiler/parse_type_repn.m
index 509bcdea2..e6ae3d517 100644
--- a/compiler/parse_type_repn.m
+++ b/compiler/parse_type_repn.m
@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------e
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------e
-% Copyright (C) 2017 The Mercury team.
+% Copyright (C) 2017-2021 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.
%---------------------------------------------------------------------------%
@@ -68,6 +68,7 @@ parse_type_repn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
( if
RepnTerm = term.functor(term.atom(AtomStr), RepnArgs, RepnContext),
( AtomStr = "is_eqv_to"
+ ; AtomStr = "is_subtype_of"
; AtomStr = "is_word_aligned_ptr"
; AtomStr = "du_repn"
; AtomStr = "foreign_type_repn"
@@ -77,6 +78,10 @@ parse_type_repn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
AtomStr = "is_eqv_to",
parse_type_repn_eqv_to(VarSet, AtomStr, RepnArgs,
RepnContext, MaybeRepn)
+ ;
+ AtomStr = "is_subtype_of",
+ parse_type_repn_subtype_of(AtomStr, RepnArgs, RepnContext,
+ MaybeRepn)
;
AtomStr = "is_word_aligned_ptr",
parse_no_arg_type_repn(AtomStr, RepnArgs, RepnContext,
@@ -119,6 +124,7 @@ parse_type_repn_item(ModuleName, VarSet, ArgTerms, Context, SeqNum,
quote("is_direct_dummy"), suffix(","),
quote("is_notag"), suffix(","),
quote("is_eqv_to"), suffix(","),
+ quote("is_subtype_of"), suffix(","),
quote("fits_in_n_bits"), suffix(","),
quote("is_word_aligned_ptr"), suffix(","),
quote("has_direct_arg_functors"), suffix(","),
@@ -209,6 +215,36 @@ parse_type_repn_eqv_to(VarSet, RepnStr, RepnArgs, RepnContext, MaybeRepn) :-
%-----------------------------------------------------------------------------e
+:- pred parse_type_repn_subtype_of(string::in, list(term)::in,
+ term.context::in, maybe1(type_ctor_repn_info)::out) is det.
+
+parse_type_repn_subtype_of(RepnStr, RepnArgs, RepnContext, MaybeRepn) :-
+ (
+ RepnArgs = [RepnArg],
+ ( if parse_unqualified_name_and_arity(RepnArg, SymName, Arity) then
+ SuperTypeCtor = type_ctor(SymName, Arity),
+ MaybeRepn = ok1(tcrepn_is_subtype_of(SuperTypeCtor))
+ else
+ Pieces = [words("Error:"), quote(RepnStr),
+ words("should have one argument, a symbol name and arity."),
+ nl],
+ Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
+ RepnContext, Pieces),
+ MaybeRepn = error1([Spec])
+ )
+ ;
+ ( RepnArgs = []
+ ; RepnArgs = [_, _ | _]
+ ),
+ Pieces = [words("Error:"), quote(RepnStr),
+ words("should have one argument, a type."), nl],
+ Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
+ RepnContext, Pieces),
+ MaybeRepn = error1([Spec])
+ ).
+
+%-----------------------------------------------------------------------------e
+
:- pred parse_type_repn_du(varset::in, term::in, maybe1(du_repn)::out) is det.
parse_type_repn_du(VarSet, Term, MaybeDuRepn) :-
diff --git a/compiler/parse_util.m b/compiler/parse_util.m
index 693bb0c20..42d2a3ff6 100644
--- a/compiler/parse_util.m
+++ b/compiler/parse_util.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2012 The University of Melbourne.
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2021 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.
%---------------------------------------------------------------------------%
@@ -197,9 +197,9 @@ parse_implicitly_qualified_name_and_arity(ModuleName, PredAndArityTerm,
PredNameTerm, SymName),
decimal_term_to_int(ArityTerm, Arity).
-parse_unqualified_name_and_arity(PredAndArityTerm, SymName, Arity) :-
+parse_unqualified_name_and_arity(Term, SymName, Arity) :-
parse_implicitly_qualified_name_and_arity(unqualified(""),
- PredAndArityTerm, SymName, Arity).
+ Term, SymName, Arity).
parse_pred_or_func_name_and_arity(PorFPredAndArityTerm,
PredOrFunc, SymName, Arity) :-
diff --git a/compiler/prog_data.m b/compiler/prog_data.m
index c63db3e53..f51eb9b10 100644
--- a/compiler/prog_data.m
+++ b/compiler/prog_data.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2012 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%---------------------------------------------------------------------------%
@@ -354,6 +354,9 @@ cons_id_is_const_struct(ConsId, ConstNum) :-
; abstract_notag_type
% The abstract type is a no_tag type.
+ ; abstract_subtype(type_ctor)
+ % The abstract type is a subtype of this super type ctor.
+
; abstract_solver_type.
% An abstract solver type.
@@ -435,8 +438,8 @@ cons_id_is_const_struct(ConsId, ConstNum) :-
---> ctor(
% The ordinal number of the functor. The first functor
% in a type definition has ordinal number 0.
- % XXX SUBTYPE For subtypes, the ordinal number needs to be
- % retrieved from the base type.
+ % A subtype's functors are numbered independently
+ % from its supertypes and base type.
cons_ordinal :: uint32,
% Existential constraints, if any.
diff --git a/compiler/prog_item.m b/compiler/prog_item.m
index f165d6315..3eceee23d 100644
--- a/compiler/prog_item.m
+++ b/compiler/prog_item.m
@@ -2,6 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2011 The University of Melbourne.
+% Copyright (C) 2014-2021 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.
%---------------------------------------------------------------------------%
@@ -1629,6 +1630,8 @@
:- type item_type_repn_info_eqv
== item_type_repn_info_general(mer_type).
+:- type item_type_repn_info_subtype
+ == item_type_repn_info_general(type_ctor).
:- type item_type_repn_info
== item_type_repn_info_general(type_ctor_repn_info).
@@ -1935,6 +1938,7 @@
:- type type_ctor_repn_info
---> tcrepn_is_word_aligned_ptr
; tcrepn_is_eqv_to(mer_type)
+ ; tcrepn_is_subtype_of(type_ctor)
; tcrepn_du(du_repn)
; tcrepn_foreign(c_j_cs_repn).
@@ -2016,7 +2020,7 @@
:- type enum_repn
---> enum_repn(
% The type is an enum type that satisfies the requirements
- % of du_type_is_enum.
+ % of non_sub_du_type_is_enum.
% The list of the functor names (all arity 0). We store
% the first two separately to enforce the structural invariant
diff --git a/compiler/prog_type.m b/compiler/prog_type.m
index d6d30ae76..40f5538da 100644
--- a/compiler/prog_type.m
+++ b/compiler/prog_type.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2005-2012 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%-----------------------------------------------------------------------------%
@@ -341,26 +341,26 @@
%
:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
- % Is the discriminated union type with the given list of constructors
- % a notag type?
+ % Is the discriminated union type (not a subtype) with the given list of
+ % constructors a notag type?
%
-:- pred du_type_is_notag(one_or_more(constructor)::in, maybe_canonical::in)
- is semidet.
+:- pred non_sub_du_type_is_notag(one_or_more(constructor)::in,
+ maybe_canonical::in) is semidet.
- % Is the discriminated union type with the given list of constructors
- % an enum? Is yes, return the number of enum values.
+ % Is the discriminated union type (not a subtype) with the given list of
+ % constructors an enum? If yes, return the number of enum values.
%
-:- pred du_type_is_enum(type_details_du::in, int::out) is semidet.
+:- pred non_sub_du_type_is_enum(type_details_du::in, int::out) is semidet.
% Return the number of bits required to represent
- % the given number of values.
+ % the given number of values, 0 to n-1.
%
-:- pred num_bits_needed_for_n_values(int::in, int::out) is det.
+:- pred num_bits_needed_for_n_dense_values(int::in, int::out) is det.
- % Is the discriminated union type with the given list of constructors
- % a dummy type?
+ % Is the discriminated union type (not a subtype) with the given list of
+ % constructors a dummy type?
%
-:- pred du_type_is_dummy(type_details_du::in) is semidet.
+:- pred non_sub_du_type_is_dummy(type_details_du::in) is semidet.
% Unify (with occurs check) two types with respect to a type substitution
% and update the type bindings. The third argument is a list of type
@@ -998,40 +998,42 @@ name_is_type_info("base_typeclass_info").
%-----------------------------------------------------------------------------%
-du_type_is_notag(OoMCtors, MaybeCanonical) :-
+non_sub_du_type_is_notag(OoMCtors, MaybeCanonical) :-
OoMCtors = one_or_more(Ctor, []),
Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [_CtorArg], 1,
_Context),
MaybeExistConstraints = no_exist_constraints,
MaybeCanonical = canon.
-du_type_is_enum(DuDetails, NumFunctors) :-
- % XXX SUBTYPE Whether a subtype is an enum depends on the base type.
- DuDetails = type_details_du(_MaybeSuperType, OoMCtors, _MaybeCanonical,
+non_sub_du_type_is_enum(DuDetails, NumFunctors) :-
+ DuDetails = type_details_du(MaybeSuperType, OoMCtors, _MaybeCanonical,
_MaybeDirectArgCtors),
+ expect(unify(MaybeSuperType, no), $pred,
+ "cannot determine if subtype is enum"),
Ctors = one_or_more_to_list(OoMCtors),
Ctors = [_, _ | _],
- all_functors_are_enum(Ctors, 0, NumFunctors).
+ all_functors_are_constants(Ctors, 0, NumFunctors).
-num_bits_needed_for_n_values(NumValues, NumBits) :-
+num_bits_needed_for_n_dense_values(NumValues, NumBits) :-
int.log2(NumValues, NumBits).
-:- pred all_functors_are_enum(list(constructor)::in,
+:- pred all_functors_are_constants(list(constructor)::in,
int::in, int::out) is semidet.
-all_functors_are_enum([], !NumFunctors).
-all_functors_are_enum([Ctor | Ctors], !NumFunctors) :-
+all_functors_are_constants([], !NumFunctors).
+all_functors_are_constants([Ctor | Ctors], !NumFunctors) :-
Ctor = ctor(_Ordinal, MaybeExistConstraints, _Name, Args, _Arity,
_Context),
Args = [],
MaybeExistConstraints = no_exist_constraints,
!:NumFunctors = !.NumFunctors + 1,
- all_functors_are_enum(Ctors, !NumFunctors).
+ all_functors_are_constants(Ctors, !NumFunctors).
-du_type_is_dummy(DuDetails) :-
- % XXX SUBTYPE Whether a subtype is a dummy type depends on the base type.
- DuDetails = type_details_du(_MaybeSuperType, Ctors, MaybeCanonical,
+non_sub_du_type_is_dummy(DuDetails) :-
+ DuDetails = type_details_du(MaybeSuperType, Ctors, MaybeCanonical,
MaybeDirectArgCtors),
+ expect(unify(MaybeSuperType, no), $pred,
+ "cannot determine if subtype is dummy"),
Ctors = one_or_more(Ctor, []),
Ctor = ctor(_Ordinal, MaybeExistConstraints, _FunctorName, [], 0,
_Context),
diff --git a/compiler/rtti.m b/compiler/rtti.m
index a3c48e8e7..56ef24e9a 100644
--- a/compiler/rtti.m
+++ b/compiler/rtti.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2007, 2009-2011 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%-----------------------------------------------------------------------------%
@@ -135,7 +135,8 @@
%
:- type type_ctor_flag
---> variable_arity_flag
- ; kind_of_du_flag.
+ ; kind_of_du_flag
+ ; layout_indexable_flag.
% A type_ctor_details structure contains all the information that the
% runtime system needs to know about the data representation scheme
@@ -170,7 +171,7 @@
enum_axioms :: equality_axioms,
enum_is_dummy :: enum_maybe_dummy,
enum_functors :: list(enum_functor),
- enum_value_table :: map(uint32, enum_functor),
+ enum_ordinal_table :: map(uint32, enum_functor),
enum_name_table :: map(string, enum_functor),
enum_functor_number_mapping
:: list(uint32)
@@ -228,9 +229,13 @@
:- type enum_functor
---> enum_functor(
enum_name :: string,
- enum_ordinal :: uint32
+ enum_ordinal :: uint32,
+ enum_value :: enum_value
).
+:- type enum_value
+ ---> enum_value(uint32).
+
% Descriptor for a functor in a foreign enum type.
%
% This type corresponds to the C Type MR_ForeignEnumFunctorDesc.
@@ -320,10 +325,10 @@
% These tables let the runtime system interpret values in memory
% of general discriminated union types.
%
- % The runtime system should first use the primary tag to index into
+ % The runtime system should first use the primary tag to index/search into
% the type's ptag_map. It can then find the location (if any) of the
% secondary tag, and use the secondary tag (or zero if there isn't one)
- % to index into the stag_map to find the functor descriptor.
+ % to index/search into the stag_map to find the functor descriptor.
%
% The type sectag_table corresponds to the C type MR_DuPtagLayout.
% The two maps are implemented in C as simple arrays.
@@ -331,6 +336,15 @@
:- type ptag_map == map(ptag, sectag_table). % key is primary tag
:- type stag_map == map(uint, du_functor). % key is secondary tag
+ % Each of the following fields corresponds to one of the
+ % MR_DU_PTAG_FLAG_* macros in runtime/mercury_type_info.h.
+ % Their meanings are documented there.
+ %
+:- type du_ptag_layout_flags
+ ---> du_ptag_layout_flags(
+ sectag_alternatives_indexable :: bool
+ ).
+
:- type sectag_table
---> sectag_table(
sectag_locn :: sectag_locn,
@@ -370,7 +384,13 @@
du_arg_pos_width :: arg_pos_width
).
- % Information about subtypes in the arguments of a functor.
+ % Information about subtype constraints on the arguments of a functor
+ % due to inst information provided in the type definition. This is not
+ % related to the subtypes introduced by ':- type SUBTYPE =< SUPERTYPE'
+ % definitions.
+ %
+ % XXX rename this type and constants to avoid confusion with subtype
+ % type definitions
%
:- type functor_subtype_info
---> functor_subtype_none
@@ -624,7 +644,7 @@
; type_ctor_notag_functor_desc
; type_ctor_du_functor_desc(uint32) % functor ordinal
; type_ctor_enum_name_ordered_table
- ; type_ctor_enum_value_ordered_table
+ ; type_ctor_enum_ordinal_ordered_table
; type_ctor_foreign_enum_name_ordered_table
; type_ctor_foreign_enum_ordinal_ordered_table
; type_ctor_du_name_ordered_table
@@ -670,6 +690,8 @@
:- func encode_type_ctor_flags(set(type_ctor_flag)) = uint16.
+:- func encode_du_ptag_layout_flags(du_ptag_layout_flags) = uint8.
+
% Convert a rtti_data to an rtti_id.
% This calls error/1 if the argument is a type_var/1 rtti_data,
% since there is no rtti_id to return in that case.
@@ -762,7 +784,7 @@
target_prefixes::out, string::out)
is det.
- % Return the C representation of a functor's subtype info.
+ % Return the C representation of a functor's subtype constraints info.
%
:- pred functor_subtype_info_to_string(functor_subtype_info::in,
target_prefixes::out, string::out) is det.
@@ -983,6 +1005,21 @@ encode_type_ctor_flag(variable_arity_flag, !Encoding) :-
!:Encoding = !.Encoding + 2u16.
encode_type_ctor_flag(kind_of_du_flag, !Encoding) :-
!:Encoding = !.Encoding + 4u16.
+encode_type_ctor_flag(layout_indexable_flag, !Encoding) :-
+ !:Encoding = !.Encoding + 8u16.
+
+ % NOTE: the encoding here must match the one in
+ % runtime/mercury_type_info.h.
+ %
+encode_du_ptag_layout_flags(Flags) = Encoding :-
+ Flags = du_ptag_layout_flags(SectagAltsIndexable),
+ (
+ SectagAltsIndexable = yes,
+ Encoding = 1u8
+ ;
+ SectagAltsIndexable = no,
+ Encoding = 0u8
+ ).
rtti_data_to_id(RttiData, RttiId) :-
(
@@ -1086,7 +1123,7 @@ ctor_rtti_name_is_exported(CtorRttiName) = IsExported :-
; CtorRttiName = type_ctor_notag_functor_desc
; CtorRttiName = type_ctor_du_functor_desc(_)
; CtorRttiName = type_ctor_enum_name_ordered_table
- ; CtorRttiName = type_ctor_enum_value_ordered_table
+ ; CtorRttiName = type_ctor_enum_ordinal_ordered_table
; CtorRttiName = type_ctor_foreign_enum_name_ordered_table
; CtorRttiName = type_ctor_foreign_enum_ordinal_ordered_table
; CtorRttiName = type_ctor_du_name_ordered_table
@@ -1231,8 +1268,8 @@ name_to_string(RttiTypeCtor, RttiName) = Str :-
string.append_list([ModuleName, "__enum_name_ordered_",
TypeName, "_", A_str], Str)
;
- RttiName = type_ctor_enum_value_ordered_table,
- string.append_list([ModuleName, "__enum_value_ordered_",
+ RttiName = type_ctor_enum_ordinal_ordered_table,
+ string.append_list([ModuleName, "__enum_ordinal_ordered_",
TypeName, "_", A_str], Str)
;
RttiName = type_ctor_foreign_enum_name_ordered_table,
@@ -1826,7 +1863,7 @@ ctor_rtti_name_would_include_code_addr(RttiName) = InclCodeAddr :-
; RttiName = type_ctor_notag_functor_desc
; RttiName = type_ctor_du_functor_desc(_)
; RttiName = type_ctor_enum_name_ordered_table
- ; RttiName = type_ctor_enum_value_ordered_table
+ ; RttiName = type_ctor_enum_ordinal_ordered_table
; RttiName = type_ctor_foreign_enum_name_ordered_table
; RttiName = type_ctor_foreign_enum_ordinal_ordered_table
; RttiName = type_ctor_du_name_ordered_table
@@ -2090,7 +2127,7 @@ ctor_rtti_name_type(type_ctor_du_functor_desc(_),
"DuFunctorDesc", not_array).
ctor_rtti_name_type(type_ctor_enum_name_ordered_table,
"EnumFunctorDescPtr", is_array).
-ctor_rtti_name_type(type_ctor_enum_value_ordered_table,
+ctor_rtti_name_type(type_ctor_enum_ordinal_ordered_table,
"EnumFunctorDescPtr", is_array).
ctor_rtti_name_type(type_ctor_foreign_enum_name_ordered_table,
"ForeignEnumFunctorDescPtr", is_array).
diff --git a/compiler/rtti_out.m b/compiler/rtti_out.m
index 7a7407e63..667e38895 100644
--- a/compiler/rtti_out.m
+++ b/compiler/rtti_out.m
@@ -2,6 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2007, 2009-2011 The University of Melbourne.
+% Copyright (C) 2014-2021 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.
%-----------------------------------------------------------------------------%
@@ -902,16 +903,16 @@ output_type_ctor_details_defn(Info, Stream, RttiTypeCtor, TypeCtorDetails,
!DeclSet, !IO) :-
(
TypeCtorDetails = tcd_enum(_, _IsDummy, EnumFunctors,
- EnumByRep, EnumByName, FunctorNumberMap),
+ EnumByOrd, EnumByName, FunctorNumberMap),
list.foldl2(output_enum_functor_defn(Info, Stream, RttiTypeCtor),
EnumFunctors, !DeclSet, !IO),
- output_enum_value_ordered_table(Info, Stream, RttiTypeCtor, EnumByRep,
- !DeclSet, !IO),
+ output_enum_ordinal_ordered_table(Info, Stream, RttiTypeCtor,
+ EnumByOrd, !DeclSet, !IO),
output_enum_name_ordered_table(Info, Stream, RttiTypeCtor, EnumByName,
!DeclSet, !IO),
output_functor_number_map(Info, Stream, RttiTypeCtor, FunctorNumberMap,
!DeclSet, !IO),
- MaybeLayoutName = yes(type_ctor_enum_value_ordered_table),
+ MaybeLayoutName = yes(type_ctor_enum_ordinal_ordered_table),
MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
@@ -989,7 +990,7 @@ output_type_ctor_details_defn(Info, Stream, RttiTypeCtor, TypeCtorDetails,
output_enum_functor_defn(Info, Stream, RttiTypeCtor, EnumFunctor,
!DeclSet, !IO) :-
- EnumFunctor = enum_functor(FunctorName, Ordinal),
+ EnumFunctor = enum_functor(FunctorName, Ordinal, enum_value(Value)),
output_generic_rtti_data_defn_start(Info, Stream,
ctor_rtti_id(RttiTypeCtor, type_ctor_enum_functor_desc(Ordinal)),
!DeclSet, !IO),
@@ -997,8 +998,8 @@ output_enum_functor_defn(Info, Stream, RttiTypeCtor, EnumFunctor,
% MR_enum_functor_name
c_util.output_quoted_string(Stream, FunctorName, !IO),
io.write_string(Stream, """,\n\t", !IO),
- % MR_enum_functor_ordinal -- XXX MAKE_FIELD_UNSIGNED
- io.write_int32(Stream, int32.cast_from_uint32(Ordinal), !IO),
+ % MR_enum_functor_value -- XXX MAKE_FIELD_UNSIGNED
+ io.write_int32(Stream, int32.cast_from_uint32(Value), !IO),
io.write_string(Stream, "\n};\n", !IO).
:- pred output_foreign_enum_functor_defn(llds_out_info::in,
@@ -1465,17 +1466,17 @@ output_du_arg_locns_loop(Stream, [ArgInfo | ArgInfos], !IO) :-
%-----------------------------------------------------------------------------%
-:- pred output_enum_value_ordered_table(llds_out_info::in,
+:- pred output_enum_ordinal_ordered_table(llds_out_info::in,
io.text_output_stream::in, rtti_type_ctor::in,
map(uint32, enum_functor)::in,
decl_set::in, decl_set::out, io::di, io::uo) is det.
-output_enum_value_ordered_table(Info, Stream, RttiTypeCtor, FunctorMap,
+output_enum_ordinal_ordered_table(Info, Stream, RttiTypeCtor, FunctorMap,
!DeclSet, !IO) :-
Functors = map.values(FunctorMap),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
output_generic_rtti_data_defn_start(Info, Stream,
- ctor_rtti_id(RttiTypeCtor, type_ctor_enum_value_ordered_table),
+ ctor_rtti_id(RttiTypeCtor, type_ctor_enum_ordinal_ordered_table),
!DeclSet, !IO),
io.write_string(Stream, " = {\n", !IO),
output_addr_of_ctor_rtti_names(RttiTypeCtor, FunctorRttiNames,
@@ -1582,25 +1583,30 @@ output_du_ptag_ordered_table(Info, Stream, RttiTypeCtor, PtagMap,
ctor_rtti_id(RttiTypeCtor, type_ctor_du_ptag_ordered_table),
!DeclSet, !IO),
io.write_string(Stream, " = {\n", !IO),
- ( if PtagList = [ptag(0u8) - _ | _] then
- FirstPtag = ptag(0u8)
- else
+ (
+ PtagList = [FirstPtag - _ | _],
+ FirstPtag = ptag(LeastPtag)
+ ;
+ PtagList = [],
unexpected($pred, "bad ptag list")
),
output_du_ptag_ordered_table_body(Stream, RttiTypeCtor, PtagList,
- FirstPtag, !IO),
+ LeastPtag, !IO),
io.write_string(Stream, "\n};\n", !IO).
:- pred output_du_ptag_ordered_table_body(io.text_output_stream::in,
- rtti_type_ctor::in, assoc_list(ptag, sectag_table)::in, ptag::in,
+ rtti_type_ctor::in, assoc_list(ptag, sectag_table)::in, uint8::in,
io::di, io::uo) is det.
-output_du_ptag_ordered_table_body(_, _, [], _CurPtag, !IO).
+output_du_ptag_ordered_table_body(_, _, [], _, !IO).
output_du_ptag_ordered_table_body(Stream, RttiTypeCtor,
- [Ptag - SectagTable | PtagTail], CurPtag, !IO) :-
- expect(unify(Ptag, CurPtag), $pred, "ptag mismatch"),
+ [Ptag - SectagTable | PtagTail], LeastPtag, !IO) :-
+ Ptag = ptag(PtagUint8),
+ % ptags for a subtype may start higher than zero, and may skip values.
+ expect(LeastPtag =< PtagUint8, $pred, "ptag mismatch"),
SectagTable = sectag_table(SectagLocn, NumSectagBits, NumSharers,
_SectagMap),
+ compute_du_ptag_layout_flags(SectagTable, Flags),
io.write_string(Stream, "\t{ ", !IO),
% MR_sectag_sharers
io.write_uint32(Stream, NumSharers, !IO),
@@ -1615,16 +1621,21 @@ output_du_ptag_ordered_table_body(Stream, RttiTypeCtor,
io.write_string(Stream, ",\n\t", !IO),
% MR_sectag_numbits
io.write_int8(Stream, NumSectagBits, !IO),
+ io.write_string(Stream, ",\n\t", !IO),
+ % MR_du_ptag
+ io.write_uint8(Stream, PtagUint8, !IO),
+ io.write_string(Stream, ",\n\t", !IO),
+ % MR_du_ptag_flags
+ io.write_uint8(Stream, encode_du_ptag_layout_flags(Flags), !IO),
(
PtagTail = [],
io.write_string(Stream, " }\n", !IO)
;
PtagTail = [_ | _],
io.write_string(Stream, " },\n", !IO),
- CurPtag = ptag(CurPtagUint8),
- NextPtag = ptag(CurPtagUint8 + 1u8),
+ NextLeastPtag = PtagUint8 + 1u8,
output_du_ptag_ordered_table_body(Stream, RttiTypeCtor, PtagTail,
- NextPtag, !IO)
+ NextLeastPtag, !IO)
).
%-----------------------------------------------------------------------------%
diff --git a/compiler/rtti_to_mlds.m b/compiler/rtti_to_mlds.m
index 3dc4b4dd0..4bac15e9f 100644
--- a/compiler/rtti_to_mlds.m
+++ b/compiler/rtti_to_mlds.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2001-2012 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%-----------------------------------------------------------------------------%
@@ -639,16 +639,16 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
module_info_get_name(ModuleInfo, ModuleName),
(
TypeCtorDetails = tcd_enum(_, _IsDummy, EnumFunctors,
- EnumByValue, EnumByName, FunctorNumberMap),
+ EnumByOrd, EnumByName, FunctorNumberMap),
list.foldl(gen_enum_functor_desc(ModuleInfo, RttiTypeCtor),
EnumFunctors, !GlobalData),
- gen_enum_value_ordered_table(ModuleInfo, RttiTypeCtor,
- EnumByValue, !GlobalData),
+ gen_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
+ EnumByOrd, !GlobalData),
gen_enum_name_ordered_table(ModuleInfo, RttiTypeCtor,
EnumByName, !GlobalData),
gen_functor_number_map(RttiTypeCtor, FunctorNumberMap, !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_enum_value_ordered_table),
+ type_ctor_enum_ordinal_ordered_table),
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
@@ -723,14 +723,14 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
enum_functor::in, ml_global_data::in, ml_global_data::out) is det.
gen_enum_functor_desc(_ModuleInfo, RttiTypeCtor, EnumFunctor, !GlobalData) :-
- EnumFunctor = enum_functor(FunctorName, Ordinal),
+ EnumFunctor = enum_functor(FunctorName, Ordinal, enum_value(Value)),
RttiName = type_ctor_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_enum_functor_name
gen_init_string(FunctorName),
- % MR_enum_functor_ordinal -- XXX MAKE_FIELD_UNSIGNED
- gen_init_int32(int32.cast_from_uint32(Ordinal))
+ % MR_enum_functor_value -- XXX MAKE_FIELD_UNSIGNED
+ gen_init_int32(int32.cast_from_uint32(Value))
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
@@ -895,7 +895,7 @@ gen_du_functor_desc(ModuleInfo, Target, RttiTypeCtor, DuFunctor,
ArgLocnsInitializer, % MR_du_functor_arg_locns
ExistInfoInitializer, % MR_du_functor_exist_info
gen_init_functor_subtype_info(FunctorSubtypeInfo),
- % MR_du_functor_subtype
+ % MR_du_functor_subtype_constraints
gen_init_uint8(NumSectagBits) % MR_du_functor_num_sectag_bits
]),
rtti_id_and_init_to_defn(RttiId, Initializer, !GlobalData).
@@ -1142,18 +1142,18 @@ gen_field_locn(RttiId, ArgInfo, ArgLocnInitializer) :-
%-----------------------------------------------------------------------------%
-:- pred gen_enum_value_ordered_table(module_info::in, rtti_type_ctor::in,
+:- pred gen_enum_ordinal_ordered_table(module_info::in, rtti_type_ctor::in,
map(uint32, enum_functor)::in,
ml_global_data::in, ml_global_data::out) is det.
-gen_enum_value_ordered_table(ModuleInfo, RttiTypeCtor, EnumByValue,
+gen_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor, EnumByOrd,
!GlobalData) :-
- map.values(EnumByValue, Functors),
+ map.values(EnumByOrd, Functors),
module_info_get_name(ModuleInfo, ModuleName),
FunctorRttiNames = list.map(enum_functor_rtti_name, Functors),
Initializer = gen_init_rtti_names_array(ModuleName, RttiTypeCtor,
FunctorRttiNames),
- RttiName = type_ctor_enum_value_ordered_table,
+ RttiName = type_ctor_enum_ordinal_ordered_table,
rtti_name_and_init_to_defn(RttiTypeCtor, RttiName, Initializer,
!GlobalData).
@@ -1212,17 +1212,13 @@ gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, PtagMap, !GlobalData) :-
list.foldl(gen_du_stag_ordered_table(ModuleName, RttiTypeCtor), PtagList,
!GlobalData),
(
- PtagList = [],
- FirstPtag = ptag(0u8)
- ;
PtagList = [FirstPtag - _ | _],
- ( if FirstPtag = ptag(0u8) then
- true
- else
+ FirstPtag = ptag(LeastPtag)
+ ;
+ PtagList = [],
unexpected($pred, "bad ptag list")
- )
),
- gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, FirstPtag,
+ gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, LeastPtag,
PtagList, PtagInitializers),
RttiName = type_ctor_du_ptag_ordered_table,
Initializer = init_array(PtagInitializers),
@@ -1230,17 +1226,20 @@ gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor, PtagMap, !GlobalData) :-
!GlobalData).
:- pred gen_du_ptag_ordered_table_body(module_name::in, rtti_type_ctor::in,
- ptag::in, assoc_list(ptag, sectag_table)::in, list(mlds_initializer)::out)
+ uint8::in, assoc_list(ptag, sectag_table)::in, list(mlds_initializer)::out)
is det.
gen_du_ptag_ordered_table_body(_, _, _, [], []).
-gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, CurPtag,
+gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, LeastPtag,
[Ptag - SectagTable | PtagTail], [Initializer | Initializers]) :-
- expect(unify(Ptag, CurPtag), $pred, "ptag mismatch"),
+ Ptag = ptag(PtagUint8),
+ % ptags for a subtype may start higher than zero, and may skip values.
+ expect(LeastPtag =< PtagUint8, $pred, "ptag mismatch"),
SectagTable = sectag_table(SectagLocn, NumSectagBits, NumSharers,
_SectagMap),
RttiName = type_ctor_du_ptag_layout(Ptag),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
+ compute_du_ptag_layout_flags(SectagTable, Flags),
Initializer = init_struct(mlds_rtti_type(item_type(RttiId)), [
% MR_sectag_sharers
gen_init_uint32(NumSharers),
@@ -1250,11 +1249,14 @@ gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, CurPtag,
gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_stag_ordered_table(Ptag)),
% MR_sectag_numbits
- gen_init_int8(NumSectagBits)
+ gen_init_int8(NumSectagBits),
+ % MR_du_ptag,
+ gen_init_uint8(PtagUint8),
+ % MR_du_ptag_flags
+ gen_init_uint8(encode_du_ptag_layout_flags(Flags))
]),
- CurPtag = ptag(CurPtagUint8),
- NextPtag = ptag(CurPtagUint8 + 1u8),
- gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, NextPtag,
+ NextLeastPtag = PtagUint8 + 1u8,
+ gen_du_ptag_ordered_table_body(ModuleName, RttiTypeCtor, NextLeastPtag,
PtagTail, Initializers).
:- pred gen_du_stag_ordered_table(module_name::in, rtti_type_ctor::in,
@@ -1694,8 +1696,8 @@ gen_init_sectag_locn(Locn) = Initializer :-
:- func gen_init_functor_subtype_info(functor_subtype_info) = mlds_initializer.
-gen_init_functor_subtype_info(FunctorSubtypeInfo) = Initializer :-
- rtti.functor_subtype_info_to_string(FunctorSubtypeInfo, TargetPrefixes,
+gen_init_functor_subtype_info(Info) = Initializer :-
+ rtti.functor_subtype_info_to_string(Info, TargetPrefixes,
Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index 7eb88393a..a63a19e22 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-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%---------------------------------------------------------------------------%
@@ -49,6 +49,9 @@
:- pred generate_rtti(module_info::in, list(rtti_data)::out) is det.
+:- pred compute_du_ptag_layout_flags(sectag_table::in,
+ du_ptag_layout_flags::out) is det.
+
% Compute the "contains var" bit vector. The input is a list describing
% the types of the arguments of a function symbol. The output is an
% bit vector (represented as a 16 bit integer) in which each bit is set
@@ -97,6 +100,8 @@
:- import_module set.
:- import_module string.
:- import_module term.
+:- import_module uint.
+:- import_module uint8.
:- import_module uint16.
:- import_module uint32.
:- import_module univ.
@@ -316,12 +321,14 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
ModuleName = unqualified(ModuleStr1),
builtin_type_ctor(ModuleStr1, TypeName, TypeArity, BuiltinCtor)
then
- Details = tcd_builtin(BuiltinCtor)
+ Details = tcd_builtin(BuiltinCtor),
+ LayoutIndexable = no
else if
ModuleName = unqualified(ModuleStr),
impl_type_ctor(ModuleStr, TypeName, TypeArity, ImplCtor)
then
- Details = tcd_impl_artifact(ImplCtor)
+ Details = tcd_impl_artifact(ImplCtor),
+ LayoutIndexable = no
else
(
TypeBody = hlds_abstract_type(_),
@@ -339,7 +346,8 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
ExistTVars = [],
pseudo_type_info.construct_maybe_pseudo_type_info(RepnType,
UnivTVars, ExistTVars, MaybePseudoTypeInfo),
- Details = tcd_eqv(MaybePseudoTypeInfo)
+ Details = tcd_eqv(MaybePseudoTypeInfo),
+ LayoutIndexable = no
;
TypeBody = hlds_foreign_type(ForeignBody),
foreign_type_body_to_exported_type(ModuleInfo, ForeignBody, _, _,
@@ -349,7 +357,8 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
else
IsStable = is_not_stable
),
- Details = tcd_foreign(IsStable)
+ Details = tcd_foreign(IsStable),
+ LayoutIndexable = no
;
TypeBody = hlds_eqv_type(Type),
% There can be no existentially typed args to an equivalence.
@@ -357,9 +366,10 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
ExistTVars = [],
pseudo_type_info.construct_maybe_pseudo_type_info(Type,
UnivTVars, ExistTVars, MaybePseudoTypeInfo),
- Details = tcd_eqv(MaybePseudoTypeInfo)
+ Details = tcd_eqv(MaybePseudoTypeInfo),
+ LayoutIndexable = no
;
- TypeBody = hlds_du_type(_Ctors, _MaybeSuperType, MaybeCanonical,
+ TypeBody = hlds_du_type(_Ctors, MaybeSuperType, MaybeCanonical,
MaybeRepn, _IsForeignType),
(
MaybeRepn = no,
@@ -378,25 +388,32 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
),
(
DuTypeKind = du_type_kind_mercury_enum,
- make_mercury_enum_details(CtorRepns, enum_is_not_dummy,
- EqualityAxioms, Details)
+ make_mercury_enum_details(MaybeSuperType, CtorRepns,
+ enum_is_not_dummy, EqualityAxioms, Details,
+ IndexableByEnumValue),
+ LayoutIndexable = IndexableByEnumValue
;
DuTypeKind = du_type_kind_foreign_enum(Lang),
make_foreign_enum_details(Lang, CtorRepns, EqualityAxioms,
- Details)
+ Details),
+ LayoutIndexable = no
;
DuTypeKind = du_type_kind_direct_dummy,
- make_mercury_enum_details(CtorRepns, enum_is_dummy,
- EqualityAxioms, Details)
+ make_mercury_enum_details(MaybeSuperType, CtorRepns,
+ enum_is_dummy, EqualityAxioms, Details,
+ IndexableByEnumValue),
+ LayoutIndexable = IndexableByEnumValue
;
DuTypeKind = du_type_kind_notag(FunctorName, ArgType,
MaybeArgName),
make_notag_details(TypeArity, FunctorName, ArgType,
- MaybeArgName, EqualityAxioms, Details)
+ MaybeArgName, EqualityAxioms, Details),
+ LayoutIndexable = no
;
DuTypeKind = du_type_kind_general,
make_du_details(ModuleInfo, CtorRepns, TypeArity,
- EqualityAxioms, Details)
+ EqualityAxioms, Details, IndexableByPtag),
+ LayoutIndexable = IndexableByPtag
)
)
),
@@ -412,6 +429,12 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
; TypeBody = hlds_abstract_type(_)
)
),
+ (
+ LayoutIndexable = yes,
+ set.insert(layout_indexable_flag, !Flags)
+ ;
+ LayoutIndexable = no
+ ),
TypeCtorData = type_ctor_data(Version, ModuleName, TypeName,
uint16.det_from_int(TypeArity), UnifyUniv, CompareUniv,
!.Flags, Details)
@@ -488,7 +511,7 @@ impl_type_ctor("table_builtin", "ml_subgoal", 0, impl_ctor_subgoal).
%
:- func type_ctor_info_rtti_version = uint8.
-type_ctor_info_rtti_version = 17u8.
+type_ctor_info_rtti_version = 18u8.
%---------------------------------------------------------------------------%
@@ -520,29 +543,43 @@ make_notag_details(TypeArity, SymName, ArgType, MaybeArgName, EqualityAxioms,
% Make the functor and layout tables for an enum type.
%
-:- pred make_mercury_enum_details(list(constructor_repn)::in,
- enum_maybe_dummy::in, equality_axioms::in, type_ctor_details::out) is det.
+:- pred make_mercury_enum_details(maybe(mer_type)::in,
+ list(constructor_repn)::in, enum_maybe_dummy::in, equality_axioms::in,
+ type_ctor_details::out, bool::out) is det.
-make_mercury_enum_details(CtorRepns, IsDummy, EqualityAxioms, Details) :-
+make_mercury_enum_details(MaybeSuperType, CtorRepns, IsDummy, EqualityAxioms,
+ Details, IndexableByEnumValue) :-
(
CtorRepns = [],
unexpected($pred, "enum with no ctors")
;
CtorRepns = [_],
+ (
+ MaybeSuperType = no,
expect(unify(IsDummy, enum_is_dummy), $pred, "one ctor but not dummy")
+ ;
+ MaybeSuperType = yes(_)
+ % A subtype with one constructor is not necessarily a dummy type.
+ )
;
CtorRepns = [_, _ | _],
expect(unify(IsDummy, enum_is_not_dummy), $pred,
"more than one ctor but dummy")
),
- make_enum_functors(CtorRepns, IsDummy, 0u32, EnumFunctors),
- ValueMap0 = map.init,
+ make_enum_functors(MaybeSuperType, CtorRepns, IsDummy, 0u32, EnumFunctors),
+ OrdinalMap0 = map.init,
NameMap0 = map.init,
- list.foldl2(make_enum_maps, EnumFunctors,
- ValueMap0, ValueMap, NameMap0, NameMap),
+ list.foldl3(make_enum_maps, EnumFunctors,
+ OrdinalMap0, OrdinalMap, NameMap0, NameMap,
+ yes, AllValueEqualsOrdinal),
+ ( if is_enum_value_map_indexable(OrdinalMap, AllValueEqualsOrdinal) then
+ IndexableByEnumValue = yes
+ else
+ IndexableByEnumValue = no
+ ),
FunctorNumberMap = make_functor_number_map(CtorRepns),
Details = tcd_enum(EqualityAxioms, IsDummy, EnumFunctors,
- ValueMap, NameMap, FunctorNumberMap).
+ OrdinalMap, NameMap, FunctorNumberMap).
% Create an enum_functor structure for each functor in an enum type.
% The functors are given to us in ordinal order (since that's how the HLDS
@@ -552,12 +589,12 @@ make_mercury_enum_details(CtorRepns, IsDummy, EqualityAxioms, Details) :-
% sort this list on functor name, which is how the type functors structure
% is constructed.
%
-:- pred make_enum_functors(list(constructor_repn)::in, enum_maybe_dummy::in,
- uint32::in, list(enum_functor)::out) is det.
+:- pred make_enum_functors(maybe(mer_type)::in, list(constructor_repn)::in,
+ enum_maybe_dummy::in, uint32::in, list(enum_functor)::out) is det.
-make_enum_functors([], _, _, []).
-make_enum_functors([FunctorRepn | FunctorRepns], IsDummy, CurOrdinal,
- [EnumFunctor | EnumFunctors]) :-
+make_enum_functors(_, [], _, _, []).
+make_enum_functors(MaybeSuperType, [FunctorRepn | FunctorRepns], IsDummy,
+ CurOrdinal, [EnumFunctor | EnumFunctors]) :-
FunctorRepn = ctor_repn(Ordinal, MaybeExistConstraints, SymName, ConsTag,
_FunctorArgRepns, Arity, _Context),
% XXX ARG_PACK We should not need CurOrdinal.
@@ -567,26 +604,54 @@ make_enum_functors([FunctorRepn | FunctorRepns], IsDummy, CurOrdinal,
expect(unify(Arity, 0), $pred, "functor in enum has nonzero arity"),
(
IsDummy = enum_is_not_dummy,
- CurOrdinalInt = uint32.cast_to_int(CurOrdinal),
- expect(unify(ConsTag, int_tag(int_tag_int(CurOrdinalInt))), $pred,
+ ( if ConsTag = int_tag(int_tag_int(ConsTagInt)) then
+ ConsTagUint32 = uint32.det_from_int(ConsTagInt)
+ else
+ unexpected($pred, "enum functor's tag is not int_tag")
+ ),
+ (
+ MaybeSuperType = no,
+ expect(unify(ConsTagUint32, CurOrdinal), $pred,
"enum functor's tag is not the expected int_tag")
+ ;
+ MaybeSuperType = yes(_)
+ ),
+ EnumValue = enum_value(ConsTagUint32)
;
IsDummy = enum_is_dummy,
expect(unify(ConsTag, dummy_tag), $pred,
- "dummy functor's tag is not dummy_tag")
+ "dummy functor's tag is not dummy_tag"),
+ EnumValue = enum_value(CurOrdinal)
),
FunctorName = unqualify_name(SymName),
- EnumFunctor = enum_functor(FunctorName, CurOrdinal),
- make_enum_functors(FunctorRepns, IsDummy, CurOrdinal + 1u32, EnumFunctors).
+ EnumFunctor = enum_functor(FunctorName, Ordinal, EnumValue),
+ make_enum_functors(MaybeSuperType, FunctorRepns, IsDummy,
+ CurOrdinal + 1u32, EnumFunctors).
:- pred make_enum_maps(enum_functor::in,
map(uint32, enum_functor)::in, map(uint32, enum_functor)::out,
- map(string, enum_functor)::in, map(string, enum_functor)::out) is det.
+ map(string, enum_functor)::in, map(string, enum_functor)::out,
+ bool::in, bool::out) is det.
+
+make_enum_maps(EnumFunctor, !OrdinalMap, !NameMap, !ValueEqualsOrdinal) :-
+ EnumFunctor = enum_functor(FunctorName, Ordinal, Value),
+ map.det_insert(Ordinal, EnumFunctor, !OrdinalMap),
+ map.det_insert(FunctorName, EnumFunctor, !NameMap),
+ ( if Value = enum_value(Ordinal) then
+ true
+ else
+ !:ValueEqualsOrdinal = no
+ ).
+
+:- pred is_enum_value_map_indexable(map(uint32, enum_functor)::in, bool::in)
+ is semidet.
-make_enum_maps(EnumFunctor, !ValueMap, !NameMap) :-
- EnumFunctor = enum_functor(FunctorName, Ordinal),
- map.det_insert(Ordinal, EnumFunctor, !ValueMap),
- map.det_insert(FunctorName, EnumFunctor, !NameMap).
+is_enum_value_map_indexable(OrdinalMap, AllValueEqualsOrdinal) :-
+ AllValueEqualsOrdinal = yes,
+ map.min_key(OrdinalMap) = 0u32,
+ map.max_key(OrdinalMap) = MaxOrdinal,
+ map.count(OrdinalMap, Count),
+ uint32.from_int(Count - 1, MaxOrdinal).
%---------------------------------------------------------------------------%
@@ -684,11 +749,17 @@ make_foreign_enum_maps(ForeignEnumFunctor, !OrdinalMap, !NameMap) :-
% (including reserved_addr types).
%
:- pred make_du_details(module_info::in, list(constructor_repn)::in,
- int::in, equality_axioms::in, type_ctor_details::out) is det.
+ int::in, equality_axioms::in, type_ctor_details::out, bool::out) is det.
-make_du_details(ModuleInfo, Ctors, TypeArity, EqualityAxioms, Details) :-
+make_du_details(ModuleInfo, Ctors, TypeArity, EqualityAxioms, Details,
+ IndexableByPtag) :-
make_du_functors(ModuleInfo, Ctors, 0u32, TypeArity, DuFunctors),
list.foldl(make_du_ptag_ordered_table, DuFunctors, map.init, DuPtagTable),
+ ( if is_ptag_table_indexable(DuPtagTable) then
+ IndexableByPtag = yes
+ else
+ IndexableByPtag = no
+ ),
FunctorNumberMap = make_functor_number_map(Ctors),
list.foldl(make_du_name_ordered_table, DuFunctors,
map.init, DuNameOrderedMap),
@@ -995,6 +1066,14 @@ make_du_name_ordered_table(DuFunctor, !NameTable) :-
map.det_insert(Name, NameMap, !NameTable)
).
+:- pred is_ptag_table_indexable(map(ptag, sectag_table)::in) is semidet.
+
+is_ptag_table_indexable(PtagTable) :-
+ map.min_key(PtagTable) = ptag(0u8),
+ map.max_key(PtagTable) = ptag(MaxPtagUint8),
+ map.count(PtagTable, Count),
+ uint8.from_int(Count - 1, MaxPtagUint8).
+
%---------------------------------------------------------------------------%
% Construct the array mapping ordinal constructor numbers
@@ -1024,6 +1103,26 @@ lookup_functor_number(CtorNameToSeqNumMap, CtorName, SeqNumUint32) :-
%---------------------------------------------------------------------------%
+compute_du_ptag_layout_flags(SectagTable, Flags) :-
+ ( if is_sectag_table_indexable(SectagTable) then
+ SectagAltsIndexable = yes
+ else
+ SectagAltsIndexable = no
+ ),
+ Flags = du_ptag_layout_flags(SectagAltsIndexable).
+
+:- pred is_sectag_table_indexable(sectag_table::in) is semidet.
+
+is_sectag_table_indexable(SectagTable) :-
+ SectagTable = sectag_table(_Locn, _NumSectagBits, NumSharers, SectagMap),
+ map.min_key(SectagMap) = 0u,
+ map.max_key(SectagMap) = MaxSectag,
+ map.count(SectagMap, Count),
+ uint.from_int(Count - 1, MaxSectag),
+ uint32.from_int(Count, NumSharers).
+
+%---------------------------------------------------------------------------%
+
compute_contains_var_bit_vector(ArgTypes) = Vector :-
compute_contains_var_bit_vector_2(ArgTypes, 0, 0u16, Vector).
diff --git a/compiler/type_util.m b/compiler/type_util.m
index 672f4930d..fd560a120 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 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.
%-----------------------------------------------------------------------------%
@@ -160,8 +160,10 @@
% A type cannot be a dummy type if it is the subject of a foreign_enum
% pragma, or if it has a reserved tag or user defined equality.
%
+ % A subtype is only a dummy type if its base type is a dummy type.
+ %
% NOTE: changes here may require changes to
- % `constructor_list_represents_dummy_argument_type'.
+ % `non_sub_du_constructor_list_represents_dummy_type'.
%
:- func is_type_a_dummy(module_info, mer_type) = is_dummy_type.
@@ -715,6 +717,7 @@ type_body_is_solver_type(ModuleInfo, TypeBody) :-
; AbstractType = abstract_dummy_type
; AbstractType = abstract_notag_type
; AbstractType = abstract_type_fits_in_n_bits(_)
+ ; AbstractType = abstract_subtype(_)
),
IsSolverType = non_solver_type
)
@@ -751,6 +754,7 @@ type_body_is_solver_type_from_type_table(TypeTable, TypeBody) :-
; AbstractType = abstract_dummy_type
; AbstractType = abstract_notag_type
; AbstractType = abstract_type_fits_in_n_bits(_)
+ ; AbstractType = abstract_subtype(_)
),
IsSolverType = no
)
@@ -810,6 +814,7 @@ is_type_a_dummy_loop(TypeTable, Type, CoveredTypes) = IsDummy :-
else if type_to_ctor_and_args(Type, TypeCtor, ArgTypes) then
% Keep this in sync with is_dummy_argument_type_with_constructors
% above.
+ % XXX gone since 097b45acec46527f1485419e66ce28d5ba224846
IsBuiltinDummy = is_type_ctor_a_builtin_dummy(TypeCtor),
(
IsBuiltinDummy = is_builtin_dummy_type_ctor,
@@ -1098,6 +1103,8 @@ classify_type_defn_body(TypeBody) = TypeCategory :-
(
( AbstractDetails = abstract_type_general
; AbstractDetails = abstract_type_fits_in_n_bits(_)
+ ; AbstractDetails = abstract_subtype(_)
+ % XXX SUBTYPE is cat_user_general ok for subtypes?
; AbstractDetails = abstract_solver_type
),
TypeCategory = ctor_cat_user(cat_user_general)
diff --git a/java/runtime/DuPtagLayout.java b/java/runtime/DuPtagLayout.java
index 1fcee1cfd..b5f5d53a1 100644
--- a/java/runtime/DuPtagLayout.java
+++ b/java/runtime/DuPtagLayout.java
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=java
//
// Copyright (C) 2001-2003 The University of Melbourne.
-// Copyright (C) 2018 The Mercury team.
+// Copyright (C) 2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
//
@@ -13,28 +13,59 @@ public class DuPtagLayout implements java.io.Serializable {
public Sectag_Locn sectag_locn;
public /* final */ DuFunctorDesc[] sectag_alternatives;
public byte sectag_numbits; // not used in Java grades
+ public byte du_ptag;
+ public byte du_ptag_flags;
+
+ private final byte MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE = 0x1;
public DuPtagLayout(
- int sharers,
- Sectag_Locn locn,
- DuFunctorDesc[] alts,
- byte numbits)
+ int sectag_sharers,
+ Sectag_Locn sectag_locn,
+ DuFunctorDesc[] sectag_alts,
+ byte sectag_numbits,
+ byte du_ptag,
+ byte du_ptag_flags)
{
- sectag_sharers = sharers;
- sectag_locn = locn;
- sectag_alternatives = alts;
- sectag_numbits = numbits;
+ this.sectag_sharers = sectag_sharers;
+ this.sectag_locn = sectag_locn;
+ this.sectag_alternatives = sectag_alts;
+ this.sectag_numbits = sectag_numbits;
+ this.du_ptag = du_ptag;
+ this.du_ptag_flags = du_ptag_flags;
}
public DuPtagLayout(
- int sharers,
- int locn,
- DuFunctorDesc[] alts,
- byte numbits)
+ int sectag_sharers,
+ int sectag_locn,
+ DuFunctorDesc[] sectag_alts,
+ byte sectag_numbits,
+ byte du_ptag,
+ byte du_ptag_flags)
{
- sectag_sharers = sharers;
- sectag_locn = new Sectag_Locn(locn);
- sectag_alternatives = alts;
- sectag_numbits = numbits;
+ this.sectag_sharers = sectag_sharers;
+ this.sectag_locn = new Sectag_Locn(sectag_locn);
+ this.sectag_alternatives = sectag_alts;
+ this.sectag_numbits = sectag_numbits;
+ this.du_ptag = du_ptag;
+ this.du_ptag_flags = du_ptag_flags;
+ }
+
+ public DuFunctorDesc index_or_search_sectag_functor(int sectag) {
+ if (flags_is_sectag_alteratives_indexable()) {
+ return sectag_alternatives[sectag];
+ }
+
+ for (DuFunctorDesc desc : sectag_alternatives) {
+ if (desc.du_functor_secondary == sectag) {
+ return desc;
+ }
+ }
+
+ return null;
+ }
+
+ private boolean flags_is_sectag_alteratives_indexable() {
+ return (du_ptag_flags & MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE)
+ != 0;
}
}
diff --git a/java/runtime/EnumFunctorDesc.java b/java/runtime/EnumFunctorDesc.java
index 951b8aee3..fad342be8 100644
--- a/java/runtime/EnumFunctorDesc.java
+++ b/java/runtime/EnumFunctorDesc.java
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=java
//
// Copyright (C) 2001-2003 The University of Melbourne.
-// Copyright (C) 2018 The Mercury team.
+// Copyright (C) 2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
//
@@ -10,14 +10,14 @@ package jmercury.runtime;
public class EnumFunctorDesc implements java.io.Serializable {
public java.lang.String enum_functor_name;
- public int enum_functor_ordinal;
+ public int enum_functor_value;
public EnumFunctorDesc() {
}
- public void init(String name, int ordinal) {
+ public void init(String name, int value) {
enum_functor_name = name;
- enum_functor_ordinal = ordinal;
+ enum_functor_value = value;
}
}
diff --git a/java/runtime/TypeCtorInfo_Struct.java b/java/runtime/TypeCtorInfo_Struct.java
index 824a9259e..94a3b9745 100644
--- a/java/runtime/TypeCtorInfo_Struct.java
+++ b/java/runtime/TypeCtorInfo_Struct.java
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=java
//
// Copyright (C) 2001-2004, 2009 The University of Melbourne.
-// Copyright (C) 2018 The Mercury team.
+// Copyright (C) 2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
//
@@ -27,6 +27,8 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
public short type_ctor_flags;
public int[] type_functor_number_map;
+ private final short MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE = 0x8;
+
public TypeCtorInfo_Struct()
{
}
@@ -62,7 +64,7 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
String module,
String name,
java.lang.Object name_ordered_functor_descs, // TypeFunctors
- java.lang.Object value_ordered_functor_descs, // TypeLayout
+ java.lang.Object ordinal_ordered_functor_descs, // TypeLayout
int num_functors,
short flags,
int[] functor_number_map)
@@ -76,7 +78,7 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
type_ctor_module_name = module;
type_ctor_name = name;
type_functors = (TypeFunctors) name_ordered_functor_descs;
- type_layout = (TypeLayout) value_ordered_functor_descs;
+ type_layout = (TypeLayout) ordinal_ordered_functor_descs;
type_ctor_num_functors = num_functors;
type_ctor_flags = flags;
type_functor_number_map = functor_number_map;
@@ -91,4 +93,40 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
&& type_ctor_name.equals(tci.type_ctor_name)
&& arity == tci.arity;
}
+
+ // Return the functor ordinal for the given enum functor value,
+ // or -1 if not found.
+ public int index_or_search_enum_functor_ordinal(int enum_value) {
+ if (flags_is_layout_indexable()) {
+ return enum_value; // same as ordinal
+ }
+
+ final EnumFunctorDesc[] layout_enum = type_layout.layout_enum();
+ for (int i = 0; i < layout_enum.length; i++) {
+ if (layout_enum[i].enum_functor_value == enum_value) {
+ return i;
+ }
+ }
+ return -1;
+ }
+
+ // Return the ptag layout with the given ptag, or null if not found.
+ public DuPtagLayout index_or_search_ptag_layout(byte ptag) {
+ final DuPtagLayout[] layout_du = type_layout.layout_du();
+
+ if (flags_is_layout_indexable()) {
+ return layout_du[ptag];
+ }
+
+ for (DuPtagLayout ptag_layout : layout_du) {
+ if (ptag_layout.du_ptag == ptag) {
+ return ptag_layout;
+ }
+ }
+ return null;
+ }
+
+ private boolean flags_is_layout_indexable() {
+ return (type_ctor_flags & MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE) != 0;
+ }
}
diff --git a/library/construct.m b/library/construct.m
index 242b9d520..2f72aa881 100644
--- a/library/construct.m
+++ b/library/construct.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2002-2009, 2011 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
@@ -201,7 +201,7 @@ get_functor_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
// If this is a discriminated union type and if the functor number
// is in range, we succeed.
MR_save_transient_registers();
- success = MR_get_functors_check_range(FunctorNumber, type_info,
+ success = MR_get_functors_check_range(FunctorNumber, type_info, MR_FALSE,
&construct_info);
MR_restore_transient_registers();
@@ -265,7 +265,7 @@ get_functor_with_names_internal(TypeDesc, FunctorNumber, FunctorName, Arity,
// If this is a discriminated union type and if the functor number
// is in range, we succeed.
MR_save_transient_registers();
- success = MR_get_functors_check_range(FunctorNumber, type_info,
+ success = MR_get_functors_check_range(FunctorNumber, type_info, MR_FALSE,
&construct_info);
MR_restore_transient_registers();
@@ -354,88 +354,14 @@ get_functor_ordinal(TypeDesc, FunctorNumber, Ordinal) :-
// If this is a discriminated union type and if the functor number is
// in range, we succeed.
MR_save_transient_registers();
- success = MR_get_functors_check_range(FunctorNumber, type_info,
+ success = MR_get_functors_check_range(FunctorNumber, type_info, MR_TRUE,
&construct_info);
MR_restore_transient_registers();
if (success) {
- switch (construct_info.type_ctor_rep) {
-
- case MR_TYPECTOR_REP_ENUM:
- case MR_TYPECTOR_REP_ENUM_USEREQ:
- Ordinal = construct_info.functor_info.
- enum_functor_desc->MR_enum_functor_ordinal;
- break;
-
- case MR_TYPECTOR_REP_FOREIGN_ENUM:
- case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
- Ordinal = construct_info.functor_info.
- foreign_enum_functor_desc->MR_foreign_enum_functor_ordinal;
- break;
-
- case MR_TYPECTOR_REP_DUMMY:
- case MR_TYPECTOR_REP_NOTAG:
- case MR_TYPECTOR_REP_NOTAG_USEREQ:
- case MR_TYPECTOR_REP_NOTAG_GROUND:
- case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
- case MR_TYPECTOR_REP_TUPLE:
- Ordinal = 0;
- break;
-
- case MR_TYPECTOR_REP_DU:
- case MR_TYPECTOR_REP_DU_USEREQ:
- Ordinal = construct_info.functor_info.
- du_functor_desc->MR_du_functor_ordinal;
- break;
-
- case MR_TYPECTOR_REP_EQUIV:
- case MR_TYPECTOR_REP_EQUIV_GROUND:
- case MR_TYPECTOR_REP_FUNC:
- case MR_TYPECTOR_REP_PRED:
- case MR_TYPECTOR_REP_INT:
- case MR_TYPECTOR_REP_UINT:
- case MR_TYPECTOR_REP_INT8:
- case MR_TYPECTOR_REP_UINT8:
- case MR_TYPECTOR_REP_INT16:
- case MR_TYPECTOR_REP_UINT16:
- case MR_TYPECTOR_REP_INT32:
- case MR_TYPECTOR_REP_UINT32:
- case MR_TYPECTOR_REP_INT64:
- case MR_TYPECTOR_REP_UINT64:
- case MR_TYPECTOR_REP_FLOAT:
- case MR_TYPECTOR_REP_CHAR:
- case MR_TYPECTOR_REP_STRING:
- case MR_TYPECTOR_REP_BITMAP:
- case MR_TYPECTOR_REP_SUBGOAL:
- case MR_TYPECTOR_REP_VOID:
- case MR_TYPECTOR_REP_C_POINTER:
- case MR_TYPECTOR_REP_STABLE_C_POINTER:
- case MR_TYPECTOR_REP_TYPEINFO:
- case MR_TYPECTOR_REP_TYPECTORINFO:
- case MR_TYPECTOR_REP_TYPECLASSINFO:
- case MR_TYPECTOR_REP_BASETYPECLASSINFO:
- case MR_TYPECTOR_REP_TYPEDESC:
- case MR_TYPECTOR_REP_TYPECTORDESC:
- case MR_TYPECTOR_REP_PSEUDOTYPEDESC:
- case MR_TYPECTOR_REP_ARRAY:
- case MR_TYPECTOR_REP_REFERENCE:
- case MR_TYPECTOR_REP_SUCCIP:
- case MR_TYPECTOR_REP_HP:
- case MR_TYPECTOR_REP_CURFR:
- case MR_TYPECTOR_REP_MAXFR:
- case MR_TYPECTOR_REP_REDOFR:
- case MR_TYPECTOR_REP_REDOIP:
- case MR_TYPECTOR_REP_TRAIL_PTR:
- case MR_TYPECTOR_REP_TICKET:
- case MR_TYPECTOR_REP_FOREIGN:
- case MR_TYPECTOR_REP_STABLE_FOREIGN:
- case MR_TYPECTOR_REP_UNUSED1:
- case MR_TYPECTOR_REP_UNUSED2:
- case MR_TYPECTOR_REP_UNKNOWN:
- success = MR_FALSE;
+ Ordinal = construct_info.functor_ordinal;
+ } else {
Ordinal = 0;
- break;
- }
}
SUCCESS_INDICATOR = success;
}").
@@ -811,9 +737,13 @@ ML_copy_tagword_args(MR_Word *arg_list_ptr, const MR_Word ptag,
// Check range of FunctorNum, get info for this functor.
MR_save_transient_registers();
success =
- MR_get_functors_check_range(FunctorNumber, type_info, &construct_info)
- && MR_typecheck_arguments(type_info, construct_info.arity, ArgList,
+ MR_get_functors_check_range(FunctorNumber, type_info, MR_FALSE,
+ &construct_info);
+ if (success) {
+ success =
+ MR_typecheck_arguments(type_info, construct_info.arity, ArgList,
construct_info.arg_pseudo_type_infos);
+ }
MR_restore_transient_registers();
// Build the new term in `new_data'.
@@ -829,7 +759,7 @@ ML_copy_tagword_args(MR_Word *arg_list_ptr, const MR_Word ptag,
case MR_TYPECTOR_REP_ENUM:
case MR_TYPECTOR_REP_ENUM_USEREQ:
new_data = construct_info.functor_info.enum_functor_desc->
- MR_enum_functor_ordinal;
+ MR_enum_functor_value;
break;
case MR_TYPECTOR_REP_FOREIGN_ENUM:
diff --git a/library/rtti_implementation.m b/library/rtti_implementation.m
index 4f33994c3..708ad3eb2 100644
--- a/library/rtti_implementation.m
+++ b/library/rtti_implementation.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2001-2007, 2009-2011 The University of Melbourne.
-% Copyright (C) 2014-2018 The Mercury team.
+% Copyright (C) 2014-2021 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
@@ -743,7 +743,7 @@ compare_pseudo_type_info_args(Res, Args1, Args2) :-
unexpected($pred, "argument list mismatch")
).
-%---------------------%
+%---------------------------------------------------------------------------%
:- func collapse_equivalences(type_info) = type_info.
:- pragma foreign_export("C#", collapse_equivalences(in) = out,
@@ -1074,6 +1074,8 @@ get_functor_du(TypeCtorRep, TypeInfo, TypeCtorInfo, FunctorNumber,
Names = list.duplicate(Arity, null_string)
).
+%---------------------%
+
:- pred get_functor_enum(type_ctor_rep::in(enum), type_ctor_info::in, int::in,
string::out, int::out, list(pseudo_type_info)::out, list(string)::out)
is det.
@@ -1089,6 +1091,8 @@ get_functor_enum(TypeCtorRep, TypeCtorInfo, FunctorNumber, FunctorName, Arity,
PseudoTypeInfoList = [],
Names = [].
+%---------------------%
+
:- pred get_functor_foreign_enum(type_ctor_rep::in(foreign_enum),
type_ctor_info::in, int::in, string::out, int::out,
list(pseudo_type_info)::out, list(string)::out) is det.
@@ -1104,6 +1108,8 @@ get_functor_foreign_enum(TypeCtorRep, TypeCtorInfo, FunctorNumber,
PseudoTypeInfoList = [],
Names = [].
+%---------------------%
+
:- pred get_functor_notag(type_ctor_rep::in(notag), type_ctor_info::in,
int::in, string::out, int::out, list(pseudo_type_info)::out,
list(string)::out) is det.
@@ -1220,7 +1226,8 @@ type_info_get_functor_ordinal(TypeInfo, FunctorNum, Ordinal) :-
TypeFunctors = get_type_functors(TypeCtorInfo),
EnumFunctorDesc = get_enum_functor_desc(TypeCtorRep, FunctorNum,
TypeFunctors),
- Ordinal = enum_functor_ordinal(EnumFunctorDesc)
+ EnumValue = enum_functor_value(EnumFunctorDesc),
+ index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue, Ordinal)
;
( TypeCtorRep = tcr_foreign_enum
; TypeCtorRep = tcr_foreign_enum_usereq
@@ -1700,6 +1707,8 @@ type_ctor_name_and_arity(TypeCtorInfo, ModuleName, Name, Arity) :-
pseudo_type_ctor_and_args(_, _, _) :-
private_builtin.sorry("pseudo_type_ctor_and_args/3").
+%---------------------%
+
:- pragma foreign_proc("C#",
is_univ_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -1721,6 +1730,8 @@ pseudo_type_ctor_and_args(_, _, _) :-
is_univ_pseudo_type_info(_, _) :-
private_builtin.sorry("is_univ_pseudo_type_info/2").
+%---------------------%
+
:- pragma foreign_proc("C#",
is_exist_pseudo_type_info(PseudoTypeInfo::in, VarNum::out),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -1769,7 +1780,7 @@ is_exist_pseudo_type_info(_, _) :-
if (FunctorNumber >= 0 && FunctorNumber < functors_enum.Length)
{
new_data = ML_construct_static_member(tc,
- functors_enum[FunctorNumber].enum_functor_ordinal);
+ functors_enum[FunctorNumber].enum_functor_value);
}
break;
@@ -2027,6 +2038,9 @@ is_exist_pseudo_type_info(_, _) :-
string typename;
System.Type type;
+ // XXX SUBTYPE A subtype may have only one functor without being a
+ // notag type. We may need to look at this again after changing the
+ // data representation of subtypes in high-level data grades.
if (tc.type_ctor_num_functors == 1) {
typename =
""mercury."" + ML_name_mangle(tc.type_ctor_module_name)
@@ -2212,7 +2226,7 @@ is_exist_pseudo_type_info(_, _) :-
if (FunctorNumber >= 0 && FunctorNumber < functors_enum.length)
{
new_data = ML_construct_static_member(tc,
- functors_enum[FunctorNumber].enum_functor_ordinal);
+ functors_enum[FunctorNumber].enum_functor_value);
}
break;
@@ -2473,6 +2487,10 @@ is_exist_pseudo_type_info(_, _) :-
InvocationTargetException
{
String clsname;
+
+ // XXX SUBTYPE A subtype may have only one functor without being a
+ // notag type. We may need to look at this again after changing the
+ // data representation of subtypes in high-level data grades.
if (tc.type_ctor_num_functors == 1) {
clsname = ""jmercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""$"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
@@ -2753,11 +2771,11 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_enum,
- TypeLayout = get_type_layout(TypeCtorInfo),
- EnumFunctorDesc = get_enum_functor_desc_from_layout_enum(TypeCtorRep,
- unsafe_get_enum_value(Term), TypeLayout),
+ EnumValue = unsafe_get_enum_value(Term),
+ det_index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue,
+ Ordinal),
+ index_enum_functor_desc(TypeCtorInfo, Ordinal, EnumFunctorDesc),
Functor = enum_functor_name(EnumFunctorDesc),
- Ordinal = enum_functor_ordinal(EnumFunctorDesc),
Arity = 0,
Arguments = []
;
@@ -2775,11 +2793,9 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_dummy,
- TypeLayout = get_type_layout(TypeCtorInfo),
- EnumFunctorDesc = get_enum_functor_desc_from_layout_enum(TypeCtorRep,
- 0, TypeLayout),
- Functor = enum_functor_name(EnumFunctorDesc),
Ordinal = 0,
+ index_enum_functor_desc(TypeCtorInfo, Ordinal, EnumFunctorDesc),
+ Functor = enum_functor_name(EnumFunctorDesc),
Arity = 0,
Arguments = []
;
@@ -2788,22 +2804,21 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
NonCanon, Functor, Ordinal, Arity, Arguments)
;
TypeCtorRep = tcr_du,
-
- LayoutInfo = get_type_layout(TypeCtorInfo),
PTag = get_primary_tag(Term),
- PTagEntry = LayoutInfo ^ ptag_index(PTag),
+ det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry),
SecTagLocn = PTagEntry ^ sectag_locn,
(
(
SecTagLocn = stag_none,
- FunctorDesc = PTagEntry ^ du_sectag_alternatives(0)
+ index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_none_direct_arg,
- FunctorDesc = PTagEntry ^ du_sectag_alternatives(0)
+ index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_remote,
SecTag = get_remote_secondary_tag(Term),
- FunctorDesc = PTagEntry ^ du_sectag_alternatives(SecTag)
+ det_index_or_search_sectag_functor(PTagEntry, SecTag,
+ FunctorDesc)
),
Functor = FunctorDesc ^ du_functor_name,
Ordinal = int32.to_int(FunctorDesc ^ du_functor_ordinal),
@@ -3148,6 +3163,8 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
unexpected($pred, "unknown type_ctor rep")
).
+%---------------------------------------------------------------------------%
+
univ_named_arg(Term, NonCanon, Name, Argument) :-
TypeInfo = get_type_info(Term),
TypeCtorInfo = get_type_ctor_info(TypeInfo),
@@ -3156,21 +3173,6 @@ univ_named_arg(Term, NonCanon, Name, Argument) :-
MaybeArgument),
MaybeArgument = yes(Argument).
- % Note: changes to this predicate may require changes to the similar
- % predicate in library/term_io.m.
- %
-:- pred quote_special_escape_char(character::in, string::out) is semidet.
-
-quote_special_escape_char('\\', "'\\\\'").
-quote_special_escape_char('\'', "'\\''").
-quote_special_escape_char('\a', "'\\a'").
-quote_special_escape_char('\b', "'\\b'").
-quote_special_escape_char('\r', "'\\r'").
-quote_special_escape_char('\f', "'\\f'").
-quote_special_escape_char('\t', "'\\t'").
-quote_special_escape_char('\n', "'\\n'").
-quote_special_escape_char('\v', "'\\v'").
-
:- pred univ_named_arg_2(T, type_info, type_ctor_info, type_ctor_rep,
noncanon_handling, string, maybe(univ)).
:- mode univ_named_arg_2(in, in, in, in, in(do_not_allow), in, out) is det.
@@ -3195,22 +3197,22 @@ univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon, Name,
)
;
TypeCtorRep = tcr_du,
- LayoutInfo = get_type_layout(TypeCtorInfo),
PTag = get_primary_tag(Term),
- PTagEntry = LayoutInfo ^ ptag_index(PTag),
+ det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry),
SecTagLocn = PTagEntry ^ sectag_locn,
(
(
SecTagLocn = stag_none,
- SecTag = 0
+ index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_none_direct_arg,
- SecTag = 0
+ index_sectag_functor(PTagEntry, 0, FunctorDesc)
;
SecTagLocn = stag_remote,
- SecTag = get_remote_secondary_tag(Term)
+ SecTag = get_remote_secondary_tag(Term),
+ det_index_or_search_sectag_functor(PTagEntry, SecTag,
+ FunctorDesc)
),
- FunctorDesc = PTagEntry ^ du_sectag_alternatives(SecTag),
Arity = int16.to_int(FunctorDesc ^ du_functor_arity),
( if
get_du_functor_arg_names(FunctorDesc, Names),
@@ -3292,6 +3294,23 @@ univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon, Name,
unexpected($pred, "unknown type_ctor rep")
).
+%---------------------------------------------------------------------------%
+
+ % Note: changes to this predicate may require changes to the similar
+ % predicate in library/term_io.m.
+ %
+:- pred quote_special_escape_char(character::in, string::out) is semidet.
+
+quote_special_escape_char('\\', "'\\\\'").
+quote_special_escape_char('\'', "'\\''").
+quote_special_escape_char('\a', "'\\a'").
+quote_special_escape_char('\b', "'\\b'").
+quote_special_escape_char('\r', "'\\r'").
+quote_special_escape_char('\f', "'\\f'").
+quote_special_escape_char('\t', "'\\t'").
+quote_special_escape_char('\n', "'\\n'").
+quote_special_escape_char('\v', "'\\v'").
+
:- pred det_dynamic_cast(T::in, U::out) is det.
det_dynamic_cast(Term, Actual) :-
@@ -3302,6 +3321,8 @@ det_dynamic_cast(Term, Actual) :-
same_array_elem_type(_, _).
+%---------------------------------------------------------------------------%
+
:- inst usereq for type_ctor_rep/0
---> tcr_enum_usereq
; tcr_foreign_enum_usereq
@@ -3310,6 +3331,8 @@ same_array_elem_type(_, _).
; tcr_notag_ground_usereq
; tcr_reserved_addr_usereq.
+ % Part of deconstruct_2.
+ %
:- pred handle_usereq_type(T, type_info, type_ctor_info, type_ctor_rep,
noncanon_handling, string, int, int, list(univ)).
:- mode handle_usereq_type(in, in, in, in(usereq),
@@ -3378,6 +3401,8 @@ expand_type_name(TypeCtorInfo, Wrap) = Name :-
i(TypeCtorInfo ^ type_ctor_arity),
s(RightWrapper)]).
+%---------------------------------------------------------------------------%
+
% Retrieve an argument number from a term, given the functor descriptor.
%
:- some [T] pred get_arg(U::in, sectag_locn::in, du_functor_desc::in,
@@ -3414,25 +3439,7 @@ get_arg_univ(Term, SecTagLocn, FunctorDesc, TypeInfo, Index) = Univ :-
get_arg(Term, SecTagLocn, FunctorDesc, TypeInfo, Index, Arg),
type_to_univ(Arg, Univ).
-:- pred high_level_data is semidet.
-:- pragma foreign_proc("Java",
- high_level_data,
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR = true;
-").
-:- pragma foreign_proc("C#",
- high_level_data,
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- SUCCESS_INDICATOR = true;
-").
-high_level_data :-
- ( if semidet_succeed then
- private_builtin.sorry("high_level_data")
- else
- semidet_succeed
- ).
+%---------------------%
:- pred get_arg_type_info(type_info::in, pseudo_type_info::in, T::in,
du_functor_desc::in, type_info::out) is det.
@@ -3473,6 +3480,8 @@ get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
true
).
+%---------------------%
+
:- func type_info_get_higher_order_arity(type_info) = int.
:- pragma foreign_proc("C#",
@@ -3495,6 +3504,8 @@ get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
type_info_get_higher_order_arity(_) = 1 :-
det_unimplemented("type_info_get_higher_order_arity").
+%---------------------%
+
% Make a new type-info with the given arity, using the given type_info
% as the basis.
%
@@ -3518,6 +3529,8 @@ new_type_info(TypeInfo, _) = NewTypeInfo :-
NewTypeInfo = OldTypeInfo.copy();
").
+%---------------------%
+
% Get the pseudo-typeinfo at the given index from the argument types.
%
:- func get_pti_from_arg_types(arg_types, int) = pseudo_type_info.
@@ -3539,6 +3552,8 @@ get_pti_from_arg_types(_, _) = _ :-
ArgTypeInfo = ArgTypes[Index];
").
+%---------------------%
+
% Get the pseudo-typeinfo at the given index from a type-info.
%
:- pred get_pti_from_type_info_index(type_info::in, int::in, int::in,
@@ -3563,6 +3578,8 @@ get_pti_from_type_info_index(_, _, _, _) :-
PTI = TypeInfo.args[Index];
").
+%---------------------%
+
% Get the type info for a particular type variable number
% (it might be in the type_info or in the term itself).
%
@@ -3594,6 +3611,8 @@ get_type_info_for_var(TypeInfo, VarNum, Term, FunctorDesc, ArgTypeInfo) :-
)
).
+%---------------------%
+
% An unchecked cast to type_info (for pseudo-typeinfos).
%
:- func type_info_from_pseudo_type_info(pseudo_type_info) = type_info.
@@ -3626,6 +3645,8 @@ type_info_from_pseudo_type_info(PseudoTypeInfo) = TypeInfo :-
}
").
+%---------------------%
+
% Get a subterm T, given its type_info, the original term U, its index
% and the start region size.
%
@@ -3711,6 +3732,8 @@ get_subterm(_, _, _, _, _) = -1 :-
TypeInfo_for_T = SubTermTypeInfo;
").
+%---------------------%
+
% Same as above, but for tuples instead of du types.
%
:- some [T] func get_tuple_subterm(type_info, U, int) = T.
@@ -3722,6 +3745,8 @@ get_tuple_subterm(TypeInfo, Term, Index) = SubTerm :-
% the Term is an array (true of tuples).
SubTerm = get_subterm(null_functor_desc, TypeInfo, Term, Index, 0).
+%---------------------%
+
:- func null_functor_desc = du_functor_desc.
:- pragma foreign_proc("C#",
null_functor_desc = (NullFunctorDesc::out),
@@ -3742,6 +3767,8 @@ get_tuple_subterm(TypeInfo, Term, Index) = SubTerm :-
NullFunctorDesc = (MR_Word) NULL;
").
+%---------------------%
+
% Test whether a (pseudo-) type info is variable.
% The argument type is pseudo_type_info, because when we call this,
% we have a pseudo_type_info but aren't sure if it is actually
@@ -3773,6 +3800,8 @@ pseudo_type_info_is_variable(_, -1) :-
assert VarNum != 0;
").
+%---------------------%
+
% Tests for universal and existentially quantified variables.
% (The existential version is not used.)
%
@@ -3805,9 +3834,11 @@ public static final int first_exist_quant_varnum = 513;
%---------------------------------------------------------------------------%
:- pred same_pointer_value(T::in, T::in) is semidet.
-:- pred same_pointer_value_untyped(T::in, U::in) is semidet.
-same_pointer_value(X, Y) :- same_pointer_value_untyped(X, Y).
+same_pointer_value(X, Y) :-
+ same_pointer_value_untyped(X, Y).
+
+:- pred same_pointer_value_untyped(T::in, U::in) is semidet.
:- pragma foreign_proc("C#",
same_pointer_value_untyped(T1::in, T2::in),
@@ -3835,6 +3866,8 @@ same_pointer_value_untyped(_, _) :-
% matching foreign_proc version.
private_builtin.sorry("same_pointer_value_untyped").
+%---------------------------------------------------------------------------%
+
:- func get_target_lang_rep(T) = string.
:- pragma foreign_proc("C",
@@ -3896,6 +3929,8 @@ get_target_lang_rep(_) = "some_foreign_value".
get_primary_tag(_) = 0u8 :-
det_unimplemented("get_primary_tag").
+%---------------------------------------------------------------------------%
+
:- func get_remote_secondary_tag(T) = int.
:- pragma foreign_proc("C#",
@@ -3924,6 +3959,8 @@ get_primary_tag(_) = 0u8 :-
get_remote_secondary_tag(_::in) = (0::out) :-
det_unimplemented("get_remote_secondary_tag").
+%---------------------------------------------------------------------------%
+
:- type sectag_locn
---> stag_none
; stag_none_direct_arg
@@ -3934,14 +3971,13 @@ get_remote_secondary_tag(_::in) = (0::out) :-
; stag_remote
; stag_variable.
-% :- pragma foreign_type("Java", sectag_locn, "jmercury.runtime.Sectag_Locn").
-
:- type du_sectag_alternatives ---> du_sectag_alternatives(c_pointer).
:- pragma foreign_type("C#", du_sectag_alternatives,
"runtime.DuFunctorDesc[]").
:- pragma foreign_type("Java", du_sectag_alternatives,
"jmercury.runtime.DuFunctorDesc[]").
+ % XXX just use the same names as the C runtime
:- type ptag_entry ---> ptag_entry(c_pointer).
:- pragma foreign_type("C#", ptag_entry, "runtime.DuPtagLayout").
:- pragma foreign_type("Java", ptag_entry, "jmercury.runtime.DuPtagLayout").
@@ -3962,28 +3998,42 @@ get_remote_secondary_tag(_::in) = (0::out) :-
:- pragma foreign_type("C#", typeinfo_locn, "runtime.DuExistLocn").
:- pragma foreign_type("Java", typeinfo_locn, "jmercury.runtime.DuExistLocn").
-:- func ptag_index(uint8, type_layout) = ptag_entry.
+%---------------------%
- % This is an "unimplemented" definition in Mercury, which will be
- % used by default.
+:- pred det_index_or_search_ptag_layout(type_ctor_info::in, uint8::in,
+ ptag_entry::out) is det.
+
+det_index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry) :-
+ ( if index_or_search_ptag_layout(TypeCtorInfo, PTag, PTagEntry0) then
+ PTagEntry = PTagEntry0
+ else
+ unexpected($pred, "no functor for ptag")
+ ).
+
+:- pred index_or_search_ptag_layout(type_ctor_info::in, uint8::in,
+ ptag_entry::out) is semidet.
-ptag_index(_, _) = _ :-
- private_builtin.sorry("ptag_index").
+index_or_search_ptag_layout(_, _, _) :-
+ private_builtin.sorry("index_or_search_ptag_layout").
:- pragma foreign_proc("C#",
- ptag_index(X::in, TypeLayout::in) = (PtagEntry::out),
+ index_or_search_ptag_layout(TypeCtorInfo::in, PTag::in, PTagEntry::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- PtagEntry = TypeLayout.layout_du()[X];
+ PTagEntry = TypeCtorInfo.index_or_search_ptag_layout(PTag);
+ SUCCESS_INDICATOR = (PTagEntry != null);
").
:- pragma foreign_proc("Java",
- ptag_index(X::in, TypeLayout::in) = (PtagEntry::out),
+ index_or_search_ptag_layout(TypeCtorInfo::in, PTag::in, PTagEntry::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- PtagEntry = TypeLayout.layout_du()[X];
+ PTagEntry = TypeCtorInfo.index_or_search_ptag_layout(PTag);
+ SUCCESS_INDICATOR = (PTagEntry != null);
").
+%---------------------%
+
:- func sectag_locn(ptag_entry) = sectag_locn.
sectag_locn(_) = _ :-
@@ -4005,25 +4055,66 @@ sectag_locn(_) = _ :-
SectagLocn = new rtti_implementation.Sectag_locn_0(SL_struct.value);
").
-:- func du_sectag_alternatives(int, ptag_entry) = du_functor_desc.
+%---------------------%
+
+:- pred index_sectag_functor(ptag_entry, int, du_functor_desc).
+:- mode index_sectag_functor(in, in, out) is det.
+
+index_sectag_functor(_, _, _) :-
+ private_builtin.sorry("index_sectag_functor").
+
+:- pragma foreign_proc("C#",
+ index_sectag_functor(PTagEntry::in, SecTag::in, FunctorDesc::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ FunctorDesc = PTagEntry.sectag_alternatives[SecTag];
+").
+
+:- pragma foreign_proc("Java",
+ index_sectag_functor(PTagEntry::in, SecTag::in, FunctorDesc::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ FunctorDesc = PTagEntry.sectag_alternatives[SecTag];
+").
+
+%---------------------%
+
+:- pred det_index_or_search_sectag_functor(ptag_entry, int, du_functor_desc).
+:- mode det_index_or_search_sectag_functor(in, in, out) is det.
+
+det_index_or_search_sectag_functor(PTagEntry, SecTag, FunctorDesc) :-
+ ( if index_or_search_sectag_functor(PTagEntry, SecTag, FunctorDesc0) then
+ FunctorDesc = FunctorDesc0
+ else
+ unexpected($pred, "no functor for sectag")
+ ).
+
+:- pred index_or_search_sectag_functor(ptag_entry, int, du_functor_desc).
+:- mode index_or_search_sectag_functor(in, in, out) is semidet.
-du_sectag_alternatives(_, _) = _ :-
- private_builtin.sorry("sectag_alternatives").
+index_or_search_sectag_functor(_, _, _) :-
+ private_builtin.sorry("index_or_search_sectag_alternatives").
:- pragma foreign_proc("C#",
- du_sectag_alternatives(X::in, PTagEntry::in) = (FunctorDescriptor::out),
+ index_or_search_sectag_functor(PTagEntry::in, SecTag::in,
+ FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- FunctorDescriptor = PTagEntry.sectag_alternatives[X];
+ FunctorDesc = PTagEntry.index_or_search_sectag_functor(SecTag);
+ SUCCESS_INDICATOR = (FunctorDesc != null);
").
:- pragma foreign_proc("Java",
- du_sectag_alternatives(X::in, PTagEntry::in) = (FunctorDescriptor::out),
+ index_or_search_sectag_functor(PTagEntry::in, SecTag::in,
+ FunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- FunctorDescriptor = PTagEntry.sectag_alternatives[X];
+ FunctorDesc = PTagEntry.index_or_search_sectag_functor(SecTag);
+ SUCCESS_INDICATOR = (FunctorDesc != null);
").
+%---------------------%
+
:- func typeinfo_locns_index(int, exist_info) = typeinfo_locn.
typeinfo_locns_index(_, _) = _ :-
@@ -4045,6 +4136,8 @@ typeinfo_locns_index(_, _) = _ :-
TypeInfoLocn = ExistInfo.exist_typeinfo_locns[VarNum - 1];
").
+%---------------------%
+
:- func exist_info_typeinfos_plain(exist_info) = int16.
exist_info_typeinfos_plain(_) = -1i16 :-
@@ -4064,6 +4157,8 @@ exist_info_typeinfos_plain(_) = -1i16 :-
TypeInfosPlain = ExistInfo.exist_typeinfos_plain;
").
+%---------------------%
+
:- func exist_info_tcis(exist_info) = int16.
exist_info_tcis(_) = -1i16 :-
@@ -4083,6 +4178,8 @@ exist_info_tcis(_) = -1i16 :-
TCIs = ExistInfo.exist_tcis;
").
+%---------------------%
+
:- func exist_arg_num(typeinfo_locn) = int16.
exist_arg_num(_) = -1i16 :-
@@ -4102,6 +4199,8 @@ exist_arg_num(_) = -1i16 :-
ArgNum = TypeInfoLocn.exist_arg_num;
").
+%---------------------%
+
:- func exist_offset_in_tci(typeinfo_locn) = int16.
exist_offset_in_tci(_) = -1i16 :-
@@ -4121,6 +4220,8 @@ exist_offset_in_tci(_) = -1i16 :-
ArgNum = TypeInfoLocn.exist_offset_in_tci;
").
+%---------------------%
+
:- func get_type_info_from_term(U, int16) = type_info.
get_type_info_from_term(_, _) = _ :-
@@ -4163,6 +4264,8 @@ get_type_info_from_term(_, _) = _ :-
}
").
+%---------------------%
+
:- func get_typeclass_info_from_term(U, int16) = typeclass_info.
get_typeclass_info_from_term(_, _) = _ :-
@@ -4205,6 +4308,8 @@ get_typeclass_info_from_term(_, _) = _ :-
}
").
+%---------------------%
+
:- func typeclass_info_type_info(typeclass_info, int) = type_info.
typeclass_info_type_info(TypeClassInfo, Index) = TypeInfo :-
@@ -4354,28 +4459,6 @@ type_info_index_as_pti(TypeInfo, _) = PseudoTypeInfo :-
set_type_info_index(_, _, _, !TypeInfo) :-
det_unimplemented("set_type_info_index").
-%---------------------%
-
-:- pred semidet_unimplemented(string::in) is semidet.
-:- pragma consider_used(semidet_unimplemented/1).
-
-semidet_unimplemented(S) :-
- ( if semidet_succeed then
- sorry($module, S)
- else
- semidet_succeed
- ).
-
-:- pred det_unimplemented(string::in) is det.
-:- pragma consider_used(det_unimplemented/1).
-
-det_unimplemented(S) :-
- ( if semidet_succeed then
- sorry($module, S)
- else
- true
- ).
-
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
@@ -4404,6 +4487,8 @@ type_ctor_arity(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_arity").
+%---------------------------------------------------------------------------%
+
:- func type_ctor_unify_pred(type_ctor_info) = unify_or_compare_pred.
:- pragma foreign_proc("C#",
type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
@@ -4431,7 +4516,10 @@ type_ctor_unify_pred(_) = unify_or_compare_pred :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_unify_pred").
+%---------------------------------------------------------------------------%
+
:- func type_ctor_compare_pred(type_ctor_info) = unify_or_compare_pred.
+
:- pragma foreign_proc("C#",
type_ctor_compare_pred(TypeCtorInfo::in) = (ComparePred::out),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -4461,13 +4549,17 @@ type_ctor_compare_pred(_) = unify_or_compare_pred :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_compare_pred").
+%---------------------------------------------------------------------------%
+
:- func get_type_ctor_rep(type_ctor_info) = type_ctor_rep.
+
:- pragma foreign_proc("C#",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
TypeCtorRep = (Type_ctor_rep_0) TypeCtorInfo.type_ctor_rep;
").
+
:- pragma foreign_proc("Java",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -4475,6 +4567,7 @@ type_ctor_compare_pred(_) = unify_or_compare_pred :-
TypeCtorRep = rtti_implementation.static_type_ctor_rep[
TypeCtorInfo.type_ctor_rep.value];
").
+
:- pragma foreign_proc("C",
get_type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
[will_not_call_mercury, promise_pure, thread_safe],
@@ -4482,11 +4575,14 @@ type_ctor_compare_pred(_) = unify_or_compare_pred :-
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
TypeCtorRep = MR_type_ctor_rep(tci);
").
+
get_type_ctor_rep(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
private_builtin.sorry("type_ctor_rep").
+%---------------------------------------------------------------------------%
+
:- func type_ctor_module_name(type_ctor_info) = string.
:- pragma foreign_proc("C#",
@@ -4516,6 +4612,8 @@ type_ctor_module_name(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_module_name").
+%---------------------------------------------------------------------------%
+
:- func type_ctor_name(type_ctor_info) = string.
:- pragma foreign_proc("C#",
@@ -4553,6 +4651,9 @@ type_ctor_name(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_name").
+%---------------------------------------------------------------------------%
+
+ % XXX exactly the same as get_type_functors
:- func get_type_ctor_functors(type_ctor_info) = type_functors.
:- pragma foreign_proc("C#",
@@ -4574,6 +4675,8 @@ get_type_ctor_functors(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("get_type_ctor_functors").
+%---------------------------------------------------------------------------%
+
:- func get_type_functors(type_ctor_info) = type_functors.
:- pragma foreign_proc("C#",
@@ -4593,6 +4696,8 @@ get_type_ctor_functors(_) = _ :-
get_type_functors(_) = _ :-
private_builtin.sorry("get_type_functors").
+%---------------------------------------------------------------------------%
+
:- func get_type_layout(type_ctor_info) = type_layout.
:- pragma foreign_proc("C#",
@@ -4620,6 +4725,8 @@ get_type_layout(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("get_type_layout").
+%---------------------------------------------------------------------------%
+
:- func type_ctor_num_functors(type_ctor_info) = int.
:- pragma foreign_proc("C#",
@@ -4641,6 +4748,8 @@ type_ctor_num_functors(_) = _ :-
% matching foreign_proc version.
private_builtin.sorry("type_ctor_num_functors").
+%---------------------------------------------------------------------------%
+
:- pred type_ctor_search_functor_number_map(type_ctor_info::in,
int::in, int::out) is semidet.
@@ -4739,6 +4848,8 @@ type_ctor_search_functor_number_map(_, _, _) :-
; tcr_notag_ground
; tcr_notag_ground_usereq.
+%---------------------%
+
:- func du_functor_desc(type_ctor_rep, int, type_functors) = du_functor_desc.
:- mode du_functor_desc(in(du), in, in) = out is det.
@@ -4761,6 +4872,8 @@ du_functor_desc(_, Num, TypeFunctors) = DuFunctorDesc :-
DuFunctorDesc = TypeFunctors.functors_du()[X];
").
+%---------------------%
+
:- func du_functor_name(du_functor_desc) = string.
du_functor_name(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(0).
@@ -4779,6 +4892,8 @@ du_functor_name(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(0).
Name = DuFunctorDesc.du_functor_name;
").
+%---------------------%
+
:- func du_functor_arity(du_functor_desc) = int16.
du_functor_arity(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(1).
@@ -4797,6 +4912,8 @@ du_functor_arity(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(1).
Arity = DuFunctorDesc.du_functor_orig_arity;
").
+%---------------------%
+
:- func du_functor_ordinal(du_functor_desc) = int32.
du_functor_ordinal(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(6).
@@ -4815,6 +4932,8 @@ du_functor_ordinal(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(6).
Ordinal = DuFunctorDesc.du_functor_ordinal;
").
+%---------------------%
+
:- func du_functor_arg_types(du_functor_desc) = arg_types.
du_functor_arg_types(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(7).
@@ -4833,6 +4952,8 @@ du_functor_arg_types(DuFunctorDesc) = DuFunctorDesc ^ unsafe_index(7).
ArgTypes = DuFunctorDesc.du_functor_arg_types;
").
+%---------------------%
+
:- pred get_du_functor_arg_names(du_functor_desc::in, arg_names::out)
is semidet.
@@ -4858,6 +4979,8 @@ get_du_functor_arg_names(DuFunctorDesc, ArgNames) :-
SUCCESS_INDICATOR = (ArgNames != null);
").
+%---------------------%
+
:- func arg_names_index(arg_names, int) = string.
:- pragma foreign_proc("C#",
@@ -4877,6 +5000,8 @@ get_du_functor_arg_names(DuFunctorDesc, ArgNames) :-
arg_names_index(_, _) = _ :-
private_builtin.sorry("arg_names_index/2").
+%---------------------%
+
:- pred search_arg_names(arg_names::in, int::in, int::in, string::in, int::out)
is semidet.
@@ -4888,6 +5013,8 @@ search_arg_names(ArgNames, I, Arity, Name, Index) :-
search_arg_names(ArgNames, I + 1, Arity, Name, Index)
).
+%---------------------%
+
:- pred get_du_functor_exist_info(du_functor_desc::in, exist_info::out)
is semidet.
@@ -4913,7 +5040,7 @@ get_du_functor_exist_info(DuFunctorDesc, ExistInfo) :-
SUCCESS_INDICATOR = (ExistInfo != null);
").
-%---------------------------------------------------------------------------%
+%---------------------%
:- func get_enum_functor_desc(type_ctor_rep::in(enum), int::in,
type_functors::in) = (enum_functor_desc::out) is det.
@@ -4937,28 +5064,71 @@ get_enum_functor_desc(_, Num, TypeFunctors) = EnumFunctorDesc :-
EnumFunctorDesc = (TypeFunctors.functors_enum())[X];
").
-:- func get_enum_functor_desc_from_layout_enum(type_ctor_rep::in(enum),
- int::in, type_layout::in) = (enum_functor_desc::out) is det.
+%---------------------%
+
+:- pred index_enum_functor_desc(type_ctor_info::in, int::in,
+ enum_functor_desc::out) is det.
-get_enum_functor_desc_from_layout_enum(_, Num, TypeLayout) = EnumFunctorDesc :-
- EnumFunctorDesc = TypeLayout ^ unsafe_index(Num).
+index_enum_functor_desc(_, _, _) :-
+ private_builtin.sorry("index_enum_functor_desc").
:- pragma foreign_proc("C#",
- get_enum_functor_desc_from_layout_enum(_TypeCtorRep::in(enum), X::in,
- TypeLayout::in) = (EnumFunctorDesc::out),
+ index_enum_functor_desc(TypeCtorInfo::in, Ordinal::in,
+ EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- EnumFunctorDesc = (TypeLayout.layout_enum())[X];
+ EnumFunctorDesc = TypeCtorInfo.type_layout.layout_enum()[Ordinal];
").
:- pragma foreign_proc("Java",
- get_enum_functor_desc_from_layout_enum(_TypeCtorRep::in(enum), X::in,
- TypeLayout::in) = (EnumFunctorDesc::out),
+ index_enum_functor_desc(TypeCtorInfo::in, Ordinal::in,
+ EnumFunctorDesc::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- EnumFunctorDesc = (TypeLayout.layout_enum())[X];
+ EnumFunctorDesc = TypeCtorInfo.type_layout.layout_enum()[Ordinal];
").
+%---------------------%
+
+:- pred det_index_or_search_enum_functor_ordinal(type_ctor_info::in, int::in,
+ int::out) is det.
+
+det_index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue, Ordinal) :-
+ ( if
+ index_or_search_enum_functor_ordinal(TypeCtorInfo, EnumValue,
+ Ordinal0)
+ then
+ Ordinal = Ordinal0
+ else
+ unexpected($pred, "no functor for enum value")
+ ).
+
+:- pred index_or_search_enum_functor_ordinal(type_ctor_info::in, int::in,
+ int::out) is semidet.
+
+index_or_search_enum_functor_ordinal(_, _, _) :-
+ private_builtin.sorry("index_or_search_enum_functor_ordinal").
+
+:- pragma foreign_proc("C#",
+ index_or_search_enum_functor_ordinal(TypeCtorInfo::in, EnumValue::in,
+ Ordinal::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Ordinal = TypeCtorInfo.index_or_search_enum_functor_ordinal(EnumValue);
+ SUCCESS_INDICATOR = (Ordinal >= 0);
+").
+
+:- pragma foreign_proc("Java",
+ index_or_search_enum_functor_ordinal(TypeCtorInfo::in, EnumValue::in,
+ Ordinal::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Ordinal = TypeCtorInfo.index_or_search_enum_functor_ordinal(EnumValue);
+ SUCCESS_INDICATOR = (Ordinal >= 0);
+").
+
+%---------------------%
+
:- func enum_functor_name(enum_functor_desc) = string.
enum_functor_name(EnumFunctorDesc) = EnumFunctorDesc ^ unsafe_index(0).
@@ -4977,32 +5147,35 @@ enum_functor_name(EnumFunctorDesc) = EnumFunctorDesc ^ unsafe_index(0).
Name = EnumFunctorDesc.enum_functor_name;
").
-:- func enum_functor_ordinal(enum_functor_desc) = int.
+%---------------------%
+
+:- func enum_functor_value(enum_functor_desc) = int.
-enum_functor_ordinal(EnumFunctorDesc) = EnumFunctorDesc ^ unsafe_index(1).
+enum_functor_value(_) = _ :-
+ private_builtin.sorry("enum_functor_value").
:- pragma foreign_proc("C#",
- enum_functor_ordinal(EnumFunctorDesc::in) = (Ordinal::out),
+ enum_functor_value(EnumFunctorDesc::in) = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Ordinal = EnumFunctorDesc.enum_functor_ordinal;
+ Value = EnumFunctorDesc.enum_functor_value;
").
:- pragma foreign_proc("Java",
- enum_functor_ordinal(EnumFunctorDesc::in) = (Ordinal::out),
+ enum_functor_value(EnumFunctorDesc::in) = (Value::out),
[will_not_call_mercury, promise_pure, thread_safe],
"
- Ordinal = EnumFunctorDesc.enum_functor_ordinal;
+ Value = EnumFunctorDesc.enum_functor_value;
").
-%---------------------------------------------------------------------------%
+%---------------------%
:- func get_foreign_enum_functor_desc(type_ctor_rep, int, type_functors)
= foreign_enum_functor_desc.
:- mode get_foreign_enum_functor_desc(in(foreign_enum), in, in) = out is det.
get_foreign_enum_functor_desc(_, _, _) = _ :-
- unexpected($pred, "get_foreign_enum_functor_desc").
+ private_builtin.sorry("get_foreign_enum_functor_desc").
:- pragma foreign_proc("C#",
get_foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
@@ -5020,14 +5193,14 @@ get_foreign_enum_functor_desc(_, _, _) = _ :-
ForeignEnumFunctorDesc = TypeFunctors.functors_foreign_enum()[X];
").
-%---------------------------------------------------------------------------%
+%---------------------%
:- func foreign_enum_functor_desc(type_ctor_rep, int, type_functors)
= foreign_enum_functor_desc.
:- mode foreign_enum_functor_desc(in(foreign_enum), in, in) = out is det.
foreign_enum_functor_desc(_, _, _) = _ :-
- unexpected($pred, "foreign_enum_functor_desc").
+ private_builtin.sorry("foreign_enum_functor_desc").
:- pragma foreign_proc("C#",
foreign_enum_functor_desc(_TypeCtorRep::in(foreign_enum), X::in,
@@ -5059,6 +5232,8 @@ foreign_enum_functor_desc(_, _, _) = _ :-
}
").
+%---------------------%
+
:- func foreign_enum_functor_name(foreign_enum_functor_desc) = string.
foreign_enum_functor_name(ForeignEnumFunctorDesc) =
@@ -5078,6 +5253,8 @@ foreign_enum_functor_name(ForeignEnumFunctorDesc) =
Name = ForeignEnumFunctorDesc.foreign_enum_functor_name;
").
+%---------------------%
+
:- func foreign_enum_functor_ordinal(foreign_enum_functor_desc) = int.
foreign_enum_functor_ordinal(_) = -1.
@@ -5096,7 +5273,7 @@ foreign_enum_functor_ordinal(_) = -1.
Ordinal = ForeignEnumFunctorDesc.foreign_enum_functor_ordinal;
").
-%---------------------------------------------------------------------------%
+%---------------------%
:- func notag_functor_desc(type_ctor_rep, int, type_functors)
= notag_functor_desc.
@@ -5122,6 +5299,8 @@ notag_functor_desc(_, Num, TypeFunctors) = NoTagFunctorDesc :-
NotagFunctorDesc = TypeFunctors.functors_notag();
").
+%---------------------%
+
:- func notag_functor_name(notag_functor_desc) = string.
notag_functor_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(0).
@@ -5140,6 +5319,8 @@ notag_functor_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(0).
Name = NotagFunctorDesc.no_tag_functor_name;
").
+%---------------------%
+
:- func notag_functor_arg_type(notag_functor_desc) = pseudo_type_info.
notag_functor_arg_type(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(1).
@@ -5158,6 +5339,8 @@ notag_functor_arg_type(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(1).
ArgType = NotagFunctorDesc.no_tag_functor_arg_type;
").
+%---------------------%
+
:- func notag_functor_arg_name(notag_functor_desc) = string.
notag_functor_arg_name(NoTagFunctorDesc) = NoTagFunctorDesc ^ unsafe_index(2).
@@ -5193,6 +5376,7 @@ unsafe_index(_, _) = _ :-
%---------------------------------------------------------------------------%
+ % XXX get rid of this
:- pred null(T::in) is semidet.
:- pragma no_determinism_warning(null/1).
:- pragma consider_used(null/1).
@@ -5223,6 +5407,7 @@ null(_) :-
%---------------------------------------------------------------------------%
+ % XXX get rid of this
:- func null_string = string.
:- pragma foreign_proc("C",
@@ -5312,5 +5497,49 @@ iterate(Start, Max, Func) = Results :-
Results = []
).
+%---------------------------------------------------------------------------%
+
+:- pred high_level_data is semidet.
+:- pragma foreign_proc("Java",
+ high_level_data,
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = true;
+").
+:- pragma foreign_proc("C#",
+ high_level_data,
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = true;
+").
+high_level_data :-
+ ( if semidet_succeed then
+ private_builtin.sorry("high_level_data")
+ else
+ semidet_succeed
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred semidet_unimplemented(string::in) is semidet.
+:- pragma consider_used(semidet_unimplemented/1).
+
+semidet_unimplemented(S) :-
+ ( if semidet_succeed then
+ sorry($module, S)
+ else
+ semidet_succeed
+ ).
+
+:- pred det_unimplemented(string::in) is det.
+:- pragma consider_used(det_unimplemented/1).
+
+det_unimplemented(S) :-
+ ( if semidet_succeed then
+ sorry($module, S)
+ else
+ true
+ ).
+
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
diff --git a/runtime/mercury_construct.c b/runtime/mercury_construct.c
index 8e1382a9c..30723f92a 100644
--- a/runtime/mercury_construct.c
+++ b/runtime/mercury_construct.c
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=c
// Copyright (C) 2002-2005, 2007 The University of Melbourne.
-// Copyright (C) 2014, 2016-2018 The Mercury team.
+// Copyright (C) 2014, 2016-2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
// mercury_construct.c
@@ -18,8 +18,42 @@
#include "mercury_univ.h"
#include "mercury_misc.h" // for MR_fatal_error()
-static int MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
- MR_Construct_Info *construct_info);
+// MR_get_enum_functor_ordinal:
+//
+// Return the functor ordinal number for an enum functor.
+//
+// If you update this you will need to update index_or_search_enum_functor in
+// mercury_ml_expand_body.h.
+
+static MR_Integer
+MR_get_enum_functor_ordinal(MR_TypeCtorInfo type_ctor_info,
+ const MR_EnumFunctorDesc *functor_desc)
+{
+ MR_Integer value;
+
+ value = functor_desc->MR_enum_functor_value;
+
+ // XXX SUBTYPE Remove version check after some time.
+ if ((type_ctor_info->MR_type_ctor_version < MR_RTTI_VERSION__SUBTYPES)
+ || MR_type_ctor_is_layout_indexable(type_ctor_info))
+ {
+ return value;
+ } else {
+ MR_EnumTypeLayout enum_layout;
+ int num_functors;
+ int i;
+
+ enum_layout = MR_type_ctor_layout(type_ctor_info).MR_layout_enum;
+ num_functors = MR_type_ctor_num_functors(type_ctor_info);
+ for (i = 0; i < num_functors; i++) {
+ if (enum_layout[i]->MR_enum_functor_value == value) {
+ return i;
+ }
+ }
+
+ MR_fatal_error("MR_get_enum_functor_ordinal: unknown value");
+ }
+}
// MR_get_functor_info:
//
@@ -32,7 +66,7 @@ static int MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
static int
MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
- MR_Construct_Info *construct_info)
+ MR_bool compute_ordinal, MR_Construct_Info *construct_info)
{
MR_TypeCtorInfo type_ctor_info;
@@ -61,6 +95,8 @@ MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
MR_functors_du[functor_number];
construct_info->functor_info.du_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_du_functor_name;
+ construct_info->functor_ordinal =
+ functor_desc->MR_du_functor_ordinal;
construct_info->arity = functor_desc->MR_du_functor_orig_arity;
construct_info->arg_pseudo_type_infos =
functor_desc->MR_du_functor_arg_types;
@@ -86,6 +122,10 @@ MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
MR_functors_enum[functor_number];
construct_info->functor_info.enum_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_enum_functor_name;
+ construct_info->functor_ordinal =
+ (compute_ordinal)
+ ? MR_get_enum_functor_ordinal(type_ctor_info, functor_desc)
+ : -1;
construct_info->arity = 0;
construct_info->arg_pseudo_type_infos = NULL;
construct_info->arg_names = NULL;
@@ -109,6 +149,8 @@ MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
= functor_desc;
construct_info->functor_name =
functor_desc->MR_foreign_enum_functor_name;
+ construct_info->functor_ordinal =
+ functor_desc->MR_foreign_enum_functor_ordinal;
construct_info->arity = 0;
construct_info->arg_pseudo_type_infos = NULL;
construct_info->arg_names = NULL;
@@ -131,6 +173,7 @@ MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
MR_functors_notag;
construct_info->functor_info.notag_functor_desc = functor_desc;
construct_info->functor_name = functor_desc->MR_notag_functor_name;
+ construct_info->functor_ordinal = 0;
construct_info->arity = 1;
construct_info->arg_pseudo_type_infos =
&functor_desc->MR_notag_functor_arg_type;
@@ -145,10 +188,11 @@ MR_get_functor_info(MR_TypeInfo type_info, int functor_number,
MR_create_type_info(
MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
MR_type_ctor_layout(type_ctor_info).MR_layout_equiv),
- functor_number, construct_info);
+ functor_number, compute_ordinal, construct_info);
case MR_TYPECTOR_REP_TUPLE:
construct_info->functor_name = "{}";
+ construct_info->functor_ordinal = 0;
construct_info->arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
// Tuple types don't have pseudo-type_infos for the functors.
@@ -271,12 +315,13 @@ MR_typecheck_arguments(MR_TypeInfo type_info, int arity, MR_Word arg_list,
MR_bool
MR_get_functors_check_range(int functor_number, MR_TypeInfo type_info,
- MR_Construct_Info *construct_info)
+ MR_bool compute_ordinal, MR_Construct_Info *construct_info)
{
// Check range of functor_number, get functors vector.
return functor_number < MR_get_num_functors(type_info) &&
functor_number >= 0 &&
- MR_get_functor_info(type_info, functor_number, construct_info);
+ MR_get_functor_info(type_info, functor_number, compute_ordinal,
+ construct_info);
}
// MR_get_num_functors:
diff --git a/runtime/mercury_construct.h b/runtime/mercury_construct.h
index 80f7f3b65..049ba1c9e 100644
--- a/runtime/mercury_construct.h
+++ b/runtime/mercury_construct.h
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=c
// Copyright (C) 2002, 2005, 2007 The University of Melbourne.
-// Copyright (C) 2016, 2018 The Mercury team.
+// Copyright (C) 2016, 2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
// mercury_construct.h
@@ -25,6 +25,7 @@ union MR_Construct_Functor_Union {
typedef struct MR_Construct_Info_Struct {
MR_ConstString functor_name;
+ MR_Integer functor_ordinal;
MR_Integer arity;
const MR_PseudoTypeInfo *arg_pseudo_type_infos;
const MR_ConstString *arg_names;
@@ -52,7 +53,7 @@ extern int MR_get_num_functors(MR_TypeInfo type_info);
// calls to this function.
extern MR_bool MR_get_functors_check_range(int functor_number,
- MR_TypeInfo type_info,
+ MR_TypeInfo type_info, MR_bool compute_ordinal,
MR_Construct_Info *construct_info);
// MR_typecheck_arguments:
diff --git a/runtime/mercury_dotnet.cs.in b/runtime/mercury_dotnet.cs.in
index e897581a9..bed8d333d 100644
--- a/runtime/mercury_dotnet.cs.in
+++ b/runtime/mercury_dotnet.cs.in
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=cs
//
// Copyright (C) 2003-2004, 2010-2011 The University of Melbourne.
-// Copyright (C) 2014-2018 The Mercury team.
+// Copyright (C) 2014-2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
//
@@ -383,6 +383,8 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
public ushort type_ctor_flags;
public int[] type_functor_number_map;
+ private const ushort MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE = 0x8;
+
// This attribute is also to prevent cyclic copying in deep_copy.
[System.NonSerialized]
private TypeInfo_Struct cached_type_info;
@@ -418,7 +420,7 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
string module,
string name,
object name_ordered_functor_descs, // TypeFunctors
- object value_ordered_functor_descs, // TypeLayout
+ object ordinal_ordered_functor_descs, // TypeLayout
int num_functors,
ushort flags,
int[] functor_number_map)
@@ -432,7 +434,7 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
type_ctor_module_name = module;
type_ctor_name = name;
type_functors = (TypeFunctors) name_ordered_functor_descs;
- type_layout = (TypeLayout) value_ordered_functor_descs;
+ type_layout = (TypeLayout) ordinal_ordered_functor_descs;
type_ctor_num_functors = num_functors;
type_ctor_flags = flags;
type_functor_number_map = functor_number_map;
@@ -474,6 +476,40 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
}
return cached_type_info;
}
+
+ public int index_or_search_enum_functor_ordinal(int enum_value) {
+ if (flags_is_layout_indexable()) {
+ return enum_value; // same as ordinal
+ }
+
+ EnumFunctorDesc[] layout_enum = type_layout.layout_enum();
+ for (int i = 0; i < layout_enum.Length; i++) {
+ if (layout_enum[i].enum_functor_value == enum_value) {
+ return i;
+ }
+ }
+ return -1;
+ }
+
+ // Return the ptag layout with the given ptag, or null if not found.
+ public DuPtagLayout index_or_search_ptag_layout(byte ptag) {
+ DuPtagLayout[] layout_du = type_layout.layout_du();
+
+ if (flags_is_layout_indexable()) {
+ return layout_du[ptag];
+ }
+
+ foreach (DuPtagLayout ptag_layout in layout_du) {
+ if (ptag_layout.du_ptag == ptag) {
+ return ptag_layout;
+ }
+ }
+ return null;
+ }
+
+ private bool flags_is_layout_indexable() {
+ return (type_ctor_flags & MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE) != 0;
+ }
}
public class TypeInfo_Struct : PseudoTypeInfo {
@@ -742,27 +778,60 @@ public class DuPtagLayout {
public Sectag_Locn sectag_locn;
public /* final */ DuFunctorDesc[] sectag_alternatives;
public sbyte sectag_numbits; // unused in C# grades
+ public byte du_ptag;
+ public byte du_ptag_flags;
+
+ private const byte MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE = 0x1;
public DuPtagLayout(
- uint sharers,
- Sectag_Locn locn,
- DuFunctorDesc[] alts,
- sbyte numbits)
+ uint sectag_sharers,
+ Sectag_Locn sectag_locn,
+ DuFunctorDesc[] sectag_alts,
+ sbyte sectag_numbits,
+ byte du_ptag,
+ byte du_ptag_flags)
{
- sectag_sharers = sharers;
- sectag_locn = locn;
- sectag_alternatives = alts;
- sectag_numbits = numbits;
+ this.sectag_sharers = sectag_sharers;
+ this.sectag_locn = sectag_locn;
+ this.sectag_alternatives = sectag_alts;
+ this.sectag_numbits = sectag_numbits;
+ this.du_ptag = du_ptag;
+ this.du_ptag_flags = du_ptag_flags;
}
public DuPtagLayout(
- uint sharers,
- int locn,
- DuFunctorDesc[] alts,
- sbyte numbits)
- : this(sharers, (Sectag_Locn) locn, alts, numbits)
+ uint sectag_sharers,
+ int sectag_locn,
+ DuFunctorDesc[] sectag_alts,
+ sbyte sectag_numbits,
+ byte du_ptag,
+ byte du_ptag_flags)
+ : this(sectag_sharers,
+ (Sectag_Locn) sectag_locn,
+ sectag_alts,
+ sectag_numbits,
+ du_ptag,
+ du_ptag_flags)
{
}
+
+ public DuFunctorDesc index_or_search_sectag_functor(int sectag) {
+ if (flags_is_sectag_alteratives_indexable()) {
+ return sectag_alternatives[sectag];
+ }
+
+ foreach (DuFunctorDesc desc in sectag_alternatives) {
+ if (desc.du_functor_secondary == sectag) {
+ return desc;
+ }
+ }
+ return null;
+ }
+
+ private bool flags_is_sectag_alteratives_indexable() {
+ return (du_ptag_flags & MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE)
+ != 0;
+ }
}
public class DuArgLocn {
@@ -901,14 +970,14 @@ public class TypeClassMethod {
public class EnumFunctorDesc {
public string enum_functor_name;
- public int enum_functor_ordinal;
+ public int enum_functor_value;
public EnumFunctorDesc() {
}
- public void init(string name, int ordinal) {
+ public void init(string name, int val) {
enum_functor_name = name;
- enum_functor_ordinal = ordinal;
+ enum_functor_value = val;
}
}
diff --git a/runtime/mercury_ml_expand_body.h b/runtime/mercury_ml_expand_body.h
index 24947e881..a5b0710ae 100644
--- a/runtime/mercury_ml_expand_body.h
+++ b/runtime/mercury_ml_expand_body.h
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=c
// Copyright (C) 2001-2007, 2012 The University of Melbourne.
-// Copyright (C) 2013, 2015-2018 The Mercury team.
+// Copyright (C) 2013, 2015-2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
// mercury_ml_expand_body.h
@@ -312,6 +312,117 @@
///////////////////
+// XXX SUBTYPE
+// We maintain compatibility with RTTI structures generated by older versions
+// of the Mercury compiler by not reading from fields that were introduced in
+// newer versions of the RTTI structures. These version checks can be deleted
+// after some time.
+#define tci_version_no_subtypes(tci) \
+ ((tci)->MR_type_ctor_version < MR_RTTI_VERSION__SUBTYPES)
+
+// This performs a linear search for subtype enums. If a subtype has a
+// large number of functors, it may be worth performing a binary search.
+// If you update this, you will need to update MR_get_enum_functor_ordinal.
+#define index_or_search_enum_functor(data, functor_name, functor_ordinal) \
+ do { \
+ MR_TypeLayout type_layout; \
+ MR_EnumTypeLayout enum_layout; \
+ \
+ type_layout = MR_type_ctor_layout(type_ctor_info); \
+ enum_layout = type_layout.MR_layout_enum; \
+ \
+ if (tci_version_no_subtypes(type_ctor_info) || \
+ MR_type_ctor_is_layout_indexable(type_ctor_info)) { \
+ functor_name = enum_layout[data]->MR_enum_functor_name; \
+ functor_ordinal = data; \
+ } else { \
+ int num_functors; \
+ int i; \
+ \
+ num_functors = MR_type_ctor_num_functors(type_ctor_info); \
+ for (i = 0; i < num_functors; i++) { \
+ if (enum_layout[i]->MR_enum_functor_value == data) { \
+ functor_name = enum_layout[i]->MR_enum_functor_name; \
+ functor_ordinal = i; \
+ break; \
+ } \
+ } \
+ MR_assert(i < num_functors); \
+ } \
+ } while (0) \
+
+#define index_or_search_ptag_layout(ptag, ptag_layout) \
+ do { \
+ MR_TypeLayout type_layout; \
+ MR_DuTypeLayout du_type_layout; \
+ \
+ type_layout = MR_type_ctor_layout(type_ctor_info); \
+ du_type_layout = type_layout.MR_layout_du; \
+ \
+ if (tci_version_no_subtypes(type_ctor_info) || \
+ MR_type_ctor_is_layout_indexable(type_ctor_info)) { \
+ ptag_layout = &du_type_layout[ptag]; \
+ } else { \
+ int num_ptags; \
+ int i; \
+ \
+ num_ptags = MR_type_ctor_num_ptags(type_ctor_info); \
+ for (i = 0; i < num_ptags; i++) { \
+ ptag_layout = &du_type_layout[i]; \
+ if (ptag_layout->MR_du_ptag == ptag) { \
+ break; \
+ } \
+ } \
+ \
+ MR_assert(i < num_ptags); \
+ } \
+ } while (0)
+
+#define index_or_search_sectag_functor(ptag_layout, sectag, functor_desc) \
+ do { \
+ if (tci_version_no_subtypes(type_ctor_info) || \
+ (ptag_layout->MR_du_ptag_flags \
+ & MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE)) { \
+ functor_desc = ptag_layout->MR_sectag_alternatives[sectag]; \
+ } else { \
+ int num_sharers; \
+ int i; \
+ \
+ num_sharers = ptag_layout->MR_sectag_sharers; \
+ for (i = 0; i < num_sharers; i++) { \
+ functor_desc = ptag_layout->MR_sectag_alternatives[i]; \
+ if (functor_desc->MR_du_functor_secondary == sectag) { \
+ break; \
+ } \
+ } \
+ MR_assert(i < num_sharers); \
+ } \
+ } while (0) \
+
+#define search_foreign_enum_functor(data, functor_name, functor_ordinal) \
+ do { \
+ int i; \
+ int num_functors; \
+ MR_TypeLayout type_layout; \
+ MR_ForeignEnumTypeLayout fe_layout; \
+ \
+ num_functors = MR_type_ctor_num_functors(type_ctor_info); \
+ type_layout = MR_type_ctor_layout(type_ctor_info); \
+ fe_layout = type_layout.MR_layout_foreign_enum; \
+ \
+ for (i = 0; i < num_functors; i++) { \
+ if (fe_layout[i]->MR_foreign_enum_functor_value == data) { \
+ functor_name = fe_layout[i]->MR_foreign_enum_functor_name; \
+ functor_ordinal = \
+ fe_layout[i]->MR_foreign_enum_functor_ordinal; \
+ break; \
+ } \
+ } \
+ MR_assert(i < num_functors); \
+ } while (0)
+
+///////////////////
+
// These macros set up the results for terms of notag types to requests
// either for all arguments, or for one selected argument.
@@ -541,13 +652,18 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
// else fall through
case MR_TYPECTOR_REP_ENUM:
- handle_functor_name(MR_type_ctor_layout(type_ctor_info).
- MR_layout_enum[*data_word_ptr]->MR_enum_functor_name);
- handle_type_functor_number(type_ctor_info,
- MR_type_ctor_layout(type_ctor_info).
- MR_layout_enum[*data_word_ptr]->MR_enum_functor_ordinal);
+ {
+ MR_Word data;
+ MR_ConstString functor_name = NULL;
+ MR_int_least32_t functor_ordinal = -1;
+
+ data = *data_word_ptr;
+ index_or_search_enum_functor(data, functor_name, functor_ordinal);
+ handle_functor_name(functor_name);
+ handle_type_functor_number(type_ctor_info, functor_ordinal);
handle_zero_arity_args();
return;
+ }
case MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ:
if (noncanon == MR_NONCANON_ABORT) {
@@ -564,29 +680,14 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
case MR_TYPECTOR_REP_FOREIGN_ENUM:
{
- int i;
- int num_functors;
+ MR_Word data;
MR_ConstString functor_name = NULL;
MR_int_least32_t functor_ordinal = -1;
- MR_Integer functor_value;
- MR_TypeLayout type_layout;
- MR_ForeignEnumTypeLayout fe_layout;
// For foreign enumerations, we cannot use the value as an index
// into the type layout, so we just have to do a linear search.
- num_functors = MR_type_ctor_num_functors(type_ctor_info);
- type_layout = MR_type_ctor_layout(type_ctor_info);
- fe_layout = type_layout.MR_layout_foreign_enum;
-
- for (i = 0; i < num_functors; i++) {
- functor_value = fe_layout[i]->MR_foreign_enum_functor_value;
- if (functor_value == *data_word_ptr) {
- functor_name = fe_layout[i]->MR_foreign_enum_functor_name;
- functor_ordinal = fe_layout[i]->MR_foreign_enum_functor_ordinal;
- break;
- }
- }
-
+ data = *data_word_ptr;
+ search_foreign_enum_functor(data, functor_name, functor_ordinal);
MR_assert(functor_name != NULL);
MR_assert(functor_ordinal != -1);
@@ -597,13 +698,19 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
}
case MR_TYPECTOR_REP_DUMMY:
+ {
// We must not refer to the "value" we are asked to deconstruct,
// *data_word_ptr, since it contains garbage.
- handle_functor_name(MR_type_ctor_layout(type_ctor_info).
- MR_layout_enum[0]->MR_enum_functor_name);
+ const MR_Word data = 0;
+ MR_ConstString functor_name = NULL;
+ MR_int_least32_t functor_ordinal = -1; /* unused */
+
+ index_or_search_enum_functor(data, functor_name, functor_ordinal);
+ handle_functor_name(functor_name);
handle_zero_arity_args();
- handle_functor_number(0);
+ handle_functor_number(data);
return;
+ }
case MR_TYPECTOR_REP_DU_USEREQ:
if (noncanon == MR_NONCANON_ABORT) {
@@ -620,7 +727,6 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
case MR_TYPECTOR_REP_DU:
{
- MR_DuTypeLayout du_type_layout;
const MR_DuPtagLayout *ptag_layout;
const MR_DuFunctorDesc *functor_desc;
const MR_DuArgLocn *arg_locns;
@@ -646,10 +752,9 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
MR_Word direct_arg;
int arg_num;
- du_type_layout = MR_type_ctor_layout(type_ctor_info).MR_layout_du;
data = *data_word_ptr;
ptag = MR_tag(data);
- ptag_layout = &du_type_layout[ptag];
+ index_or_search_ptag_layout(ptag, ptag_layout);
switch (ptag_layout->MR_sectag_locn) {
@@ -676,7 +781,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
case MR_SECTAG_LOCAL_REST_OF_WORD:
sectag = MR_unmkbody(data);
- functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ index_or_search_sectag_functor(ptag_layout, sectag, functor_desc);
handle_functor_name_number_arity(expand_info, type_ctor_info,
functor_desc);
assert_no_exist_info(functor_desc, "MR_SECTAG_LOCAL_REST_OF_WORD");
@@ -688,7 +793,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
// XXX ARG_PACK
// Consider storing this mask in the ptag_layout.
((1 << ptag_layout->MR_sectag_numbits) - 1);
- functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ index_or_search_sectag_functor(ptag_layout, sectag, functor_desc);
handle_functor_name_number_arity(expand_info, type_ctor_info,
functor_desc);
assert_no_exist_info(functor_desc, "MR_SECTAG_LOCAL_BITS");
@@ -750,7 +855,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
case MR_SECTAG_REMOTE_FULL_WORD:
sectag = MR_field(ptag, data, 0);
- functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ index_or_search_sectag_functor(ptag_layout, sectag, functor_desc);
handle_functor_name_number_arity(expand_info, type_ctor_info,
functor_desc);
set_exist_info_extra_args(functor_desc, exist_info,
@@ -764,7 +869,7 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
// XXX ARG_PACK
// Consider storing this mask in the ptag_layout.
((1 << ptag_layout->MR_sectag_numbits) - 1);
- functor_desc = ptag_layout->MR_sectag_alternatives[sectag];
+ index_or_search_sectag_functor(ptag_layout, sectag, functor_desc);
handle_functor_name_number_arity(expand_info, type_ctor_info,
functor_desc);
assert_no_exist_info(functor_desc, "MR_SECTAG_LOCAL_BITS");
@@ -1825,6 +1930,12 @@ EXPAND_FUNCTION_NAME(MR_TypeInfo type_info, MR_Word *data_word_ptr,
#undef set_exist_info_extra_args
#undef assert_no_exist_info
+#undef tci_version_no_subtypes
+#undef index_or_search_enum_functor
+#undef index_or_search_ptag_layout
+#undef index_or_search_sectag_functor
+#undef search_foreign_enum_functor
+
#undef notag_arg_build_univ_list
#undef maybe_notag_arg_build_univ_list
#undef set_chosen_for_notag_arg_name
diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h
index 796c62c8d..ed00dca4a 100644
--- a/runtime/mercury_type_info.h
+++ b/runtime/mercury_type_info.h
@@ -1,7 +1,7 @@
// vim: ts=4 sw=4 expandtab ft=c
// Copyright (C) 1995-2007, 2009, 2011-2012 The University of Melbourne.
-// Copyright (C) 2015-2018 The Mercury team.
+// Copyright (C) 2015-2018, 2021 The Mercury team.
// This file is distributed under the terms specified in COPYING.LIB.
// Definitions of the types defining the type_ctor_infos, type_infos,
@@ -70,7 +70,7 @@
// This number should be kept in sync with type_ctor_info_rtti_version in
// compiler/type_ctor_info.m.
-#define MR_RTTI_VERSION MR_RTTI_VERSION__UINT
+#define MR_RTTI_VERSION MR_RTTI_VERSION__SUBTYPES
#define MR_RTTI_VERSION__INITIAL 2
#define MR_RTTI_VERSION__USEREQ 3
#define MR_RTTI_VERSION__CLEAN_LAYOUT 4
@@ -87,6 +87,7 @@
#define MR_RTTI_VERSION__ARG_WIDTHS 15
#define MR_RTTI_VERSION__FUNCTOR_SUBTYPE 16
#define MR_RTTI_VERSION__UINT 17
+#define MR_RTTI_VERSION__SUBTYPES 18
// Check that the RTTI version is in a sensible range.
// The lower bound should be the lowest currently supported version number.
@@ -94,10 +95,11 @@
// If you increase the lower bound, you should also increase the binary
// compatibility version number in runtime/mercury_grade.h (MR_GRADE_PART_0).
//
-// Note that the definition of this macro matters only if it used, and (for
+// Note that the definition of this macro matters only if it is used, and (for
// efficiency) it shouldn't be used except if a period of transition between
// different versions requires different treatment of RTTI structures generated
// by different compiler versions.
+// XXX SUBTYPE set this to MR_RTTI_VERSION__SUBTYPES later
#define MR_TYPE_CTOR_INFO_CHECK_RTTI_VERSION_RANGE(typector) \
assert((typector)->MR_type_ctor_version >= MR_RTTI_VERSION__ARG_WIDTHS)
@@ -955,7 +957,9 @@ typedef struct {
// would probably also require extra space.
} MR_DuArgLocn;
-// This type describes the subtype constraints on the arguments of a functor.
+// This type describes the subtype constraints on the arguments of a functor
+// due to inst information provided in a type definition
+// (unrelated to subtypes introduced by type definitions).
// Currently, we only record whether any such constraints exist.
typedef enum {
@@ -1018,7 +1022,10 @@ typedef const MR_DuFunctorDesc *MR_DuFunctorDescPtr;
typedef struct {
MR_ConstString MR_enum_functor_name;
- MR_int_least32_t MR_enum_functor_ordinal; // XXX MAKE_FIELD_UNSIGNED
+ // The functor value is the same as the functor ordinal number for
+ // non-subtype enum types (the k'th functor is represented by the value k),
+ // but that is not true for subtype enums.
+ MR_int_least32_t MR_enum_functor_value; // XXX MAKE_FIELD_UNSIGNED
} MR_EnumFunctorDesc;
typedef const MR_EnumFunctorDesc *MR_EnumFunctorDescPtr;
@@ -1060,11 +1067,14 @@ typedef const MR_NotagFunctorDesc *MR_NotagFunctorDescPtr;
// interpret, you compute its primary tag and find its MR_DuPtagLayout.
// You then look at the locn field. If it is MR_SECTAG_NONE{,_DIRECT_ARG}, you
// index the alternatives field with zero; if it is MR_SECTAG_{LOCAL,REMOTE},
-// you compute the secondary tag and index the alternatives field with that.
+// you compute the secondary tag and look in the alternatives array with that.
+// The ptag_flags tells if the alternatives array can be indexed, or if it must
+// be searched.
//
// A value of type MR_DuTypeLayout points to an array of MR_DuPtagLayout
-// structures. The element at index k gives information about primary tag
-// value k. The size of the array is recorded in the num_ptags field of the
+// structures. If the type_ctor_info has the LAYOUT_INDEXABLE flag then the
+// element at index k gives information about primary tag value k.
+// The size of the array is recorded in the num_ptags field of the
// type_ctor_info.
typedef struct {
@@ -1082,8 +1092,25 @@ typedef struct {
// compute it potentially millions of times. It could be stored either as
// a MR_uint_least32_t or as a MR_uint_least16_t, depending on how
// conservative we want to be.
+
+ // ptag holds the primary tag that this layout describes.
+ // ptag_flags contains the flags listed below.
+ // XXX ARG_PACK Move these fields at the same time as other fields.
+ MR_uint_least8_t MR_du_ptag;
+ MR_uint_least8_t MR_du_ptag_flags;
} MR_DuPtagLayout;
+// The flag bits here must agree with the ones in encode_du_ptag_layout_flag
+// in compiler/rtti.m, and with constants in java/runtime and
+// mercury_dotnet.cs.in.
+//
+// The sectag_indexable flag is set if the sectag_alternatives array
+// can be indexed using a secondary tag value.
+#define MR_DU_PTAG_FLAG_SECTAG_ALTERATIVES_INDEXABLE 0x1
+
+// An array of ptag layouts, ordered by ptag value.
+// Whether or not it is indexable by ptag value is indicated by the
+// MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE flag.
typedef const MR_DuPtagLayout *MR_DuTypeLayout;
////////////////////////////////////////////////////////////////////////////
@@ -1269,7 +1296,8 @@ struct MR_TypeCtorInfo_Struct {
((tci)->MR_type_ctor_num_functors)
// The flag bits here must agree with the ones in encode_type_ctor_flag
-// in compiler/rtti.m.
+// in compiler/rtti.m, and with constants in java/runtime and
+// mercury_dotnet.cs.in.
//
// We used to have a "reserve tag" flag whose representation was 0x1,
// but we don't supported reserving tags anymore.
@@ -1280,16 +1308,24 @@ struct MR_TypeCtorInfo_Struct {
// The kind of du flag is set for all discriminated union types, even if
// their representation is specialized (as enumerations, notag types etc).
//
+// The layout indexable flag is set for enumerations where the enum layout
+// array is indexable by the enum value, and for discriminated union types
+// where the layout array is indexable by the ptag value.
+//
// The dummy flag must be set for type constructors whose values are not
// actually passed around.
+// XXX no such flag exists
#define MR_TYPE_CTOR_FLAG_VARIABLE_ARITY 0x2
#define MR_TYPE_CTOR_FLAG_KIND_OF_DU 0x4
+#define MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE 0x8
#define MR_type_ctor_has_variable_arity(tci) \
((tci)->MR_type_ctor_flags & MR_TYPE_CTOR_FLAG_VARIABLE_ARITY)
#define MR_type_ctor_is_kind_of_du(tci) \
((tci)->MR_type_ctor_flags & MR_TYPE_CTOR_FLAG_KIND_OF_DU)
+#define MR_type_ctor_is_layout_indexable(tci) \
+ ((tci)->MR_type_ctor_flags & MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE)
////////////////////////////////////////////////////////////////////////////
diff --git a/tests/hard_coded/Mercury.options b/tests/hard_coded/Mercury.options
index f8c3bb6fb..ce0924c9d 100644
--- a/tests/hard_coded/Mercury.options
+++ b/tests/hard_coded/Mercury.options
@@ -74,6 +74,8 @@ MCFLAGS-reuse_ho = --ctgc --no-optimise-higher-order
MCFLAGS-sharing_comb = --ctgc --structure-sharing-widening 2
MCFLAGS-simplify_multi_arm_switch = -O3
MCFLAGS-spawn_native = --no-ansi-c
+MCFLAGS-subtype_pack = --allow-packing-dummies
+MCFLAGS-subtype_rtti = --allow-packing-local-sectags --allow-packing-remote-sectags
MCFLAGS-tail-rec-scc = --inine-linear-tail-rec-sccs
MCFLAGS-term_io_test = --no-warn-unresolved-polymorphism
MCFLAGS-test_imported_no_tag = --no-warn-interface-imports
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index b1c58c7e7..3013f4b99 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -392,6 +392,8 @@ ORDINARY_PROGS = \
string_various \
string_well_formed \
string_well_formed_utf8 \
+ subtype_pack \
+ subtype_rtti \
sv_nested_closures \
sv_record_update \
switch_detect \
diff --git a/tests/hard_coded/subtype_pack.exp b/tests/hard_coded/subtype_pack.exp
new file mode 100644
index 000000000..325cce5ab
--- /dev/null
+++ b/tests/hard_coded/subtype_pack.exp
@@ -0,0 +1,2 @@
+struct(orange, lemon, dummy, notag(notag0(orange)), notag(notag0(lemon)), tagged(42), tagged(4242), lemon, 3.14159, dog, dog, abs_notag(42))
+struct(orange, lemon, dummy, notag(notag0(orange)), notag(notag0(lemon)), tagged(42), tagged(4242), lemon, 3.14159, dog, dog, abs_notag(42))
diff --git a/tests/hard_coded/subtype_pack.m b/tests/hard_coded/subtype_pack.m
new file mode 100644
index 000000000..fc98b4fbf
--- /dev/null
+++ b/tests/hard_coded/subtype_pack.m
@@ -0,0 +1,129 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+%
+% Test that subtype arguments are packed the same as their base types.
+%
+% To view the type representations are decided, run:
+%
+% mmc --make-short-int subtype_pack_2.m
+% mmc --make-int subtype_pack_2.m
+% mmc -C --show-local-type-repns subtype_pack.m
+% cat subtype_pack.type_repns
+%
+%---------------------------------------------------------------------------%
+
+:- module subtype_pack.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module construct.
+:- import_module deconstruct.
+:- import_module list.
+:- import_module string.
+:- import_module type_desc.
+:- import_module univ.
+
+:- import_module subtype_pack_2.
+
+:- type enum
+ ---> apple
+ ; orange
+ ; lemon.
+
+:- type sub_enum =< enum
+ ---> orange
+ ; lemon.
+
+:- type dummy(T)
+ ---> dummy.
+
+:- type sub_dummy =< dummy(sub_enum)
+ ---> dummy.
+
+:- type notag
+ ---> notag(notag0(enum)).
+
+:- type sub_notag =< notag
+ ---> notag(sub_notag0(sub_enum)).
+
+:- type notag0(T)
+ ---> notag0(T).
+
+:- type sub_notag0(T) =< notag0(T)
+ ---> notag0(T).
+
+:- type tagged
+ ---> none
+ ; tagged(int).
+
+:- type sub_tagged =< tagged
+ ---> tagged(int).
+
+:- type struct(T, U)
+ ---> const0
+ ; const1
+ ; struct(
+ f0_1 :: enum, % 2 bits (packed)
+ f0_2 :: enum, % 2 bits (packed)
+ f1_0 :: dummy(enum), % 0 bits
+ f1 :: notag, % word
+ f2 :: sub_notag, % word
+ f3 :: tagged, % word
+ f4 :: sub_tagged, % word
+ f5 :: T, % word
+ f6 :: U, % word
+ f7_1 :: sub_abs_enum, % 3 bits (packed)
+ f7_2 :: sub_abs_enum, % 3 bits (packed)
+ % XXX SUBTYPE
+ % This currently results in an abort in the LLDS backend, and
+ % the MLDS backends generate code that won't compile.
+ %f8_0 :: sub_abs_dummy, % 0 bits
+ f8 :: sub_abs_notag % word
+ ).
+
+:- type substruct =< struct(sub_enum, float)
+ ---> struct(
+ s_f0_1 :: sub_enum, % differs from base
+ s_f0_2 :: sub_enum, % differs from base
+ s_f1_0 :: sub_dummy, % differs from base
+ s_f1 :: sub_notag, % differs from base
+ s_f2 :: sub_notag,
+ s_f3 :: sub_tagged, % differs from base
+ s_f4 :: sub_tagged,
+ s_f5 :: sub_enum, % differs from base
+ s_f6 :: float, % differs from base
+ s_f7_1 :: sub_abs_enum,
+ s_f7_2 :: sub_abs_enum,
+ %s_f8_0 :: sub_abs_dummy,
+ s_f8 :: sub_abs_notag
+ ).
+
+main(!IO) :-
+ Sub = struct(
+ orange,
+ lemon,
+ dummy,
+ notag(notag0(orange)),
+ notag(notag0(lemon)),
+ tagged(42),
+ tagged(4242),
+ lemon,
+ 3.14159,
+ make_sub_abs_enum,
+ make_sub_abs_enum,
+ % make_sub_abs_dummy,
+ make_sub_abs_notag
+ ),
+ io.print_line(Sub : substruct, !IO),
+ % XXX SUBTYPE enable with coerce
+ %Base = coerce(Sub) : struct(_, _),
+ Base = Sub,
+ io.print_line(Base, !IO).
diff --git a/tests/hard_coded/subtype_pack_2.m b/tests/hard_coded/subtype_pack_2.m
new file mode 100644
index 000000000..4655e04f9
--- /dev/null
+++ b/tests/hard_coded/subtype_pack_2.m
@@ -0,0 +1,65 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_pack_2.
+:- interface.
+
+% sub_abs_enum should occupy 3 bits in subtype_pack.struct without needing
+% to export its base type.
+% :- type abs_enum.
+
+:- type sub_abs_enum.
+
+:- type sub_abs_dummy.
+
+:- type sub_abs_notag.
+
+:- func make_sub_abs_enum = sub_abs_enum.
+
+:- func make_sub_abs_dummy = sub_abs_dummy.
+
+:- func make_sub_abs_notag = sub_abs_notag.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type abs_enum
+ ---> ant
+ ; bat
+ ; cat
+ ; dog
+ ; eel.
+
+:- type abs_enum2 =< abs_enum
+ ---> ant
+ ; bat
+ ; cat
+ ; dog.
+
+:- type eqv_enum == abs_enum2.
+:- type eqv_eqv_enum == eqv_enum.
+
+:- type sub_abs_enum =< eqv_eqv_enum
+ ---> bat
+ ; cat
+ ; dog.
+
+:- type abs_dummy
+ ---> dummy.
+
+:- type sub_abs_dummy =< abs_dummy
+ ---> dummy.
+
+:- type abs_notag
+ ---> abs_notag(int).
+
+:- type sub_abs_notag =< abs_notag
+ ---> abs_notag(int).
+
+make_sub_abs_enum = dog.
+
+make_sub_abs_dummy = dummy.
+
+make_sub_abs_notag = abs_notag(42).
diff --git a/tests/hard_coded/subtype_rtti.exp b/tests/hard_coded/subtype_rtti.exp
new file mode 100644
index 000000000..d5f9a2813
--- /dev/null
+++ b/tests/hard_coded/subtype_rtti.exp
@@ -0,0 +1,264 @@
+--------------------
+term
+ dummy
+deconstruct.functor
+ name: dummy
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: dummy
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: dummy
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ dummy
+unify ok
+
+--------------------
+term
+ notag(notag0(orange))
+deconstruct.functor
+ name: notag
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 1
+deconstruct.deconstruct
+ functor name: notag
+ arity: 1
+ args: [univ_cons(notag0(orange))]
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: notag
+ arity: 1
+ arg types: [sub_notag0(sub_color)]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_notag0(subtype_rtti.sub_color)]
+construct.construct
+ notag(notag0(orange))
+unify ok
+
+--------------------
+term
+ f1(42)
+deconstruct.functor
+ name: f1
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 1
+deconstruct.deconstruct
+ functor name: f1
+ arity: 1
+ args: [univ_cons(42)]
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: f1
+ arity: 1
+ arg types: [int]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [int]
+construct.construct
+ f1(42)
+unify ok
+
+--------------------
+term
+ blue
+deconstruct.functor
+ name: blue
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: blue
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 1
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 3
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: blue
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ blue
+unify ok
+
+--------------------
+term
+ f0_a
+deconstruct.functor
+ name: f0_a
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: f0_a
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 5
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: f0_a
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ f0_a
+unify ok
+
+--------------------
+term
+ f0_b(flag_set, blue, banana)
+deconstruct.functor
+ name: f0_b
+ arity: 3
+deconstruct.functor_number_cc
+ functor lex: 1
+ arity: 3
+deconstruct.deconstruct
+ functor name: f0_b
+ arity: 3
+ args: [univ_cons(flag_set), univ_cons(blue), univ_cons(banana)]
+deconstruct.deconstruct_du
+ functor lex: 1
+construct.get_functor_ordinal
+ functor ord: 4
+construct.get_functor_lex
+ functor lex: 1
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 1
+ functor name: f0_b
+ arity: 3
+ arg types: [sub_flag, sub_color, fruit]
+ arg names: [no, no, no]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_flag, subtype_rtti.sub_color, subtype_rtti.fruit]
+construct.construct
+ f0_b(flag_set, blue, banana)
+unify ok
+
+--------------------
+term
+ f2(42)
+deconstruct.functor
+ name: f2
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 2
+ arity: 1
+deconstruct.deconstruct
+ functor name: f2
+ arity: 1
+ args: [univ_cons(42)]
+deconstruct.deconstruct_du
+ functor lex: 2
+construct.get_functor_ordinal
+ functor ord: 3
+construct.get_functor_lex
+ functor lex: 2
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 2
+ functor name: f2
+ arity: 1
+ arg types: [int]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [int]
+construct.construct
+ f2(42)
+unify ok
+
+--------------------
+term
+ f7_b(flag_set, blue, banana, 3.14)
+deconstruct.functor
+ name: f7_b
+ arity: 4
+deconstruct.functor_number_cc
+ functor lex: 4
+ arity: 4
+deconstruct.deconstruct
+ functor name: f7_b
+ arity: 4
+ args: [univ_cons(flag_set), univ_cons(blue), univ_cons(banana), univ_cons(3.14)]
+deconstruct.deconstruct_du
+ functor lex: 4
+construct.get_functor_ordinal
+ functor ord: 1
+construct.get_functor_lex
+ functor lex: 4
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 4
+ functor name: f7_b
+ arity: 4
+ arg types: [sub_flag, sub_color, fruit, float]
+ arg names: [yes("sub_f7_b1"), yes("sub_f7_b2"), yes("sub_f7_b3"), yes("sub_f7_b4")]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_flag, subtype_rtti.sub_color, subtype_rtti.fruit, float]
+construct.construct
+ f7_b(flag_set, blue, banana, 3.14)
+unify ok
+
diff --git a/tests/hard_coded/subtype_rtti.exp2 b/tests/hard_coded/subtype_rtti.exp2
new file mode 100644
index 000000000..5e166a5c3
--- /dev/null
+++ b/tests/hard_coded/subtype_rtti.exp2
@@ -0,0 +1,262 @@
+--------------------
+term
+ dummy
+deconstruct.functor
+ name: dummy
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: dummy
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: dummy
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ dummy
+unify ok
+
+--------------------
+term
+ notag(notag0(orange))
+deconstruct.functor
+ name: notag
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 1
+deconstruct.deconstruct
+ functor name: notag
+ arity: 1
+ args: [univ_cons(notag0(orange))]
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: notag
+ arity: 1
+ arg types: [some_pseudo_type_desc]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_notag0(subtype_rtti.sub_color)]
+construct.construct
+ notag(notag0(orange))
+unify ok
+
+--------------------
+term
+ f1(42)
+deconstruct.functor
+ name: f1
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 1
+deconstruct.deconstruct
+ functor name: f1
+ arity: 1
+ args: [univ_cons(42)]
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 0
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 1
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: f1
+ arity: 1
+ arg types: [some_pseudo_type_desc]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [int]
+construct.construct skipped
+
+--------------------
+term
+ blue
+deconstruct.functor
+ name: blue
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: blue
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 1
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 3
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: blue
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ blue
+unify ok
+
+--------------------
+term
+ f0_a
+deconstruct.functor
+ name: f0_a
+ arity: 0
+deconstruct.functor_number_cc
+ functor lex: 0
+ arity: 0
+deconstruct.deconstruct
+ functor name: f0_a
+ arity: 0
+ args: []
+deconstruct.deconstruct_du
+ functor lex: 0
+construct.get_functor_ordinal
+ functor ord: 5
+construct.get_functor_lex
+ functor lex: 0
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 0
+ functor name: f0_a
+ arity: 0
+ arg types: []
+ arg names: []
+construct.find_functor
+ arg type descs: []
+construct.construct
+ f0_a
+unify ok
+
+--------------------
+term
+ f0_b(flag_set, blue, banana)
+deconstruct.functor
+ name: f0_b
+ arity: 3
+deconstruct.functor_number_cc
+ functor lex: 1
+ arity: 3
+deconstruct.deconstruct
+ functor name: f0_b
+ arity: 3
+ args: [univ_cons(flag_set), univ_cons(blue), univ_cons(banana)]
+deconstruct.deconstruct_du
+ functor lex: 1
+construct.get_functor_ordinal
+ functor ord: 4
+construct.get_functor_lex
+ functor lex: 1
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 1
+ functor name: f0_b
+ arity: 3
+ arg types: [some_pseudo_type_desc, some_pseudo_type_desc, some_pseudo_type_desc]
+ arg names: [no, no, no]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_flag, subtype_rtti.sub_color, subtype_rtti.fruit]
+construct.construct
+ f0_b(flag_set, blue, banana)
+unify ok
+
+--------------------
+term
+ f2(42)
+deconstruct.functor
+ name: f2
+ arity: 1
+deconstruct.functor_number_cc
+ functor lex: 2
+ arity: 1
+deconstruct.deconstruct
+ functor name: f2
+ arity: 1
+ args: [univ_cons(42)]
+deconstruct.deconstruct_du
+ functor lex: 2
+construct.get_functor_ordinal
+ functor ord: 3
+construct.get_functor_lex
+ functor lex: 2
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 2
+ functor name: f2
+ arity: 1
+ arg types: [some_pseudo_type_desc]
+ arg names: [no]
+construct.find_functor
+ arg type descs: [int]
+construct.construct
+ f2(42)
+unify ok
+
+--------------------
+term
+ f7_b(flag_set, blue, banana, 3.14)
+deconstruct.functor
+ name: f7_b
+ arity: 4
+deconstruct.functor_number_cc
+ functor lex: 4
+ arity: 4
+deconstruct.deconstruct
+ functor name: f7_b
+ arity: 4
+ args: [univ_cons(flag_set), univ_cons(blue), univ_cons(banana), univ_cons(3.14)]
+deconstruct.deconstruct_du
+ functor lex: 4
+construct.get_functor_ordinal
+ functor ord: 1
+construct.get_functor_lex
+ functor lex: 4
+construct.num_functors
+ num functors: 6
+construct.get_functor_with_names
+ functor lex: 4
+ functor name: f7_b
+ arity: 4
+ arg types: [some_pseudo_type_desc, some_pseudo_type_desc, some_pseudo_type_desc, some_pseudo_type_desc]
+ arg names: [yes("sub_f7_b1"), yes("sub_f7_b2"), yes("sub_f7_b3"), yes("sub_f7_b4")]
+construct.find_functor
+ arg type descs: [subtype_rtti.sub_flag, subtype_rtti.sub_color, subtype_rtti.fruit, float]
+construct.construct
+ f7_b(flag_set, blue, banana, 3.14)
+unify ok
+
diff --git a/tests/hard_coded/subtype_rtti.m b/tests/hard_coded/subtype_rtti.m
new file mode 100644
index 000000000..35470df82
--- /dev/null
+++ b/tests/hard_coded/subtype_rtti.m
@@ -0,0 +1,285 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+%
+% The .exp file is for C backends.
+% The .exp2 file is for Java and C# backends.
+%
+%---------------------------------------------------------------------------%
+
+:- module subtype_rtti.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module construct.
+:- import_module deconstruct.
+:- import_module int.
+:- import_module list.
+:- import_module string.
+:- import_module type_desc.
+:- import_module univ.
+
+:- type dummy(T)
+ ---> dummy.
+
+:- type sub_dummy =< dummy(sub_color)
+ ---> dummy.
+
+:- type notag
+ ---> notag(notag0(color)).
+
+:- type sub_notag =< notag
+ ---> notag(sub_notag0(sub_color)).
+
+:- type notag0(T)
+ ---> notag0(T).
+
+:- type sub_notag0(T) =< notag0(T)
+ ---> notag0(T).
+
+:- type tagged
+ ---> f0
+ ; f1(int).
+
+:- type sub_tagged =< tagged
+ ---> f1(int).
+
+ % An enum type whose representation takes 1 bit.
+:- type flag
+ ---> flag_clear
+ ; flag_set.
+
+ % This is an enum with one constructor, not a dummy type.
+:- type sub_flag =< flag
+ ---> flag_set. % lex 0, ord 0
+
+ % An enum type whose representation takes 2 bits.
+:- type color
+ ---> red
+ ; green
+ ; blue
+ ; orange.
+
+ % This is also an enum. The functor ordinals differ from the base type.
+:- type sub_color =< color
+ ---> orange % lex 2, ord 0
+ ; blue % lex 0, ord 1
+ ; green. % lex 1, ord 2
+
+ % An enum type whose representation takes 3 bits.
+:- type fruit
+ ---> apple
+ ; pear
+ ; peach
+ ; orange
+ ; banana.
+
+ % Every function symbol fN* should be allocated primary tag N.
+ % The function symbols whose names end in _[abc] share their
+ % primary tags. being distinguished by a local (f0) or remote (f7)
+ % secondary tag.
+:- type t
+ ---> f0_a
+ ; f0_b(f0_b1 :: flag, f0_b2 :: color, f0_b3 :: fruit)
+ ; f0_c(f0_c1 :: color, f0_c2 :: fruit, f0_c3 :: flag)
+ ; f1(int)
+ ; f2(int)
+ ; f3(int)
+ ; f4(int)
+ ; f5(int)
+ ; f6(int)
+ ; f7_a(f7_a1 :: int)
+ ; f7_b(f7_b1 :: flag, f7_b2 :: color, f7_b3 :: fruit, f7_b4 :: float)
+ ; f7_c(f7_c1 :: fruit, f7_c2 :: flag, f7_c3 :: color, f7_c4 :: int).
+
+ % The function ordinals differ from the base type.
+:- type sub_t =< t
+ ---> f7_c(fruit, flag, color, int) % lex 5, ord 0
+ ; f7_b( % lex 4, ord 1
+ sub_f7_b1 :: sub_flag,
+ sub_f7_b2 :: sub_color,
+ sub_f7_b3 :: fruit,
+ sub_f7_b4 :: float
+ )
+ ; f6(int) % lex 3, ord 2
+ ; f2(int) % lex 2, ord 3
+ ; f0_b(sub_flag, sub_color, fruit) % lex 1, ord 4
+ ; f0_a. % lex 0, ord 5
+
+main(!IO) :-
+ % dummy
+ Dummy = dummy : sub_dummy,
+ test(Dummy, !IO),
+
+ % notag
+ Notag = notag(notag0(orange)) : sub_notag,
+ test(Notag, !IO),
+
+ % tagged
+ Tagged = f1(42) : sub_tagged,
+ test(Tagged, !IO),
+
+ % enum
+ Color = blue : sub_color,
+ test(Color, !IO),
+
+ % MR_SECTAG_LOCAL_BITS
+ F0_A = f0_a : sub_t,
+ test(F0_A, !IO),
+
+ % MR_SECTAG_LOCAL_BITS with --allow-packing-local-sectags
+ F0_B = f0_b(flag_set, blue, banana) : sub_t,
+ test(F0_B, !IO),
+
+ % MR_SECTAG_NONE
+ F2 = f2(42) : sub_t,
+ test(F2, !IO),
+
+ % MR_SECTAG_REMOTE_BITS with --allow-packing-remote-sectags
+ F7_B = f7_b(flag_set, blue, banana, 3.14) : sub_t,
+ test(F7_B, !IO).
+
+:- pred test(T::in, io::di, io::uo) is cc_multi.
+
+test(Term, !IO) :-
+ io.write_string("--------------------\n", !IO),
+ io.write_string("term\n\t", !IO),
+ io.print_line(Term, !IO),
+
+ ( if deconstruct.functor(Term, do_not_allow, Functor, Arity) then
+ io.write_string("deconstruct.functor\n", !IO),
+ print_value("name", Functor, !IO),
+ print_value("arity", Arity, !IO)
+ else
+ io.write_string("deconstruct.functor failed\n", !IO)
+ ),
+
+ % deconstruct.functor_number is not yet implemented for Java/C#
+ % so use functor_number_cc.
+ ( if deconstruct.functor_number_cc(Term, FunctorLexA, ArityA) then
+ io.write_string("deconstruct.functor_number_cc\n", !IO),
+ print_value("functor lex", FunctorLexA, !IO),
+ print_value("arity", ArityA, !IO)
+ else
+ io.write_string("deconstruct.functor_number_cc failed\n", !IO)
+ ),
+
+ deconstruct.deconstruct(Term, do_not_allow, Functor, Arity, Args),
+ io.write_string("deconstruct.deconstruct\n", !IO),
+ print_value("functor name", Functor, !IO),
+ print_value("arity", Arity, !IO),
+ print_value("args", Args, !IO),
+
+ TypeDesc = type_of(Term),
+
+ ( if
+ deconstruct.deconstruct_du(Term, do_not_allow, FunctorLex, Arity, Args)
+ then
+ io.write_string("deconstruct.deconstruct_du\n", !IO),
+ print_value("functor lex", FunctorLex, !IO),
+
+ ( if
+ construct.get_functor_ordinal(TypeDesc, FunctorLex, FunctorOrdinal)
+ then
+ io.write_string("construct.get_functor_ordinal\n", !IO),
+ print_value("functor ord", FunctorOrdinal, !IO),
+
+ ( if
+ construct.get_functor_lex(TypeDesc, FunctorOrdinal) =
+ FunctorLexB
+ then
+ io.write_string("construct.get_functor_lex\n", !IO),
+ print_value("functor lex", FunctorLexB, !IO)
+ else
+ io.write_string("construct.get_functor_lex failed\n", !IO)
+ )
+ else
+ io.write_string("construct.get_functor_ordinal failed\n", !IO)
+ ),
+
+ ( if construct.num_functors(TypeDesc) = NumFunctors then
+ io.write_string("construct.num_functors\n", !IO),
+ print_value("num functors", NumFunctors, !IO)
+ else
+ io.write_string("construct.num_functors failed\n", !IO)
+ ),
+
+ ( if
+ construct.get_functor_with_names(TypeDesc, FunctorLex, Name,
+ Arity, ArgTypes, ArgNames)
+ then
+ io.write_string("construct.get_functor_with_names\n", !IO),
+ print_value("functor lex", FunctorLex, !IO),
+ print_value("functor name", Name, !IO),
+ print_value("arity", Arity, !IO),
+ print_value("arg types", ArgTypes, !IO),
+ print_value("arg names", ArgNames, !IO),
+
+ ( if
+ construct.find_functor(TypeDesc, Name, Arity, FunctorLex,
+ ArgTypeDescs)
+ then
+ io.write_string("construct.find_functor\n", !IO),
+ print_value("arg type descs", ArgTypeDescs, !IO)
+ else
+ io.write_string("construct.find_functor failed\n", !IO)
+ )
+ else
+ io.write_string("construct.find_functor failed\n", !IO)
+ ),
+
+ % XXX SUBTYPE construct of sub_tagged currently does not work on
+ % Java/C# backends (see ML_construct_du in rtti_implementation.m).
+ % Revisit this after updating high-level data backends.
+ ( if
+ is_java_or_csharp,
+ dynamic_cast(Term, _ : sub_tagged)
+ then
+ io.write_string("construct.construct skipped\n", !IO)
+ else if construct.construct(TypeDesc, FunctorLex, Args) = Univ then
+ io.write_string("construct.construct\n\t", !IO),
+ io.print_line(Univ, !IO),
+ ( if univ_to_type(Univ, Term) then
+ io.write_string("unify ok\n", !IO)
+ else
+ io.write_string("unify failed\n", !IO)
+ )
+ else
+ io.write_string("construct failed\n", !IO)
+ )
+ else
+ io.write_string("deconstruct_du failed\n", !IO)
+ ),
+ io.nl(!IO).
+
+:- pred print_value(string::in, T::in, io::di, io::uo) is det.
+
+print_value(Label, Value, !IO) :-
+ % We do not use io.format because this test case is compiled with
+ % --allow-packing-local-sectags but the standard library likely is not,
+ % which leads to mismatching data representations inside the format
+ % implementation resulting in a crash.
+ io.write_string("\t", !IO),
+ io.write_string(Label, !IO),
+ io.write_string(":\t", !IO),
+ ( if string.length(Label) < 7 then
+ io.write_string("\t", !IO)
+ else
+ true
+ ),
+ io.print(Value, !IO),
+ io.nl(!IO).
+
+:- pred is_java_or_csharp is semidet.
+
+is_java_or_csharp :-
+ ( string.sub_string_search($grade, "java", _)
+ ; string.sub_string_search($grade, "csharp", _)
+ ).
--
2.30.0
More information about the reviews
mailing list