[m-rev.] for review: Make subtypes share high-level data representation with base type.
Peter Wang
novalazy at gmail.com
Thu Apr 1 12:24:05 AEDT 2021
In the high-level data representation, make a subtype term be
represented using the class corresponding to the base type constructor
instead of its own class. This is necessary to be able to downcast
a term from a type to a subtype in Java and C#.
compiler/du_type_layout.m:
Move get_base_type_ctor predicate to type_util.m.
Abort in a couple of places that should not occur.
compiler/type_util.m:
Add get_base_type_ctor predicate.
compiler/globals.m:
Add compilation_target_high_level_data predicate.
compiler/lco.m:
Use compilation_target_high_level_data predicate.
compiler/ml_type_gen.m:
When using the high-level data representation,
don't generate a MLDS type definition (class) for a subtype.
compiler/mlds.m:
When using the high-level data representation,
replace a Mercury subtype with its base type in an mlds_type.
Move foreign_type_to_mlds_type.
compiler/ml_unify_gen_util.m:
To access a field when using the high-level data representation,
use field names from the base type constructor of a subtype.
compiler/unify_proc.m:
When using the high-level data representation,
generate unify/compare procs for subtypes that just call the
unify/compare proc for the base type constructor.
compiler/options.m:
Delete references to --high-level and --high-level-data.
---------------
runtime/mercury_type_info.h:
Document a new field MR_type_ctor_base in MR_TypeCtorInfo_Struct.
The field is unnecessary and does not exist in the
MR_TypeCtorInfo_Struct for C.
runtime/mercury_dotnet.cs.in:
Add type_ctor_base member to MR_TypeCtorInfo_Struct for C#.
java/runtime/TypeCtorInfo_Struct.java
Add type_ctor_base member to MR_TypeCtorInfo_Struct for Java.
compiler/rtti.m:
compiler/type_ctor_info.m:
Add field correponding to MR_type_ctor_base in type_ctor_details
for enum, notag and general du types.
compiler/rtti_to_mlds.m:
Initialize the MR_type_ctor_base field in type_ctor_infos
for high-level data grades.
compiler/rtti_out.m:
Don't write out the MR_type_ctor_base field when using
the low-level data representation.
library/rtti_implementation.m:
In Java and C# grades (high-level data grades), use the
MR_type_ctor_base field to get the type_ctor_info of the base type
ctor when constructing or deconstructing terms of a subtype.
It is necessary to perform reflection using class and field names
from the base type constructor since there are no classes
correponding to subtypes.
Clean up some code.
---------------
tests/hard_coded/Mmakefile:
tests/hard_coded/subtype_abstract.m:
tests/hard_coded/subtype_abstract_2.m:
tests/hard_coded/subtype_abstract.exp:
Add a test case.
tests/hard_coded/subtype_rtti.m:
tests/hard_coded/subtype_rtti.exp2:
Enable a test that was previously skipped in Java and C# grades.
---
compiler/du_type_layout.m | 62 +---
compiler/globals.m | 24 +-
compiler/lco.m | 10 +-
compiler/ml_type_gen.m | 53 ++--
compiler/ml_unify_gen_util.m | 20 +-
compiler/mlds.m | 236 +++++++++++----
compiler/options.m | 7 +-
compiler/rtti.m | 28 +-
compiler/rtti_out.m | 11 +-
compiler/rtti_to_mlds.m | 72 ++++-
compiler/type_ctor_info.m | 75 +++--
compiler/type_util.m | 53 ++++
compiler/unify_proc.m | 195 +++++++++----
java/runtime/TypeCtorInfo_Struct.java | 34 ++-
library/rtti_implementation.m | 394 +++++++++++++++++++-------
runtime/mercury_dotnet.cs.in | 60 ++--
runtime/mercury_type_info.h | 9 +-
tests/hard_coded/Mmakefile | 1 +
tests/hard_coded/subtype_abstract.exp | 1 +
tests/hard_coded/subtype_abstract.m | 25 ++
tests/hard_coded/subtype_abstract_2.m | 30 ++
tests/hard_coded/subtype_rtti.exp2 | 4 +-
tests/hard_coded/subtype_rtti.m | 17 +-
23 files changed, 976 insertions(+), 445 deletions(-)
create mode 100644 tests/hard_coded/subtype_abstract.exp
create mode 100644 tests/hard_coded/subtype_abstract.m
create mode 100644 tests/hard_coded/subtype_abstract_2.m
diff --git a/compiler/du_type_layout.m b/compiler/du_type_layout.m
index ac52d7986..2e75b94a9 100644
--- a/compiler/du_type_layout.m
+++ b/compiler/du_type_layout.m
@@ -133,7 +133,6 @@
:- import_module one_or_more.
:- import_module pair.
:- import_module require.
-:- import_module set.
:- import_module string.
:- import_module term.
:- import_module uint.
@@ -705,7 +704,7 @@ add_if_subtype_of_simple_du_type_to_maps(OldTypeTable, TypeCtorTypeDefn,
maybe_copy_no_tag_type_from_base(BaseTypeCtor,
TypeCtor, TypeParams, yes(Ctors), !NoTagTypeMap)
else
- true
+ unexpected($pred, "cannot get base type")
)
;
MaybeSuperType = no,
@@ -724,7 +723,7 @@ add_if_subtype_of_simple_du_type_to_maps(OldTypeTable, TypeCtorTypeDefn,
maybe_copy_no_tag_type_from_base(BaseTypeCtor, TypeCtor,
TypeParams, no, !NoTagTypeMap)
else
- true
+ unexpected($pred, "cannot get base type")
)
;
( AbstractDetails = abstract_type_general
@@ -743,63 +742,6 @@ add_if_subtype_of_simple_du_type_to_maps(OldTypeTable, TypeCtorTypeDefn,
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.
diff --git a/compiler/globals.m b/compiler/globals.m
index 6263b4e2e..c21ad6105 100644
--- a/compiler/globals.m
+++ b/compiler/globals.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
-% Copyright (C) 2013-2017 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.
%---------------------------------------------------------------------------%
@@ -66,14 +66,18 @@
; lang_csharp
; lang_java.
-:- func target_lang_to_foreign_export_lang(compilation_target)
- = foreign_language.
-
% A string representation of the compilation target suitable
% for use in human-readable error messages.
%
:- func compilation_target_string(compilation_target) = string.
+ % Return if the compilation target uses high-level data.
+ %
+:- func compilation_target_high_level_data(compilation_target) = bool.
+
+:- func target_lang_to_foreign_export_lang(compilation_target)
+ = foreign_language.
+
% A string representation of the foreign language suitable
% for use in human-readable error messages.
%
@@ -461,14 +465,18 @@
%---------------------------------------------------------------------------%
-target_lang_to_foreign_export_lang(target_c) = lang_c.
-target_lang_to_foreign_export_lang(target_csharp) = lang_csharp.
-target_lang_to_foreign_export_lang(target_java) = lang_java.
-
compilation_target_string(target_c) = "C".
compilation_target_string(target_csharp) = "C#".
compilation_target_string(target_java) = "Java".
+compilation_target_high_level_data(target_c) = no.
+compilation_target_high_level_data(target_csharp) = yes.
+compilation_target_high_level_data(target_java) = yes.
+
+target_lang_to_foreign_export_lang(target_c) = lang_c.
+target_lang_to_foreign_export_lang(target_csharp) = lang_csharp.
+target_lang_to_foreign_export_lang(target_java) = lang_java.
+
foreign_language_string(lang_c) = "C".
foreign_language_string(lang_csharp) = "C#".
foreign_language_string(lang_java) = "Java".
diff --git a/compiler/lco.m b/compiler/lco.m
index 9a263e4ad..2726a09c6 100644
--- a/compiler/lco.m
+++ b/compiler/lco.m
@@ -456,15 +456,7 @@ lco_proc(LowerSCCVariants, SCC, CurProc, PredInfo, ProcInfo0,
proc_info_get_inferred_determinism(ProcInfo0, CurProcDetism),
module_info_get_globals(!.ModuleInfo, Globals),
globals.get_target(Globals, Target),
- (
- Target = target_c,
- HighLevelData = no
- ;
- ( Target = target_java
- ; Target = target_csharp
- ),
- HighLevelData = yes
- ),
+ HighLevelData = compilation_target_high_level_data(Target),
globals.lookup_bool_option(Globals, unboxed_float, UnboxedFloat),
(
UnboxedFloat = no,
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index 1d7812b5d..5d5431bc1 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -201,38 +201,45 @@ ml_gen_hld_type_defn(ModuleInfo, Target, TypeCtor, TypeDefn, !ClassDefns) :-
% see our BABEL'01 paper "Compiling Mercury to the .NET CLR".
% The same issue arises for some of the other kinds of types.
;
- TypeBody = hlds_du_type(_Ctors, _MaybeSuperType, MaybeUserEqComp,
+ TypeBody = hlds_du_type(_Ctors, MaybeSuperType, MaybeUserEqComp,
MaybeRepn, _Foreign),
- % XXX SUBTYPE
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
;
MaybeRepn = yes(Repn)
),
- Repn = du_type_repn(CtorRepns, _ConsCtorMap, _CheaperTagTest,
- DuTypeKind, _MaybeDirectArgCtors),
- ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
(
- ( DuTypeKind = du_type_kind_mercury_enum
- ; DuTypeKind = du_type_kind_foreign_enum(_)
- ),
- ml_gen_hld_enum_type(Target, TypeCtor, TypeDefn, CtorRepns,
- MaybeEqualityMembers, ClassDefn)
- ;
- DuTypeKind = du_type_kind_direct_dummy,
- % XXX We shouldn't have to generate an MLDS type for these types,
- % but it is not easy to ensure that we never refer to that type.
- ml_gen_hld_enum_type(Target, TypeCtor, TypeDefn, CtorRepns,
- MaybeEqualityMembers, ClassDefn)
+ MaybeSuperType = yes(_)
+ % In high-level data grades, a subtype uses the same class as its
+ % base type ctor.
;
- ( DuTypeKind = du_type_kind_notag(_, _, _)
- ; DuTypeKind = du_type_kind_general
+ MaybeSuperType = no,
+ Repn = du_type_repn(CtorRepns, _ConsCtorMap, _CheaperTagTest,
+ DuTypeKind, _MaybeDirectArgCtors),
+ ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
+ (
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ),
+ ml_gen_hld_enum_type(Target, TypeCtor, TypeDefn, CtorRepns,
+ MaybeEqualityMembers, ClassDefn)
+ ;
+ DuTypeKind = du_type_kind_direct_dummy,
+ % XXX We shouldn't have to generate an MLDS type for these
+ % types, but it is not easy to ensure that we never refer to
+ % that type.
+ ml_gen_hld_enum_type(Target, TypeCtor, TypeDefn, CtorRepns,
+ MaybeEqualityMembers, ClassDefn)
+ ;
+ ( DuTypeKind = du_type_kind_notag(_, _, _)
+ ; DuTypeKind = du_type_kind_general
+ ),
+ ml_gen_hld_du_type(ModuleInfo, Target, TypeCtor, TypeDefn,
+ CtorRepns, MaybeEqualityMembers, ClassDefn)
),
- ml_gen_hld_du_type(ModuleInfo, Target, TypeCtor, TypeDefn,
- CtorRepns, MaybeEqualityMembers, ClassDefn)
- ),
- !:ClassDefns = [ClassDefn | !.ClassDefns]
+ !:ClassDefns = [ClassDefn | !.ClassDefns]
+ )
).
%---------------------------------------------------------------------------%
@@ -250,7 +257,7 @@ ml_gen_hld_type_defn(ModuleInfo, Target, TypeCtor, TypeDefn, !ClassDefns) :-
% };
%
% It is marked as an mlds_enum so that the MLDS -> target code generator
- % can treat it specially if need be (e.g. generating a C enum rather than
+ % can treat it specially if need be (e.g. generating a C# enum rather than
% a class).
%
% Note that for Java the MR_value field is inherited from the
diff --git a/compiler/ml_unify_gen_util.m b/compiler/ml_unify_gen_util.m
index da49d1776..aa1f7935d 100644
--- a/compiler/ml_unify_gen_util.m
+++ b/compiler/ml_unify_gen_util.m
@@ -509,13 +509,24 @@ decide_field_gen(Info, VarLval, VarType, ConsId, ConsTag, Ptag, FieldGen) :-
% except for tuple types.
( if type_is_tuple(VarType, _) then
FieldVia = field_via_offset
- else if ConsId = cons(ConsSymName, ConsArity, TypeCtor) then
+ else if ConsId = cons(ConsSymName, ConsArity, ConsTypeCtor) then
+ ml_gen_info_get_module_info(Info, ModuleInfo),
ml_gen_info_get_target(Info, Target),
% XXX ARG_PACK Delete this sanity test after it has been tested
% for a while.
type_to_ctor_det(VarType, VarTypeCtor),
- expect(unify(TypeCtor, VarTypeCtor), $pred,
- "TypeCtor != VarTypeCtor"),
+ expect(unify(ConsTypeCtor, VarTypeCtor), $pred,
+ "ConsTypeCtor != VarTypeCtor"),
+ % With the high-level data representation, subtypes use the same
+ % class as their base type constructor, whose field names are
+ % derived from the base type constructor.
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ ( if get_base_type_ctor(TypeTable, ConsTypeCtor, BaseTypeCtor) then
+ TypeCtor = BaseTypeCtor
+ else
+ TypeCtor = ConsTypeCtor
+ ),
+
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity),
QualTypeName = qual_class_name(MLDS_Module, QualKind, TypeName),
TypeQualifier = mlds_append_class_qualifier(Target, MLDS_Module,
@@ -592,8 +603,7 @@ ml_gen_hl_tag_field_id(ModuleInfo, Target, Type) = FieldId :-
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
(
- TypeDefnBody = hlds_du_type(_, _MaybeSuperType, _, MaybeRepn, _),
- % XXX SUBTYPE Type representation depends on base type.
+ TypeDefnBody = hlds_du_type(_, _, _, MaybeRepn, _),
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
diff --git a/compiler/mlds.m b/compiler/mlds.m
index 90e35bde0..25e5f69b5 100644
--- a/compiler/mlds.m
+++ b/compiler/mlds.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1999-2011 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.
%---------------------------------------------------------------------------%
@@ -2478,6 +2478,7 @@
:- import_module check_hlds.
:- import_module check_hlds.type_util.
:- import_module mdbcomp.builtin_modules.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names.
:- import_module parse_tree.java_names.
@@ -2606,59 +2607,14 @@ mlds_get_func_signature(Params) = Signature :-
ParamTypes = mlds_get_arg_types(Parameters),
Signature = mlds_func_signature(ParamTypes, RetTypes).
-:- func foreign_type_to_mlds_type(module_info, foreign_type_body) = mlds_type.
-
-foreign_type_to_mlds_type(ModuleInfo, ForeignTypeBody) = MLDSType :-
- % The body of this function is very similar to the function
- % foreign_type_body_to_exported_type in foreign.m.
- % Any changes here may require changes there as well.
- ForeignTypeBody = foreign_type_body(MaybeC, MaybeJava, MaybeCSharp),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- (
- Target = target_c,
- (
- MaybeC = yes(Data),
- Data = type_details_foreign(CForeignType, _, _),
- ForeignType = c(CForeignType)
- ;
- MaybeC = no,
- % This is checked by check_foreign_type in make_hlds.
- unexpected($pred, "no C foreign type")
- )
- ;
- Target = target_csharp,
- (
- MaybeCSharp = yes(Data),
- Data = type_details_foreign(CSharpForeignType, _, _),
- ForeignType = csharp(CSharpForeignType)
- ;
- MaybeCSharp = no,
- % This is checked by check_foreign_type in make_hlds.
- unexpected($pred, "no C# foreign type")
- )
- ;
- Target = target_java,
- (
- MaybeJava = yes(Data),
- Data = type_details_foreign(JavaForeignType, _, _),
- ForeignType = java(JavaForeignType)
- ;
- MaybeJava = no,
- % This is checked by check_foreign_type in make_hlds.
- unexpected($pred, "no Java foreign type")
- )
- ),
- MLDSType = mlds_foreign_type(ForeignType).
-
%---------------------------------------------------------------------------%
-% There is some special-case handling for arrays, foreign types and some
-% other types here, but apart from that, currently we return mlds_types
+% There is some special-case handling for arrays, foreign types, subtypes, and
+% some other types here, but apart from that, currently we return mlds_types
% that are just the same as Mercury types, except that we also store the type
% category, so that we can tell if the type is an enumeration or not, without
% needing to refer to the HLDS type_table.
-% XXX It might be a better idea to get rid of the mercury_type/2 MLDS type
+% XXX It might be a better idea to get rid of the mercury_nb_type/2 MLDS type
% and instead fully convert all Mercury types to MLDS types.
mercury_type_to_mlds_type(ModuleInfo, Type) = MLDSType :-
@@ -2692,17 +2648,8 @@ mercury_type_to_mlds_type(ModuleInfo, Type) = MLDSType :-
else
module_info_get_type_table(ModuleInfo, TypeTable),
( if search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) then
- hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ( if TypeBody = hlds_foreign_type(ForeignTypeBody) then
- MLDSType = foreign_type_to_mlds_type(ModuleInfo,
- ForeignTypeBody)
- else if TypeBody = hlds_abstract_type(_) then
- CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
- MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
- else
- CtorCat = classify_type_defn_body(TypeBody),
- MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
- )
+ MLDSType = mercury_type_ctor_defn_to_mlds_type(ModuleInfo,
+ Type, TypeCtor, TypeDefn)
else
CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
@@ -2713,6 +2660,65 @@ mercury_type_to_mlds_type(ModuleInfo, Type) = MLDSType :-
MLDSType = mercury_nb_type(Type, Category)
).
+:- func mercury_type_ctor_defn_to_mlds_type(module_info, mer_type,
+ type_ctor, hlds_type_defn) = mlds_type.
+
+mercury_type_ctor_defn_to_mlds_type(ModuleInfo, Type, TypeCtor, TypeDefn) =
+ MLDSType :-
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ (
+ TypeBody = hlds_du_type(_, MaybeSuperType, _, _, _),
+ ( if
+ MaybeSuperType = yes(SuperType),
+ compilation_target_uses_high_level_data(ModuleInfo)
+ then
+ % In high-level data grades, a subtype is represented with the
+ % same class as its base type ctor.
+ type_to_ctor_det(SuperType, SuperTypeCtor),
+ get_base_type_maybe_phony_arg_types(ModuleInfo, SuperTypeCtor,
+ BaseType),
+ CtorCat = classify_type(ModuleInfo, BaseType),
+ MLDSType = type_and_category_to_mlds_type(BaseType, CtorCat)
+ else
+ CtorCat = classify_type_defn_body(TypeBody),
+ MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
+ )
+ ;
+ TypeBody = hlds_abstract_type(DetailsAbstract),
+ (
+ ( DetailsAbstract = abstract_type_general
+ ; DetailsAbstract = abstract_type_fits_in_n_bits(_)
+ ; DetailsAbstract = abstract_dummy_type
+ ; DetailsAbstract = abstract_notag_type
+ ; DetailsAbstract = abstract_solver_type
+ ),
+ CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
+ MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
+ ;
+ DetailsAbstract = abstract_subtype(SuperTypeCtor),
+ ( if compilation_target_uses_high_level_data(ModuleInfo) then
+ % In high-level data grades, a subtype is represented with the
+ % same class as its base type ctor.
+ get_base_type_maybe_phony_arg_types(ModuleInfo, SuperTypeCtor,
+ BaseType),
+ CtorCat = classify_type(ModuleInfo, BaseType),
+ MLDSType = type_and_category_to_mlds_type(BaseType, CtorCat)
+ else
+ CtorCat = classify_type_ctor(ModuleInfo, TypeCtor),
+ MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
+ )
+ )
+ ;
+ TypeBody = hlds_foreign_type(ForeignTypeBody),
+ MLDSType = foreign_type_to_mlds_type(ModuleInfo, ForeignTypeBody)
+ ;
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_solver_type(_)
+ ),
+ CtorCat = classify_type_defn_body(TypeBody),
+ MLDSType = type_and_category_to_mlds_type(Type, CtorCat)
+ ).
+
:- func type_and_category_to_mlds_type(mer_type, type_ctor_category)
= mlds_type.
@@ -2735,6 +2741,116 @@ type_and_category_to_mlds_type(Type, CtorCat) = MLDSType :-
MLDSType = mercury_nb_type(Type, CtorCat)
).
+%---------------------%
+
+:- pred compilation_target_uses_high_level_data(module_info::in) is semidet.
+
+compilation_target_uses_high_level_data(ModuleInfo) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ compilation_target_high_level_data(Target) = yes.
+
+:- pred get_base_type_maybe_phony_arg_types(module_info::in, type_ctor::in,
+ mer_type::out) is det.
+
+get_base_type_maybe_phony_arg_types(ModuleInfo, SuperTypeCtor, BaseType) :-
+ %
+ % XXX If a type is a subtype of a subtype, we should substitute the type
+ % arguments into the supertype recursively until we get to the base type.
+ % This requires that the tvarset containing the variables of the original
+ % type be passed into mercury_type_to_mlds_type. But that would still not
+ % solve the next problem.
+ %
+ % XXX If a type is a subtype of an abstract supertype, we will only know
+ % the type ctor of the supertype, as supertype arguments are not written to
+ % interface files (we may need to revisit that decision).
+ %
+ % Instead, we find the base type ctor of a type ctor and simply apply
+ % `c_pointer' for all its type parameters. `c_pointer' corresponds to
+ % `Object' in Java and `object' in C#.
+ %
+ % In almost all cases, only the type ctor in a mercury_nb_type is used,
+ % not the type arguments. The phony type arguments only makes a difference
+ % when generating the Java class corresponding to a Mercury type, e.g. for
+ %
+ % :- type mytype(T)
+ % ---> mytype(abs(T)). % abstract subtype
+ %
+ % we generate
+ %
+ % public static class Mytype_1<MR_tvar_1>
+ % implements jmercury.runtime.MercuryType
+ % {
+ % public Abs_1<Object> F1;
+ %
+ % public Mytype_1(Abs_1<Object> F1)
+ % {
+ % this.F1 = F1;
+ % }
+ % }
+ %
+ % The member F1 and constructor argument has type Abs_1<Object> instead of
+ % Abs_1<MR_tvar_1>. The Java code will still compile and run, but there is
+ % a slight loss of type information for hand written code that uses the F1
+ % member. This is a very minor problem and does not seem worth fixing
+ % unless other problems arise.
+ %
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ ( if get_base_type_ctor(TypeTable, SuperTypeCtor, BaseTypeCtor) then
+ BaseTypeCtor = type_ctor(_, Arity),
+ list.duplicate(Arity, c_pointer_type, PhonyTypeArgs),
+ construct_type(BaseTypeCtor, PhonyTypeArgs, BaseType)
+ else
+ unexpected($pred, "cannot get base type ctor")
+ ).
+
+%---------------------%
+
+:- func foreign_type_to_mlds_type(module_info, foreign_type_body) = mlds_type.
+
+foreign_type_to_mlds_type(ModuleInfo, ForeignTypeBody) = MLDSType :-
+ % The body of this function is very similar to the function
+ % foreign_type_body_to_exported_type in foreign.m.
+ % Any changes here may require changes there as well.
+ ForeignTypeBody = foreign_type_body(MaybeC, MaybeJava, MaybeCSharp),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ (
+ Target = target_c,
+ (
+ MaybeC = yes(Data),
+ Data = type_details_foreign(CForeignType, _, _),
+ ForeignType = c(CForeignType)
+ ;
+ MaybeC = no,
+ % This is checked by check_foreign_type in make_hlds.
+ unexpected($pred, "no C foreign type")
+ )
+ ;
+ Target = target_csharp,
+ (
+ MaybeCSharp = yes(Data),
+ Data = type_details_foreign(CSharpForeignType, _, _),
+ ForeignType = csharp(CSharpForeignType)
+ ;
+ MaybeCSharp = no,
+ % This is checked by check_foreign_type in make_hlds.
+ unexpected($pred, "no C# foreign type")
+ )
+ ;
+ Target = target_java,
+ (
+ MaybeJava = yes(Data),
+ Data = type_details_foreign(JavaForeignType, _, _),
+ ForeignType = java(JavaForeignType)
+ ;
+ MaybeJava = no,
+ % This is checked by check_foreign_type in make_hlds.
+ unexpected($pred, "no Java foreign type")
+ )
+ ),
+ MLDSType = mlds_foreign_type(ForeignType).
+
%---------------------------------------------------------------------------%
ml_global_const_var_name_to_string(ConstVar, Num) = Str :-
diff --git a/compiler/options.m b/compiler/options.m
index 4fb9085a1..fe9156937 100644
--- a/compiler/options.m
+++ b/compiler/options.m
@@ -5401,12 +5401,7 @@ options_help_compilation_model(!IO) :-
"-H, --high-level-code\t\t\t(grades: hlc, csharp, java)",
"\tUse an alternative back-end that generates high-level code",
"\trather than the very low-level code that is generated by our",
- "\toriginal back-end.",
- "--high-level-data\t\t\t(grades: csharp, java)",
- "\tUse an alternative higher-level data representation.",
-% "--high-level\t\t\t(grades: hl, hl_nest, il, csharp, java)",
- "--high-level\t\t\t(grades: csharp, java)",
- "\tAn abbreviation for `--high-level-code --high-level-data'."
+ "\toriginal back-end."
% The --det-copy-out option is not yet documented,
% because it is not yet tested much and probably not very useful,
% except for Java, where it is the default.
diff --git a/compiler/rtti.m b/compiler/rtti.m
index 56ef24e9a..e8fb54ee1 100644
--- a/compiler/rtti.m
+++ b/compiler/rtti.m
@@ -174,7 +174,8 @@
enum_ordinal_table :: map(uint32, enum_functor),
enum_name_table :: map(string, enum_functor),
enum_functor_number_mapping
- :: list(uint32)
+ :: list(uint32),
+ enum_base_type_ctor :: maybe(type_ctor)
)
; tcd_foreign_enum(
foreign_enum_language :: foreign_language,
@@ -192,11 +193,14 @@
du_value_table :: ptag_map,
du_name_table :: map(string, map(uint16, du_functor)),
du_functor_number_mapping
- :: list(uint32)
+ :: list(uint32),
+ du_base_type_ctor :: maybe(type_ctor)
)
; tcd_notag(
notag_axioms :: equality_axioms,
- notag_functor :: notag_functor
+ notag_functor :: notag_functor,
+ notag_base_type_ctor
+ :: maybe(type_ctor)
)
; tcd_eqv(
eqv_type :: rtti_maybe_pseudo_type_info
@@ -1483,7 +1487,7 @@ type_ctor_rep_to_string(TypeCtorData, TargetPrefixes, RepStr) :-
"runtime.TypeCtorRep."),
TypeCtorDetails = TypeCtorData ^ tcr_rep_details,
(
- TypeCtorDetails = tcd_enum(TypeCtorUserEq, IsDummy, _, _, _, _),
+ TypeCtorDetails = tcd_enum(TypeCtorUserEq, IsDummy, _, _, _, _, _),
(
IsDummy = enum_is_dummy,
expect(unify(TypeCtorUserEq, standard), $pred,
@@ -1509,7 +1513,7 @@ type_ctor_rep_to_string(TypeCtorData, TargetPrefixes, RepStr) :-
RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ"
)
;
- TypeCtorDetails = tcd_du(TypeCtorUserEq, _, _, _, _),
+ TypeCtorDetails = tcd_du(TypeCtorUserEq, _, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_DU"
@@ -1518,7 +1522,7 @@ type_ctor_rep_to_string(TypeCtorData, TargetPrefixes, RepStr) :-
RepStr = "MR_TYPECTOR_REP_DU_USEREQ"
)
;
- TypeCtorDetails = tcd_notag(TypeCtorUserEq, NotagFunctor),
+ TypeCtorDetails = tcd_notag(TypeCtorUserEq, NotagFunctor, _),
NotagEqvType = NotagFunctor ^ nt_arg_type,
(
TypeCtorUserEq = standard,
@@ -1785,9 +1789,9 @@ maybe_pseudo_type_info_or_self_to_rtti_data(self) =
type_ctor_details_num_ptags(TypeCtorDetails) = MaybeNumPtags :-
(
- ( TypeCtorDetails = tcd_enum(_, _, _, _, _, _)
+ ( TypeCtorDetails = tcd_enum(_, _, _, _, _, _, _)
; TypeCtorDetails = tcd_foreign_enum(_, _, _, _, _, _)
- ; TypeCtorDetails = tcd_notag(_, _)
+ ; TypeCtorDetails = tcd_notag(_, _, _)
; TypeCtorDetails = tcd_eqv(_)
; TypeCtorDetails = tcd_builtin(_)
; TypeCtorDetails = tcd_impl_artifact(_)
@@ -1795,7 +1799,7 @@ type_ctor_details_num_ptags(TypeCtorDetails) = MaybeNumPtags :-
),
MaybeNumPtags = no
;
- TypeCtorDetails = tcd_du(_, _, PtagMap, _, _),
+ TypeCtorDetails = tcd_du(_, _, PtagMap, _, _, _),
map.keys(PtagMap, Ptags),
list.det_last(Ptags, LastPtag),
LastPtag = ptag(LastPtagUint8),
@@ -1806,16 +1810,16 @@ type_ctor_details_num_ptags(TypeCtorDetails) = MaybeNumPtags :-
type_ctor_details_num_functors(TypeCtorDetails) = MaybeNumFunctors :-
(
(
- TypeCtorDetails = tcd_enum(_, _, EnumFunctors, _, _, _),
+ TypeCtorDetails = tcd_enum(_, _, EnumFunctors, _, _, _, _),
list.length(EnumFunctors, NumFunctors)
;
TypeCtorDetails = tcd_foreign_enum(_, _, ForeignFunctors, _, _, _),
list.length(ForeignFunctors, NumFunctors)
;
- TypeCtorDetails = tcd_du(_, DuFunctors, _, _, _),
+ TypeCtorDetails = tcd_du(_, DuFunctors, _, _, _, _),
list.length(DuFunctors, NumFunctors)
;
- TypeCtorDetails = tcd_notag(_, _),
+ TypeCtorDetails = tcd_notag(_, _, _),
NumFunctors = 1
),
MaybeNumFunctors = yes(NumFunctors)
diff --git a/compiler/rtti_out.m b/compiler/rtti_out.m
index 667e38895..0a1fdc808 100644
--- a/compiler/rtti_out.m
+++ b/compiler/rtti_out.m
@@ -903,7 +903,8 @@ output_type_ctor_details_defn(Info, Stream, RttiTypeCtor, TypeCtorDetails,
!DeclSet, !IO) :-
(
TypeCtorDetails = tcd_enum(_, _IsDummy, EnumFunctors,
- EnumByOrd, EnumByName, FunctorNumberMap),
+ EnumByOrd, EnumByName, FunctorNumberMap, _MaybeBaseTypeCtor),
+ % MaybeBaseTypeCtor is not required for low-level data.
list.foldl2(output_enum_functor_defn(Info, Stream, RttiTypeCtor),
EnumFunctors, !DeclSet, !IO),
output_enum_ordinal_ordered_table(Info, Stream, RttiTypeCtor,
@@ -933,8 +934,9 @@ output_type_ctor_details_defn(Info, Stream, RttiTypeCtor, TypeCtorDetails,
MaybeFunctorsName = yes(type_ctor_foreign_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = tcd_du(_, DuFunctors, DuByRep,
- DuByName, FunctorNumberMap),
+ TypeCtorDetails = tcd_du(_, DuFunctors, DuByRep, DuByName,
+ FunctorNumberMap, _MaybeBaseTypeCtor),
+ % MaybeBaseTypeCtor is not required for low-level data.
list.foldl2(output_du_functor_defn(Info, Stream, RttiTypeCtor),
DuFunctors, !DeclSet, !IO),
output_du_ptag_ordered_table(Info, Stream, RttiTypeCtor, DuByRep,
@@ -947,7 +949,8 @@ output_type_ctor_details_defn(Info, Stream, RttiTypeCtor, TypeCtorDetails,
MaybeFunctorsName = yes(type_ctor_du_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = tcd_notag(_, NotagFunctor),
+ TypeCtorDetails = tcd_notag(_, NotagFunctor, _MaybeBaseTypeCtor),
+ % MaybeBaseTypeCtor is not required for low-level data.
output_notag_functor_defn(Info, Stream, RttiTypeCtor, NotagFunctor,
!DeclSet, !IO),
output_functor_number_map(Info, Stream, RttiTypeCtor, [0u32],
diff --git a/compiler/rtti_to_mlds.m b/compiler/rtti_to_mlds.m
index 4bac15e9f..375b09e52 100644
--- a/compiler/rtti_to_mlds.m
+++ b/compiler/rtti_to_mlds.m
@@ -230,7 +230,7 @@ gen_init_rtti_data_defn(ModuleInfo, Target, RttiData, !GlobalData) :-
gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor,
TypeCtorDetails, FunctorsInfo, LayoutInfo, NumberMapInfo,
- !GlobalData),
+ BaseTypeCtorInitializer, !GlobalData),
% Note that gen_init_special_pred will by necessity add an extra
% level of indirection to calling the special preds. However, the
@@ -274,7 +274,9 @@ gen_init_rtti_data_defn(ModuleInfo, Target, RttiData, !GlobalData) :-
% MR_type_ctor_flags
gen_init_uint16(encode_type_ctor_flags(Flags)),
% MR_type_ctor_functor_number_map
- NumberMapInfo
+ NumberMapInfo,
+ % MR_type_ctor_base
+ BaseTypeCtorInitializer
% These two are commented out while the corresponding fields of the
% MR_TypeCtorInfo_Struct type are commented out.
@@ -631,15 +633,15 @@ gen_pseudo_type_info_defn(ModuleInfo, Target, RttiPseudoTypeInfo, Name, RttiId,
:- pred gen_functors_layout_info(module_info::in, mlds_target_lang::in,
rtti_type_ctor::in, type_ctor_details::in,
mlds_initializer::out, mlds_initializer::out, mlds_initializer::out,
- ml_global_data::in, ml_global_data::out) is det.
+ mlds_initializer::out, ml_global_data::in, ml_global_data::out) is det.
gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
FunctorInitializer, LayoutInitializer, NumberMapInitializer,
- !GlobalData) :-
+ BaseTypeCtorInitializer, !GlobalData) :-
module_info_get_name(ModuleInfo, ModuleName),
(
TypeCtorDetails = tcd_enum(_, _IsDummy, EnumFunctors,
- EnumByOrd, EnumByName, FunctorNumberMap),
+ EnumByOrd, EnumByName, FunctorNumberMap, MaybeBaseTypeCtor),
list.foldl(gen_enum_functor_desc(ModuleInfo, RttiTypeCtor),
EnumFunctors, !GlobalData),
gen_enum_ordinal_ordered_table(ModuleInfo, RttiTypeCtor,
@@ -652,7 +654,9 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_enum_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map)
+ type_ctor_functor_number_map),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ MaybeBaseTypeCtor)
;
TypeCtorDetails = tcd_foreign_enum(ForeignEnumLang, _,
ForeignEnumFunctors, ForeignEnumByOrdinal, ForeignEnumByName,
@@ -671,10 +675,12 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_foreign_enum_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map)
+ type_ctor_functor_number_map),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ no)
;
TypeCtorDetails = tcd_du(_, DuFunctors, DuByPtag, DuByName,
- FunctorNumberMap),
+ FunctorNumberMap, MaybeBaseTypeCtor),
list.foldl(gen_du_functor_desc(ModuleInfo, Target, RttiTypeCtor),
DuFunctors, !GlobalData),
gen_du_ptag_ordered_table(ModuleInfo, RttiTypeCtor,
@@ -687,9 +693,11 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
FunctorInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_du_name_ordered_table),
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
- type_ctor_functor_number_map)
+ type_ctor_functor_number_map),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ MaybeBaseTypeCtor)
;
- TypeCtorDetails = tcd_notag(_, NotagFunctor),
+ TypeCtorDetails = tcd_notag(_, NotagFunctor, MaybeBaseTypeCtor),
gen_functor_number_map(RttiTypeCtor, [0u32], !GlobalData),
LayoutInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
@@ -698,7 +706,9 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
NumberMapInitializer = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_functor_number_map),
gen_notag_functor_desc(ModuleInfo, Target, RttiTypeCtor, NotagFunctor,
- !GlobalData)
+ !GlobalData),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ MaybeBaseTypeCtor)
;
TypeCtorDetails = tcd_eqv(EqvType),
TypeRttiData = maybe_pseudo_type_info_to_rtti_data(EqvType),
@@ -706,7 +716,9 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
LayoutInitializer, !GlobalData),
% The type is a lie, but a safe one.
FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
- NumberMapInitializer = gen_init_null_pointer(mlds_generic_type)
+ NumberMapInitializer = gen_init_null_pointer(mlds_generic_type),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ no)
;
( TypeCtorDetails = tcd_builtin(_)
; TypeCtorDetails = tcd_impl_artifact(_)
@@ -714,7 +726,9 @@ gen_functors_layout_info(ModuleInfo, Target, RttiTypeCtor, TypeCtorDetails,
),
LayoutInitializer = gen_init_null_pointer(mlds_generic_type),
FunctorInitializer = gen_init_null_pointer(mlds_generic_type),
- NumberMapInitializer = gen_init_null_pointer(mlds_generic_type)
+ NumberMapInitializer = gen_init_null_pointer(mlds_generic_type),
+ BaseTypeCtorInitializer = gen_init_base_type_ctor(ModuleName, Target,
+ no)
).
%-----------------------------------------------------------------------------%
@@ -1310,6 +1324,36 @@ gen_init_functor_number(NumUint32) = Init :-
%-----------------------------------------------------------------------------%
+:- func gen_init_base_type_ctor(module_name, mlds_target_lang,
+ maybe(type_ctor)) = mlds_initializer.
+
+gen_init_base_type_ctor(ModuleName, Target, MaybeBaseTypeCtor) = Initializer :-
+ % The MR_type_ctor_base field is only required in high-level data grades.
+ ( if mlds_target_high_level_data(Target) = yes then
+ (
+ MaybeBaseTypeCtor = yes(BaseTypeCtor),
+ BaseTypeCtor = type_ctor(SymName, Arity),
+ (
+ SymName = qualified(TypeModule, TypeName)
+ ;
+ SymName = unqualified(_),
+ unexpected($pred, "base type ctor is not module qualified")
+ ),
+ RttiTypeCtor = rtti_type_ctor(TypeModule, TypeName,
+ uint16.det_from_int(Arity)),
+ RttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_type_ctor_info),
+ Initializer = gen_init_rtti_id(ModuleName, RttiId)
+ ;
+ MaybeBaseTypeCtor = no,
+ % The type is a lie, but a safe one.
+ Initializer = gen_init_null_pointer(mlds_generic_type)
+ )
+ else
+ Initializer = no_initializer
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- func gen_init_rtti_names_array(module_name, rtti_type_ctor,
list(ctor_rtti_name)) = mlds_initializer.
@@ -1707,6 +1751,8 @@ gen_init_type_ctor_rep(TypeCtorData) = Initializer :-
rtti.type_ctor_rep_to_string(TypeCtorData, TargetPrefixes, Name),
Initializer = gen_init_builtin_const(TargetPrefixes, Name).
+%-----------------------------------------------------------------------------%
+
%-----------------------------------------------------------------------------%
%
% Ordering RTTI definitions.
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index a63a19e22..25b3fabf1 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -388,8 +388,8 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
),
(
DuTypeKind = du_type_kind_mercury_enum,
- make_mercury_enum_details(MaybeSuperType, CtorRepns,
- enum_is_not_dummy, EqualityAxioms, Details,
+ make_mercury_enum_details(ModuleInfo, MaybeSuperType,
+ CtorRepns, enum_is_not_dummy, EqualityAxioms, Details,
IndexableByEnumValue),
LayoutIndexable = IndexableByEnumValue
;
@@ -399,20 +399,21 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
LayoutIndexable = no
;
DuTypeKind = du_type_kind_direct_dummy,
- make_mercury_enum_details(MaybeSuperType, CtorRepns,
- enum_is_dummy, EqualityAxioms, Details,
+ make_mercury_enum_details(ModuleInfo, 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),
+ make_notag_details(ModuleInfo, TypeArity, MaybeSuperType,
+ FunctorName, ArgType, MaybeArgName, EqualityAxioms,
+ Details),
LayoutIndexable = no
;
DuTypeKind = du_type_kind_general,
- make_du_details(ModuleInfo, CtorRepns, TypeArity,
- EqualityAxioms, Details, IndexableByPtag),
+ make_du_details(ModuleInfo, MaybeSuperType, CtorRepns,
+ TypeArity, EqualityAxioms, Details, IndexableByPtag),
LayoutIndexable = IndexableByPtag
)
)
@@ -517,11 +518,12 @@ type_ctor_info_rtti_version = 18u8.
% Make the functor and layout tables for a notag type.
%
-:- pred make_notag_details(int::in, sym_name::in, mer_type::in,
- maybe(string)::in, equality_axioms::in, type_ctor_details::out) is det.
+:- pred make_notag_details(module_info::in, int::in, maybe(mer_type)::in,
+ sym_name::in, mer_type::in, maybe(string)::in, equality_axioms::in,
+ type_ctor_details::out) is det.
-make_notag_details(TypeArity, SymName, ArgType, MaybeArgName, EqualityAxioms,
- Details) :-
+make_notag_details(ModuleInfo, TypeArity, MaybeSuperType, SymName, ArgType,
+ MaybeArgName, EqualityAxioms, Details) :-
FunctorName = unqualify_name(SymName),
NumUnivTVars = TypeArity,
% There can be no existentially typed args to the functor in a notag type.
@@ -535,7 +537,8 @@ make_notag_details(TypeArity, SymName, ArgType, MaybeArgName, EqualityAxioms,
),
Functor = notag_functor(FunctorName, MaybePseudoTypeInfo, MaybeArgName,
FunctorSubtypeInfo),
- Details = tcd_notag(EqualityAxioms, Functor).
+ maybe_get_base_type_ctor(ModuleInfo, MaybeSuperType, MaybeBaseTypeCtor),
+ Details = tcd_notag(EqualityAxioms, Functor, MaybeBaseTypeCtor).
%---------------------------------------------------------------------------%
@@ -543,12 +546,12 @@ make_notag_details(TypeArity, SymName, ArgType, MaybeArgName, EqualityAxioms,
% Make the functor and layout tables for an enum type.
%
-:- pred make_mercury_enum_details(maybe(mer_type)::in,
+:- pred make_mercury_enum_details(module_info::in, 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(MaybeSuperType, CtorRepns, IsDummy, EqualityAxioms,
- Details, IndexableByEnumValue) :-
+make_mercury_enum_details(ModuleInfo, MaybeSuperType, CtorRepns, IsDummy,
+ EqualityAxioms, Details, IndexableByEnumValue) :-
(
CtorRepns = [],
unexpected($pred, "enum with no ctors")
@@ -578,8 +581,9 @@ make_mercury_enum_details(MaybeSuperType, CtorRepns, IsDummy, EqualityAxioms,
IndexableByEnumValue = no
),
FunctorNumberMap = make_functor_number_map(CtorRepns),
+ maybe_get_base_type_ctor(ModuleInfo, MaybeSuperType, MaybeBaseTypeCtor),
Details = tcd_enum(EqualityAxioms, IsDummy, EnumFunctors,
- OrdinalMap, NameMap, FunctorNumberMap).
+ OrdinalMap, NameMap, FunctorNumberMap, MaybeBaseTypeCtor).
% 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
@@ -745,14 +749,14 @@ make_foreign_enum_maps(ForeignEnumFunctor, !OrdinalMap, !NameMap) :-
:- type tag_list == assoc_list(int,
pair(sectag_locn, map(int, ctor_rtti_name))).
- % Make the functor and layout tables for a du type
- % (including reserved_addr types).
+ % Make the functor and layout tables for a du type.
%
-:- pred make_du_details(module_info::in, list(constructor_repn)::in,
- int::in, equality_axioms::in, type_ctor_details::out, bool::out) is det.
+:- pred make_du_details(module_info::in, maybe(mer_type)::in,
+ list(constructor_repn)::in, int::in, equality_axioms::in,
+ type_ctor_details::out, bool::out) is det.
-make_du_details(ModuleInfo, Ctors, TypeArity, EqualityAxioms, Details,
- IndexableByPtag) :-
+make_du_details(ModuleInfo, MaybeSuperType, 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
@@ -763,8 +767,9 @@ make_du_details(ModuleInfo, Ctors, TypeArity, EqualityAxioms, Details,
FunctorNumberMap = make_functor_number_map(Ctors),
list.foldl(make_du_name_ordered_table, DuFunctors,
map.init, DuNameOrderedMap),
+ maybe_get_base_type_ctor(ModuleInfo, MaybeSuperType, MaybeBaseTypeCtor),
Details = tcd_du(EqualityAxioms, DuFunctors, DuPtagTable,
- DuNameOrderedMap, FunctorNumberMap).
+ DuNameOrderedMap, FunctorNumberMap, MaybeBaseTypeCtor).
% Create a du_functor_desc structure for each functor in a du type.
% Besides returning a list of the rtti names of their du_functor_desc
@@ -1103,6 +1108,28 @@ lookup_functor_number(CtorNameToSeqNumMap, CtorName, SeqNumUint32) :-
%---------------------------------------------------------------------------%
+:- pred maybe_get_base_type_ctor(module_info::in, maybe(mer_type)::in,
+ maybe(type_ctor)::out) is det.
+
+maybe_get_base_type_ctor(ModuleInfo, MaybeSuperType, MaybeBaseTypeCtor) :-
+ (
+ MaybeSuperType = yes(SuperType),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ ( if
+ type_to_ctor(SuperType, SuperTypeCtor),
+ get_base_type_ctor(TypeTable, SuperTypeCtor, BaseTypeCtor)
+ then
+ MaybeBaseTypeCtor = yes(BaseTypeCtor)
+ else
+ unexpected($pred, "cannot get base type ctor")
+ )
+ ;
+ MaybeSuperType = no,
+ MaybeBaseTypeCtor = no
+ ).
+
+%---------------------------------------------------------------------------%
+
compute_du_ptag_layout_flags(SectagTable, Flags) :-
( if is_sectag_table_indexable(SectagTable) then
SectagAltsIndexable = yes
diff --git a/compiler/type_util.m b/compiler/type_util.m
index fd560a120..18bbcad1b 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -188,6 +188,13 @@
:- pred type_ctor_has_hand_defined_rtti(type_ctor::in, hlds_type_body::in)
is semidet.
+ % Return the base type ctor for a given type ctor.
+ % This predicate must only be called with a type ctor that is known
+ % to be a subtype or supertype type ctor, not with arbitrary type ctors.
+ %
+:- pred get_base_type_ctor(type_table::in, type_ctor::in, type_ctor::out)
+ is semidet.
+
% Given a type, determine what category its principal constructor
% falls into.
%
@@ -902,6 +909,52 @@ type_ctor_has_hand_defined_rtti(Type, Body) :-
%-----------------------------------------------------------------------------%
+get_base_type_ctor(TypeTable, TypeCtor, BaseTypeCtor) :-
+ % Circular subtype definitions are assumed to have been detected by now.
+ hlds_data.search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
+ hlds_data.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(TypeTable, SuperTypeCtor, BaseTypeCtor)
+ )
+ ;
+ 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(TypeTable, SuperTypeCtor, BaseTypeCtor)
+ ;
+ AbstractDetails = abstract_solver_type,
+ unexpected($pred, "abstract solver type")
+ )
+ ;
+ TypeBody = hlds_eqv_type(EqvType),
+ type_to_ctor(EqvType, EqvTypeCtor),
+ get_base_type_ctor(TypeTable, EqvTypeCtor, BaseTypeCtor)
+ ;
+ TypeBody = hlds_foreign_type(_),
+ unexpected($pred, "foreign type")
+ ;
+ TypeBody = hlds_solver_type(_),
+ unexpected($pred, "solver type")
+ ).
+
+%-----------------------------------------------------------------------------%
+
classify_type(ModuleInfo, VarType) = TypeCategory :-
( if type_to_ctor(VarType, TypeCtor) then
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m
index 24b8d7700..9bda36ddd 100644
--- a/compiler/unify_proc.m
+++ b/compiler/unify_proc.m
@@ -2,7 +2,7 @@
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1994-2012 The University of Melbourne.
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2018, 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.
%---------------------------------------------------------------------------%
@@ -105,6 +105,7 @@
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.set_of_var.
:- import_module bool.
@@ -232,47 +233,60 @@ generate_unify_proc_body(SpecDefnInfo, X, Y, Clauses, !Info) :-
Clause, !Info),
Clauses = [Clause]
;
- TypeBody = hlds_du_type(_, _, _, MaybeRepn, _),
+ TypeBody = hlds_du_type(_, MaybeSuperType, _, MaybeRepn, _),
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
;
MaybeRepn = yes(Repn)
),
- DuTypeKind = Repn ^ dur_kind,
- (
- ( DuTypeKind = du_type_kind_mercury_enum
- ; DuTypeKind = du_type_kind_foreign_enum(_)
- ),
- generate_unify_proc_body_enum(Context, X, Y,
- Clause, !Info),
- Clauses = [Clause]
- ;
- DuTypeKind = du_type_kind_direct_dummy,
- generate_unify_proc_body_dummy(Context, X, Y,
- Clause, !Info),
+ ( if
+ MaybeSuperType = yes(SuperType),
+ compilation_target_uses_high_level_data(ModuleInfo),
+ TVarSet = SpecDefnInfo ^ spdi_tvarset,
+ get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType)
+ then
+ % In high-level data grades, subtypes use the same class
+ % as their base type constructor.
+ generate_unify_proc_body_eqv(Context, BaseType, X, Y, Clause,
+ !Info),
Clauses = [Clause]
- ;
- DuTypeKind = du_type_kind_notag(_, ArgType, _),
- ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType),
+ else
+ DuTypeKind = Repn ^ dur_kind,
(
- ArgIsDummy = is_dummy_type,
- % Treat this type as if it were a dummy type
- % itself.
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ),
+ generate_unify_proc_body_enum(Context, X, Y,
+ Clause, !Info),
+ Clauses = [Clause]
+ ;
+ DuTypeKind = du_type_kind_direct_dummy,
generate_unify_proc_body_dummy(Context, X, Y,
Clause, !Info),
Clauses = [Clause]
;
- ArgIsDummy = is_not_dummy_type,
+ DuTypeKind = du_type_kind_notag(_, ArgType, _),
+ ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType),
+ (
+ ArgIsDummy = is_dummy_type,
+ % Treat this type as if it were a dummy type
+ % itself.
+ generate_unify_proc_body_dummy(Context, X, Y,
+ Clause, !Info),
+ Clauses = [Clause]
+ ;
+ ArgIsDummy = is_not_dummy_type,
+ CtorRepns = Repn ^ dur_ctor_repns,
+ generate_unify_proc_body_du(SpecDefnInfo,
+ CtorRepns, X, Y, Clauses, !Info)
+ )
+ ;
+ DuTypeKind = du_type_kind_general,
CtorRepns = Repn ^ dur_ctor_repns,
generate_unify_proc_body_du(SpecDefnInfo,
CtorRepns, X, Y, Clauses, !Info)
)
- ;
- DuTypeKind = du_type_kind_general,
- CtorRepns = Repn ^ dur_ctor_repns,
- generate_unify_proc_body_du(SpecDefnInfo,
- CtorRepns, X, Y, Clauses, !Info)
)
)
).
@@ -974,44 +988,63 @@ generate_compare_proc_body(SpecDefnInfo, Res, X, Y, Clause, !Info) :-
generate_compare_proc_body_solver(Context,
Res, X, Y, Clause, !Info)
;
- TypeBody = hlds_du_type(_, _, _, MaybeRepn, _),
+ TypeBody = hlds_du_type(_, MaybeSuperType, _, MaybeRepn, _),
(
MaybeRepn = no,
unexpected($pred, "MaybeRepn = no")
;
MaybeRepn = yes(Repn)
),
- DuTypeKind = Repn ^ dur_kind,
- (
- ( DuTypeKind = du_type_kind_mercury_enum
- ; DuTypeKind = du_type_kind_foreign_enum(_)
- ),
- generate_compare_proc_body_enum(Context,
- Res, X, Y, Clause, !Info)
- ;
- DuTypeKind = du_type_kind_direct_dummy,
- generate_compare_proc_body_dummy(Context,
- Res, X, Y, Clause, !Info)
- ;
- DuTypeKind = du_type_kind_notag(_, ArgType, _),
- ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType),
+ ( if
+ MaybeSuperType = yes(SuperType),
+ compilation_target_uses_high_level_data(ModuleInfo),
+ TVarSet = SpecDefnInfo ^ spdi_tvarset,
+ get_du_base_type(ModuleInfo, TVarSet, SuperType, BaseType)
+ then
+ % In high-level data grades, subtypes use the same class
+ % as their base type constructor.
+ %
+ % XXX SUBTYPE This produces the wrong ordering for subtypes
+ % whose functors are declared in a different order from their
+ % base types. However, it is probably better to define the
+ % standard ordering on subtypes to be the same as their base
+ % types, and report a warning if the functor order in a
+ % subtype definition differs.
+ generate_compare_proc_body_eqv(Context, BaseType, Res, X, Y,
+ Clause, !Info)
+ else
+ DuTypeKind = Repn ^ dur_kind,
(
- ArgIsDummy = is_dummy_type,
- % Treat this type as if it were a dummy type
- % itself.
+ ( DuTypeKind = du_type_kind_mercury_enum
+ ; DuTypeKind = du_type_kind_foreign_enum(_)
+ ),
+ generate_compare_proc_body_enum(Context,
+ Res, X, Y, Clause, !Info)
+ ;
+ DuTypeKind = du_type_kind_direct_dummy,
generate_compare_proc_body_dummy(Context,
Res, X, Y, Clause, !Info)
;
- ArgIsDummy = is_not_dummy_type,
+ DuTypeKind = du_type_kind_notag(_, ArgType, _),
+ ArgIsDummy = is_type_a_dummy(ModuleInfo, ArgType),
+ (
+ ArgIsDummy = is_dummy_type,
+ % Treat this type as if it were a dummy type
+ % itself.
+ generate_compare_proc_body_dummy(Context,
+ Res, X, Y, Clause, !Info)
+ ;
+ ArgIsDummy = is_not_dummy_type,
+ CtorRepns = Repn ^ dur_ctor_repns,
+ generate_compare_proc_body_du(SpecDefnInfo,
+ CtorRepns, Res, X, Y, Clause, !Info)
+ )
+ ;
+ DuTypeKind = du_type_kind_general,
CtorRepns = Repn ^ dur_ctor_repns,
generate_compare_proc_body_du(SpecDefnInfo,
CtorRepns, Res, X, Y, Clause, !Info)
)
- ;
- DuTypeKind = du_type_kind_general,
- CtorRepns = Repn ^ dur_ctor_repns,
- generate_compare_proc_body_du(SpecDefnInfo,
- CtorRepns, Res, X, Y, Clause, !Info)
)
)
).
@@ -2531,6 +2564,68 @@ generate_index_du_case(SpecDefnInfo, X, Index, CtorRepn, Goal, !N, !Info) :-
% Utility predicates.
%
+:- pred compilation_target_uses_high_level_data(module_info::in) is semidet.
+
+compilation_target_uses_high_level_data(ModuleInfo) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ compilation_target_high_level_data(Target) = yes.
+
+:- pred get_du_base_type(module_info::in, tvarset::in, mer_type::in,
+ mer_type::out) is det.
+
+get_du_base_type(ModuleInfo, TVarSet, Type, BaseType) :-
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ get_du_base_type_loop(TypeTable, TVarSet, Type, BaseType).
+
+:- pred get_du_base_type_loop(type_table::in, tvarset::in, mer_type::in,
+ mer_type::out) is det.
+
+get_du_base_type_loop(TypeTable, TVarSet, Type, BaseType) :-
+ % Circular subtype definitions are assumed to have been detected by now.
+ type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs),
+ hlds_data.lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ (
+ TypeBody = hlds_du_type(_, MaybeSuperType, _, _MaybeRepn, _),
+ (
+ MaybeSuperType = no,
+ BaseType = Type
+ ;
+ MaybeSuperType = yes(SuperType0),
+ hlds_data.get_type_defn_tvarset(TypeDefn, TypeDefnTVarSet),
+ hlds_data.get_type_defn_tparams(TypeDefn, TypeDefnTypeParams),
+ merge_tvarsets_and_subst_type_args(TVarSet, TypeArgs,
+ TypeDefnTVarSet, TypeDefnTypeParams, SuperType0, SuperType),
+ get_du_base_type_loop(TypeTable, TVarSet, SuperType, BaseType)
+ )
+ ;
+ TypeBody = hlds_abstract_type(_),
+ unexpected($pred, "abstract type")
+ ;
+ TypeBody = hlds_eqv_type(_),
+ unexpected($pred, "eqv type")
+ ;
+ TypeBody = hlds_foreign_type(_),
+ unexpected($pred, "foreign type")
+ ;
+ TypeBody = hlds_solver_type(_),
+ unexpected($pred, "solver type")
+ ).
+
+:- 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 build_simple_call(module_info::in, module_name::in, string::in,
list(prog_var)::in, prog_context::in, hlds_goal::out) is det.
diff --git a/java/runtime/TypeCtorInfo_Struct.java b/java/runtime/TypeCtorInfo_Struct.java
index 94a3b9745..363210cc6 100644
--- a/java/runtime/TypeCtorInfo_Struct.java
+++ b/java/runtime/TypeCtorInfo_Struct.java
@@ -26,6 +26,7 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
public int type_ctor_num_functors;
public short type_ctor_flags;
public int[] type_functor_number_map;
+ public TypeCtorInfo_Struct type_ctor_base; // null unless subtype
private final short MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE = 0x8;
@@ -50,7 +51,8 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
other.type_layout,
other.type_ctor_num_functors,
other.type_ctor_flags,
- other.type_functor_number_map
+ other.type_functor_number_map,
+ other.type_ctor_base
);
}
@@ -67,21 +69,23 @@ public class TypeCtorInfo_Struct extends PseudoTypeInfo
java.lang.Object ordinal_ordered_functor_descs, // TypeLayout
int num_functors,
short flags,
- int[] functor_number_map)
+ int[] functor_number_map,
+ TypeCtorInfo_Struct base_type_ctor)
{
- arity = type_arity;
- type_ctor_version = version;
- type_ctor_num_ptags = num_ptags;
- type_ctor_rep = new TypeCtorRep(rep);
- unify_pred = (MethodPtr) unify_proc;
- compare_pred = (MethodPtr) compare_proc;
- type_ctor_module_name = module;
- type_ctor_name = name;
- type_functors = (TypeFunctors) name_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;
+ this.arity = type_arity;
+ this.type_ctor_version = version;
+ this.type_ctor_num_ptags = num_ptags;
+ this.type_ctor_rep = new TypeCtorRep(rep);
+ this.unify_pred = (MethodPtr) unify_proc;
+ this.compare_pred = (MethodPtr) compare_proc;
+ this.type_ctor_module_name = module;
+ this.type_ctor_name = name;
+ this.type_functors = (TypeFunctors) name_ordered_functor_descs;
+ this.type_layout = (TypeLayout) ordinal_ordered_functor_descs;
+ this.type_ctor_num_functors = num_functors;
+ this.type_ctor_flags = flags;
+ this.type_functor_number_map = functor_number_map;
+ this.type_ctor_base = base_type_ctor;
}
// XXX this should be renamed `equals'
diff --git a/library/rtti_implementation.m b/library/rtti_implementation.m
index 708ad3eb2..a05fa567a 100644
--- a/library/rtti_implementation.m
+++ b/library/rtti_implementation.m
@@ -396,9 +396,9 @@ unify_tuple_pos(Loc, TupleArity, TypeInfo, TermA, TermB) :-
true
else
ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
-
- SubTermA = get_tuple_subterm(ArgTypeInfo, TermA, Loc - 1),
- SubTermB = get_tuple_subterm(ArgTypeInfo, TermB, Loc - 1),
+ % XXX just count from 0
+ get_tuple_subterm(TermA, Loc - 1, ArgTypeInfo, SubTermA),
+ get_tuple_subterm(TermB, Loc - 1, ArgTypeInfo, SubTermB),
private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
generic_unify(SubTermA, CastSubTermB),
@@ -423,9 +423,9 @@ compare_tuple_pos(Loc, TupleArity, TypeInfo, Result, TermA, TermB) :-
Result = (=)
else
ArgTypeInfo = var_arity_type_info_index_as_ti(TypeInfo, Loc),
-
- SubTermA = get_tuple_subterm(ArgTypeInfo, TermA, Loc - 1),
- SubTermB = get_tuple_subterm(ArgTypeInfo, TermB, Loc - 1),
+ % XXX just count from 0
+ get_tuple_subterm(TermA, Loc - 1, ArgTypeInfo, SubTermA),
+ get_tuple_subterm(TermB, Loc - 1, ArgTypeInfo, SubTermB),
private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
generic_compare(SubResult, SubTermA, CastSubTermB),
@@ -2034,13 +2034,35 @@ is_exist_pseudo_type_info(_, _) :-
private static object
ML_construct_du(runtime.TypeCtorInfo_Struct tc,
runtime.DuFunctorDesc functor_desc, list.List_1 arg_list)
+ {
+ TypeCtorInfo_Struct base_tc = tc.type_ctor_base;
+ if (base_tc != null) {
+ // For subtypes, we must derive the class and field names from the
+ // base type ctor.
+ byte ptag = functor_desc.du_functor_primary;
+ DuPtagLayout ptag_layout =
+ base_tc.index_or_search_ptag_layout(ptag);
+
+ int sectag = functor_desc.du_functor_secondary;
+ if (sectag == -1) {
+ sectag = 0;
+ }
+ DuFunctorDesc base_functor_desc =
+ ptag_layout.index_or_search_sectag_functor(sectag);
+
+ return ML_construct_du_2(base_tc, base_functor_desc, arg_list);
+ } else {
+ return ML_construct_du_2(tc, functor_desc, arg_list);
+ }
+ }
+
+ private static object
+ ML_construct_du_2(runtime.TypeCtorInfo_Struct tc,
+ runtime.DuFunctorDesc functor_desc, list.List_1 arg_list)
{
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)
@@ -2091,6 +2113,11 @@ is_exist_pseudo_type_info(_, _) :-
private static object
ML_construct_static_member(runtime.TypeCtorInfo_Struct tc, int i)
{
+ // For subtypes, we must derive the class name from the base type ctor.
+ if (tc.type_ctor_base != null) {
+ tc = tc.type_ctor_base;
+ }
+
string typename =
""mercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""+"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
@@ -2099,7 +2126,8 @@ is_exist_pseudo_type_info(_, _) :-
return System.Enum.ToObject(type, i);
}
- private static System.Type ML_search_type(string typename)
+ private static System.Type
+ ML_search_type(string typename)
{
// Do we need to optimise this? e.g. search the current assembly,
// then that which contains the standard library, or cache old results.
@@ -2114,6 +2142,7 @@ is_exist_pseudo_type_info(_, _) :-
return null;
}
+ // XXX fix name
private static string
ML_flipInitialCase(string s)
{
@@ -2481,16 +2510,42 @@ is_exist_pseudo_type_info(_, _) :-
private static Object
ML_construct_du(TypeCtorInfo_Struct tc, DuFunctorDesc functor_desc,
- list.List_1<univ.Univ_0> arg_list)
+ list.List_1<univ.Univ_0> arg_list)
throws ClassNotFoundException, NoSuchFieldException,
IllegalAccessException, InstantiationException,
InvocationTargetException
+ {
+ final jmercury.runtime.TypeCtorInfo_Struct base_tc = tc.type_ctor_base;
+ if (base_tc != null) {
+ // For subtypes, we must derive the class and field names from the
+ // base type ctor.
+ byte ptag = functor_desc.du_functor_primary;
+ jmercury.runtime.DuPtagLayout ptag_layout =
+ base_tc.index_or_search_ptag_layout(ptag);
+
+ int sectag = functor_desc.du_functor_secondary;
+ if (sectag == -1) {
+ sectag = 0;
+ }
+ jmercury.runtime.DuFunctorDesc base_functor_desc =
+ ptag_layout.index_or_search_sectag_functor(sectag);
+
+ return ML_construct_du_2(base_tc, base_functor_desc, arg_list);
+ } else {
+ return ML_construct_du_2(tc, functor_desc, arg_list);
+ }
+ }
+
+ private static Object
+ ML_construct_du_2(TypeCtorInfo_Struct tc, DuFunctorDesc functor_desc,
+ list.List_1<univ.Univ_0> arg_list)
+ throws
+ ClassNotFoundException, NoSuchFieldException,
+ IllegalAccessException, InstantiationException,
+ 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))
@@ -2569,6 +2624,11 @@ is_exist_pseudo_type_info(_, _) :-
throws ClassNotFoundException, NoSuchFieldException,
IllegalAccessException
{
+ // For subtypes, we must derive the class name from the base type ctor.
+ if (tc.type_ctor_base != null) {
+ tc = tc.type_ctor_base;
+ }
+
Class<?> cls = Class.forName(
""jmercury."" + ML_name_mangle(tc.type_ctor_module_name)
+ ""$"" + ML_flipInitialCase(ML_name_mangle(tc.type_ctor_name))
@@ -2580,6 +2640,7 @@ is_exist_pseudo_type_info(_, _) :-
return field.get(cls);
}
+ // XXX fix name
private static String
ML_flipInitialCase(String s)
{
@@ -2824,7 +2885,7 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Ordinal = int32.to_int(FunctorDesc ^ du_functor_ordinal),
Arity = int16.to_int(FunctorDesc ^ du_functor_arity),
Arguments = iterate(0, Arity - 1,
- get_arg_univ(Term, SecTagLocn, FunctorDesc, TypeInfo))
+ get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc))
;
SecTagLocn = stag_local_rest_of_word,
Functor = "some_du_local_sectag",
@@ -3012,9 +3073,9 @@ deconstruct_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon,
Ordinal = 0,
Arity = get_var_arity_typeinfo_arity(TypeInfo),
list.map_foldl(
- (pred(TI::in, U::out, Index::in, Next::out) is det :-
- SubTerm = get_tuple_subterm(TI, Term, Index),
- U = univ(SubTerm),
+ ( pred(ArgTypeInfo::in, Univ::out, Index::in, Next::out) is det :-
+ get_tuple_subterm(Term, Index, ArgTypeInfo, SubTerm),
+ Univ = univ(SubTerm),
Next = Index + 1
), TypeArgs, Arguments, 0, _)
;
@@ -3218,7 +3279,7 @@ univ_named_arg_2(Term, TypeInfo, TypeCtorInfo, TypeCtorRep, NonCanon, Name,
get_du_functor_arg_names(FunctorDesc, Names),
search_arg_names(Names, 0, Arity, Name, Index)
then
- ArgUniv = get_arg_univ(Term, SecTagLocn, FunctorDesc, TypeInfo,
+ ArgUniv = get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc,
Index),
MaybeArgument = yes(ArgUniv)
else
@@ -3405,20 +3466,21 @@ expand_type_name(TypeCtorInfo, Wrap) = Name :-
% 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,
- type_info::in, int::in, T::out) is det.
+:- some [ArgT] pred get_arg(T::in, type_info::in, sectag_locn::in,
+ du_functor_desc::in, int::in, ArgT::out) is det.
-get_arg(Term, SecTagLocn, FunctorDesc, TypeInfo, Index, Arg) :-
+get_arg(Term, TypeInfo, SecTagLocn, FunctorDesc, Index, Arg) :-
( if get_du_functor_exist_info(FunctorDesc, ExistInfo) then
- ExtraArgs = int16.to_int(exist_info_typeinfos_plain(ExistInfo)) +
+ NumExtraArgs0 =
+ int16.to_int(exist_info_typeinfos_plain(ExistInfo)) +
int16.to_int(exist_info_tcis(ExistInfo))
else
- ExtraArgs = 0
+ NumExtraArgs0 = 0
),
ArgTypes = FunctorDesc ^ du_functor_arg_types,
PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, Index),
- get_arg_type_info(TypeInfo, PseudoTypeInfo, Term, FunctorDesc,
+ get_arg_type_info(Term, TypeInfo, FunctorDesc, PseudoTypeInfo,
ArgTypeInfo),
( if
( SecTagLocn = stag_none
@@ -3426,25 +3488,25 @@ get_arg(Term, SecTagLocn, FunctorDesc, TypeInfo, Index, Arg) :-
; high_level_data
)
then
- TagOffset = 0
+ NumExtraArgs = NumExtraArgs0
else
- TagOffset = 1
+ NumExtraArgs = NumExtraArgs0 + 1
),
- RealArgsOffset = TagOffset + ExtraArgs,
- Arg = get_subterm(FunctorDesc, ArgTypeInfo, Term, Index, RealArgsOffset).
+ get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs,
+ ArgTypeInfo, Arg).
-:- func get_arg_univ(U, sectag_locn, du_functor_desc, type_info, int) = univ.
+:- func get_arg_univ(T, type_info, sectag_locn, du_functor_desc, int) = univ.
-get_arg_univ(Term, SecTagLocn, FunctorDesc, TypeInfo, Index) = Univ :-
- get_arg(Term, SecTagLocn, FunctorDesc, TypeInfo, Index, Arg),
+get_arg_univ(Term, TypeInfo, SecTagLocn, FunctorDesc, Index) = Univ :-
+ get_arg(Term, TypeInfo, SecTagLocn, FunctorDesc, Index, Arg),
type_to_univ(Arg, Univ).
%---------------------%
-:- pred get_arg_type_info(type_info::in, pseudo_type_info::in, T::in,
- du_functor_desc::in, type_info::out) is det.
+:- pred get_arg_type_info(T::in, type_info::in, du_functor_desc::in,
+ pseudo_type_info::in, type_info::out) is det.
-get_arg_type_info(TypeInfoParams, PseudoTypeInfo, Term, FunctorDesc,
+get_arg_type_info(Term, TypeInfoParams, FunctorDesc, PseudoTypeInfo,
ArgTypeInfo) :-
( if pseudo_type_info_is_variable(PseudoTypeInfo, VarNum) then
get_type_info_for_var(TypeInfoParams, VarNum, Term,
@@ -3472,7 +3534,7 @@ get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
Offset, I, Max, !ArgTypeInfo) :-
( if I < Max then
get_pti_from_type_info_index(TypeInfo, Offset, I, PTI),
- get_arg_type_info(TypeInfoParams, PTI, Term, FunctorDesc, ETypeInfo),
+ get_arg_type_info(Term, TypeInfoParams, FunctorDesc, PTI, ETypeInfo),
set_type_info_index(Offset, I, ETypeInfo, !ArgTypeInfo),
get_arg_type_info_2(TypeInfoParams, TypeInfo, Term, FunctorDesc,
Offset, I + 1, Max, !ArgTypeInfo)
@@ -3647,124 +3709,240 @@ 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.
- %
-:- some [T] func get_subterm(du_functor_desc, type_info, U, int, int) = T.
+:- some [ArgT] pred get_subterm(T::in, type_info::in, du_functor_desc::in,
+ int::in, int::in, type_info::in, ArgT::out) is det.
-get_subterm(_, _, _, _, _) = -1 :-
+get_subterm(_, _, _, _, _, _, -1) :-
det_unimplemented("get_subterm").
:- pragma foreign_proc("C#",
- get_subterm(FunctorDesc::in, SubTermTypeInfo::in, Term::in,
- Index::in, ExtraArgs::in) = (Arg::out),
+ get_subterm(Term::in, TypeInfo::in, FunctorDesc::in,
+ Index::in, NumExtraArgs::in, ArgTypeInfo::in, Arg::out),
[will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
"
// Mention TypeInfo_for_U to avoid a warning.
- if (Term is object[]) {
- int i = Index + ExtraArgs;
- Arg = ((object[]) Term)[i];
- } else {
- string fieldName = null;
- if (FunctorDesc.du_functor_arg_names != null) {
- fieldName = FunctorDesc.du_functor_arg_names[Index];
+ Arg = ML_get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs);
+ TypeInfo_for_ArgT = ArgTypeInfo;
+").
+
+:- pragma foreign_proc("Java",
+ get_subterm(Term::in, TypeInfo::in, FunctorDesc::in,
+ Index::in, NumExtraArgs::in, ArgTypeInfo::in, Arg::out),
+ [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
+"
+ // Mention TypeInfo_for_T to avoid a warning.
+
+ // Currently we use reflection to extract the field.
+ // It probably would be more efficient to generate
+ // a method for each class to return its n'th field.
+ Arg = ML_get_subterm(Term, TypeInfo, FunctorDesc, Index, NumExtraArgs);
+ assert Arg != null;
+
+ TypeInfo_for_ArgT = ArgTypeInfo;
+").
+
+:- pragma foreign_code("C#",
+"
+ private static object
+ ML_get_subterm(object term,
+ TypeInfo_Struct type_info,
+ DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
+ if (term is object[]) {
+ int i = index + num_extra_args;
+ return ((object[]) term)[i];
+ } else {
+ return ML_get_subterm_non_array(term, type_info, functor_desc,
+ index, num_extra_args);
+ }
+ }
+
+ private static object
+ ML_get_subterm_non_array(object term,
+ TypeInfo_Struct type_info,
+ DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
+ TypeCtorInfo_Struct base_tc = type_info.type_ctor.type_ctor_base;
+ string field_name;
+
+ if (base_tc != null) {
+ // For subtypes, we need to get the corresponding DuFunctorDesc
+ // from the base type ctor.
+ DuFunctorDesc base_functor_desc =
+ ML_get_functor_desc_by_tags(base_tc,
+ functor_desc.du_functor_primary,
+ functor_desc.du_functor_secondary);
+ field_name =
+ ML_get_field_name_by_index(base_functor_desc,
+ index, num_extra_args);
+ } else {
+ field_name =
+ ML_get_field_name_by_index(functor_desc,
+ index, num_extra_args);
+ }
+
+ return ML_get_subterm_by_field_name(term, field_name);
+ }
+
+ private static DuFunctorDesc
+ ML_get_functor_desc_by_tags(TypeCtorInfo_Struct base_tc,
+ byte ptag, int sectag)
+ {
+ DuPtagLayout ptag_layout = base_tc.index_or_search_ptag_layout(ptag);
+ if (sectag == -1) {
+ sectag = 0;
}
- if (fieldName != null) {
- fieldName = ML_name_mangle(fieldName);
+ return ptag_layout.index_or_search_sectag_functor(sectag);
+ }
+
+ private static string
+ ML_get_field_name_by_index(DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
+ // Look up the field name if it exists, otherwise recreate the field
+ // name that would have been used.
+ string field_name = null;
+ if (functor_desc.du_functor_arg_names != null) {
+ field_name = functor_desc.du_functor_arg_names[index];
+ }
+ if (field_name != null) {
+ field_name = ML_name_mangle(field_name);
} else {
// The F<i> field variables are numbered from 1.
- int i = 1 + Index + ExtraArgs;
- fieldName = ""F"" + i;
+ int i = 1 + index + num_extra_args;
+ field_name = ""F"" + i;
}
+ return field_name;
+ }
- System.Reflection.FieldInfo f = Term.GetType().GetField(fieldName);
+ private static object
+ ML_get_subterm_by_field_name(object term, string field_name)
+ {
+ System.Reflection.FieldInfo f = term.GetType().GetField(field_name);
if (f == null) {
- throw new System.Exception(""no such field: "" + fieldName);
+ throw new System.Exception(""no such field: "" + field_name);
}
- Arg = f.GetValue(Term);
+ return f.GetValue(term);
}
-
- TypeInfo_for_T = SubTermTypeInfo;
").
-:- pragma foreign_proc("Java",
- get_subterm(FunctorDesc::in, SubTermTypeInfo::in, Term::in,
- Index::in, ExtraArgs::in) = (Arg::out),
- [will_not_call_mercury, promise_pure, thread_safe, may_not_duplicate],
+:- pragma foreign_code("Java",
"
- // Mention TypeInfo_for_U to avoid a warning.
+ private static Object
+ ML_get_subterm(Object term,
+ jmercury.runtime.TypeInfo_Struct type_info,
+ jmercury.runtime.DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
+ if (term instanceof Object[]) {
+ int i = index + num_extra_args;
+ return ((Object[]) term)[i];
+ } else {
+ return ML_get_subterm_non_array(term, type_info, functor_desc,
+ index, num_extra_args);
+ }
+ }
- // Currently we use reflection to extract the field.
- // It probably would be more efficient to generate
- // a method for each class to return its n'th field.
+ private static Object
+ ML_get_subterm_non_array(Object term,
+ jmercury.runtime.TypeInfo_Struct type_info,
+ jmercury.runtime.DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
+ jmercury.runtime.TypeCtorInfo_Struct base_tc =
+ type_info.type_ctor.type_ctor_base;
+ String field_name;
+
+ if (base_tc != null) {
+ // For subtypes, we need to get the corresponding DuFunctorDesc in
+ // the base type ctor.
+ jmercury.runtime.DuFunctorDesc base_functor_desc =
+ ML_get_functor_desc_by_tags(base_tc,
+ functor_desc.du_functor_primary,
+ functor_desc.du_functor_secondary);
+ field_name =
+ ML_get_field_name_by_index(base_functor_desc,
+ index, num_extra_args);
+ } else {
+ field_name =
+ ML_get_field_name_by_index(functor_desc,
+ index, num_extra_args);
+ }
- if (Term instanceof Object[]) {
- int i = Index + ExtraArgs;
- Arg = ((Object[]) Term)[i];
- } else {
+ return ML_get_subterm_by_field_name(term, field_name);
+ }
+
+ private static jmercury.runtime.DuFunctorDesc
+ ML_get_functor_desc_by_tags(jmercury.runtime.TypeCtorInfo_Struct base_tc,
+ byte ptag, int sectag)
+ {
+ jmercury.runtime.DuPtagLayout ptag_layout =
+ base_tc.index_or_search_ptag_layout(ptag);
+ if (sectag == -1) {
+ sectag = 0;
+ }
+ return ptag_layout.index_or_search_sectag_functor(sectag);
+ }
+
+ private static String
+ ML_get_field_name_by_index(jmercury.runtime.DuFunctorDesc functor_desc,
+ int index, int num_extra_args)
+ {
// Look up the field name if it exists, otherwise recreate the field
// name that would have been used.
- String fieldName = null;
- if (FunctorDesc.du_functor_arg_names != null) {
- fieldName = FunctorDesc.du_functor_arg_names[Index];
+ String field_name = null;
+ if (functor_desc.du_functor_arg_names != null) {
+ field_name = functor_desc.du_functor_arg_names[index];
}
- if (fieldName != null) {
- fieldName = ML_name_mangle(fieldName);
+ if (field_name != null) {
+ field_name = ML_name_mangle(field_name);
} else {
// The F<i> field variables are numbered from 1.
- int i = 1 + Index + ExtraArgs;
- fieldName = ""F"" + i;
+ int i = 1 + index + num_extra_args;
+ field_name = ""F"" + i;
}
+ return field_name;
+ }
+ private static Object
+ ML_get_subterm_by_field_name(Object term, String field_name)
+ {
try {
- Field f = Term.getClass().getDeclaredField(fieldName);
- Arg = f.get(Term);
+ Field f = term.getClass().getDeclaredField(field_name);
+ return f.get(term);
} catch (IllegalAccessException e) {
throw new Error(e);
} catch (NoSuchFieldException e) {
throw new Error(e);
}
}
-
- assert Arg != null;
-
- 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.
+:- some [ArgT] pred get_tuple_subterm(T::in, int::in, type_info::in, ArgT::out)
+ is det.
-get_tuple_subterm(TypeInfo, Term, Index) = SubTerm :-
- % Reuse the code in get_subterm.
- % Passing null for FunctorDesc is okay because the C# implementation
- % doesn't use it, and the Java implementation doesn't use it if
- % the Term is an array (true of tuples).
- SubTerm = get_subterm(null_functor_desc, TypeInfo, Term, Index, 0).
+get_tuple_subterm(_, _, _, -1) :-
+ private_builtin.sorry("get_tuple_subterm").
-%---------------------%
-
-:- func null_functor_desc = du_functor_desc.
:- pragma foreign_proc("C#",
- null_functor_desc = (NullFunctorDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe],
+ get_tuple_subterm(Term::in, Index::in, ArgTypeInfo::in, Arg::out),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
- NullFunctorDesc = null;
+ Arg = ((object[]) Term)[Index];
+ TypeInfo_for_ArgT = ArgTypeInfo;
").
+
:- pragma foreign_proc("Java",
- null_functor_desc = (NullFunctorDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe],
-"
- NullFunctorDesc = null;
-").
-:- pragma foreign_proc("C",
- null_functor_desc = (NullFunctorDesc::out),
- [will_not_call_mercury, promise_pure, thread_safe],
+ get_tuple_subterm(Term::in, Index::in, ArgTypeInfo::in, Arg::out),
+ [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
"
- NullFunctorDesc = (MR_Word) NULL;
+ Arg = ((Object[]) Term)[Index];
+ TypeInfo_for_ArgT = ArgTypeInfo;
").
%---------------------%
diff --git a/runtime/mercury_dotnet.cs.in b/runtime/mercury_dotnet.cs.in
index bed8d333d..271dbc7e9 100644
--- a/runtime/mercury_dotnet.cs.in
+++ b/runtime/mercury_dotnet.cs.in
@@ -369,19 +369,20 @@ public class PseudoTypeInfo {
}
public class TypeCtorInfo_Struct : PseudoTypeInfo {
- public int arity;
- public byte type_ctor_version;
- public sbyte type_ctor_num_ptags;
- public TypeCtorRep type_ctor_rep;
- public object unify_pred;
- public object compare_pred;
- public string type_ctor_module_name;
- public string type_ctor_name;
- public TypeFunctors type_functors;
- public TypeLayout type_layout;
- public int type_ctor_num_functors;
- public ushort type_ctor_flags;
- public int[] type_functor_number_map;
+ public int arity;
+ public byte type_ctor_version;
+ public sbyte type_ctor_num_ptags;
+ public TypeCtorRep type_ctor_rep;
+ public object unify_pred;
+ public object compare_pred;
+ public string type_ctor_module_name;
+ public string type_ctor_name;
+ public TypeFunctors type_functors;
+ public TypeLayout type_layout;
+ public int type_ctor_num_functors;
+ public ushort type_ctor_flags;
+ public int[] type_functor_number_map;
+ public TypeCtorInfo_Struct type_ctor_base; // null unless subtype
private const ushort MR_TYPE_CTOR_FLAG_LAYOUT_INDEXABLE = 0x8;
@@ -406,7 +407,8 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
other.type_layout,
other.type_ctor_num_functors,
other.type_ctor_flags,
- other.type_functor_number_map
+ other.type_functor_number_map,
+ other.type_ctor_base
);
}
@@ -423,21 +425,23 @@ public class TypeCtorInfo_Struct : PseudoTypeInfo {
object ordinal_ordered_functor_descs, // TypeLayout
int num_functors,
ushort flags,
- int[] functor_number_map)
+ int[] functor_number_map,
+ TypeCtorInfo_Struct type_ctor_base)
{
- arity = type_arity;
- type_ctor_version = version;
- type_ctor_num_ptags = num_ptags;
- type_ctor_rep = rep;
- unify_pred = unify_proc;
- compare_pred = compare_proc;
- type_ctor_module_name = module;
- type_ctor_name = name;
- type_functors = (TypeFunctors) name_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;
+ this.arity = type_arity;
+ this.type_ctor_version = version;
+ this.type_ctor_num_ptags = num_ptags;
+ this.type_ctor_rep = rep;
+ this.unify_pred = unify_proc;
+ this.compare_pred = compare_proc;
+ this.type_ctor_module_name = module;
+ this.type_ctor_name = name;
+ this.type_functors = (TypeFunctors) name_ordered_functor_descs;
+ this.type_layout = (TypeLayout) ordinal_ordered_functor_descs;
+ this.type_ctor_num_functors = num_functors;
+ this.type_ctor_flags = flags;
+ this.type_functor_number_map = functor_number_map;
+ this.type_ctor_base = type_ctor_base;
}
public override bool Equals(object other) {
diff --git a/runtime/mercury_type_info.h b/runtime/mercury_type_info.h
index ed00dca4a..a43e9e6ce 100644
--- a/runtime/mercury_type_info.h
+++ b/runtime/mercury_type_info.h
@@ -1261,10 +1261,13 @@ struct MR_TypeCtorInfo_Struct {
MR_uint_least16_t MR_type_ctor_flags;
MR_FunctorNumberMap MR_type_ctor_functor_number_map;
-// The following fields will be added later, once we can exploit them:
-// MR_TrieNodePtr MR_type_ctor_std_table;
-// MR_ProcAddr MR_type_ctor_prettyprinter;
+ // The following field is required when using high-level data
+ // (Java and C#) but not for low-level data (both C backends):
+ // MR_TypeCtorInfo_Struct *MR_type_ctor_base;
+ // The following fields will be added later, once we can exploit them:
+ // MR_TrieNodePtr MR_type_ctor_std_table;
+ // MR_ProcAddr MR_type_ctor_prettyprinter;
};
// Check whether an MR_TypeCtorRepInt is a valid MR_TypeCtorRep value.
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 5f966063a..23ed2129e 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -392,6 +392,7 @@ ORDINARY_PROGS = \
string_various \
string_well_formed \
string_well_formed_utf8 \
+ subtype_abstract \
subtype_pack \
subtype_rtti \
sv_nested_closures \
diff --git a/tests/hard_coded/subtype_abstract.exp b/tests/hard_coded/subtype_abstract.exp
new file mode 100644
index 000000000..93ca24748
--- /dev/null
+++ b/tests/hard_coded/subtype_abstract.exp
@@ -0,0 +1 @@
+foo(pair(3.14159, 42))
diff --git a/tests/hard_coded/subtype_abstract.m b/tests/hard_coded/subtype_abstract.m
new file mode 100644
index 000000000..7b73b378d
--- /dev/null
+++ b/tests/hard_coded/subtype_abstract.m
@@ -0,0 +1,25 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_abstract.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module subtype_abstract_2.
+
+:- type foo(T, U)
+ ---> foo(
+ my_field :: abstract_pair(T, U)
+ ).
+
+main(!IO) :-
+ X = foo(make_abstract_pair(42, 3.14159)),
+ io.print_line(X, !IO).
diff --git a/tests/hard_coded/subtype_abstract_2.m b/tests/hard_coded/subtype_abstract_2.m
new file mode 100644
index 000000000..93b7bf16f
--- /dev/null
+++ b/tests/hard_coded/subtype_abstract_2.m
@@ -0,0 +1,30 @@
+%---------------------------------------------------------------------------%
+% vim: ts=4 sw=4 et ft=mercury
+%---------------------------------------------------------------------------%
+
+:- module subtype_abstract_2.
+:- interface.
+
+:- type abstract_pair(T, U).
+
+:- func make_abstract_pair(T, U) = abstract_pair(T, U).
+
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type bar(T, U)
+ ---> red
+ ; green
+ ; blue
+ ; pair(U, T).
+
+:- type bar_pair(T, U) =< bar(T, U)
+ ---> pair(U, T).
+
+:- type eqv_bar_pair(T, U) == bar_pair(T, U).
+
+:- type abstract_pair(T, U) =< eqv_bar_pair(T, U)
+ ---> pair(U, T).
+
+make_abstract_pair(X, Y) = pair(Y, X).
diff --git a/tests/hard_coded/subtype_rtti.exp2 b/tests/hard_coded/subtype_rtti.exp2
index 5e166a5c3..28eafa865 100644
--- a/tests/hard_coded/subtype_rtti.exp2
+++ b/tests/hard_coded/subtype_rtti.exp2
@@ -93,7 +93,9 @@ construct.get_functor_with_names
arg names: [no]
construct.find_functor
arg type descs: [int]
-construct.construct skipped
+construct.construct
+ f1(42)
+unify ok
--------------------
term
diff --git a/tests/hard_coded/subtype_rtti.m b/tests/hard_coded/subtype_rtti.m
index 35470df82..520973e48 100644
--- a/tests/hard_coded/subtype_rtti.m
+++ b/tests/hard_coded/subtype_rtti.m
@@ -235,15 +235,7 @@ test(Term, !IO) :-
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
+ ( 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
@@ -276,10 +268,3 @@ print_value(Label, Value, !IO) :-
),
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