[m-rev.] for review: move towards replacing base_typeclass_infos
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Oct 20 10:49:16 AEST 2003
For review by Fergus.
Zoltan.
Move toward the proposed structures for representing type class information at
runtime by adding code for generating the structures corresponding to
base_typeclass_infos. The structures corresponding to typeclass_infos will
be added in a later change.
Register the new data structures in a table at runtime.
Add four new mdb developer commands for checking the contents of the new
type class table, as well as the contents of the existing type constructor
table: class_decl, type_ctor, all_class_decls and all_type_ctors.
compiler/rtti.m:
Add the data types required to represent the new runtime data
structures that will eventually replace base_typeclass_infos
inside the compiler.
Add the required function symbols to the data types representing both
the new RTTI data structures themselves and those representing
references to them.
Make the required changes to the predicates operating on the modified
data types, and add some required new predicates.
compiler/rtti_out.m:
Add code to write out the new data structures for the LLDS backend.
Make some changes in existing predicates to allow them to be used
in the new code.
compiler/type_class_info.m:
A new module to generate the new RTTI data structures.
compiler/backend_libs.m:
Include the new module.
compiler/options.m:
Add a new option, --new-type-class-rtti, to control whether we
invoke the top level predicate of type_class_info.m to generate
the new type class RTTI structures. We still generate and use
base_typeclass_infos regardless of the value of this option.
compiler/mercury_compile.m:
Invoke the code of the new module if --new-type-class-rtti is given.
compiler/opt_debug.m:
Add code to dump descriptions of the new rtti_ids.
compiler/mlds_to_gcc.m:
compiler/rtti_to_mlds.m:
Handle the new alternatives in the rtti data types, mostly by throwing
exceptions. The actual code should be written later by Fergus.
compiler/pseudo_type_info.m:
Module qualify the names of builtin types when generating
pseudo-typeinfos for them. This makes the naming scheme more regular.
library/list.m:
Add a utility predicate for use by compiler/rtti_out.m.
runtime/mercury_typeclass_info.h:
Make some changes in the C data types representing type class
information that I discovered to be necessary or advantageous
in the process of generating values of those types automatically.
Rename some types to make their names be better documentation.
Change some arrays of pointers to structures into arrays of structures,
where the structures at different array indexes are the same size.
Removing consts that rtti_out.m supplies automatically avoids
duplicate const errors from the C compiler.
Add #includes to make the file namespace clean.
Protect against multiple inclusion.
runtime/mercury_typeclass_info_example.c:
Remove this file. After the changes to mercury_typeclass_info.h, its
contents are no longer correct examples of the structures in
mercury_typeclass_info.h, and since the compiler can now generate
those structures automatically, hand-written examples no longer serve
any useful pupose.
runtime/mercury_types.h:
Add a new type, MR_CodePtr, for use in mercury_typeclass_info.h.
The compiler predicate tc_rtti_name_type wants single-word names
for types.
runtime/mercury_imp.h:
#include mercury_typeclass_info.h.
runtime/mercury_type_tables.[ch]:
Add functions to register and to look up type class declarations and
type class instances.
Add the functions and data structures required to look up all type
constructors and all type classes. The debugger uses these to support
the commands that let the programmer check the contents of these
tables.
Eventually, we should be able to use the type class tables to test
whether a vector of types is a member of a given type class.
runtime/mercury_wrapper.c:
runtime/mercury_type_info.[ch]:
Move the array of type_ctor_rep names from the mercury_wrapper module
to the mercury_type_info module, and make it always-defined and public;
the debugger also needs access to it now.
runtime/Mmakefile:
Add mercury_typeclass_info.h to the list of header files that other
files depend on.
trace/mercury_trace_internal.c:
Add four new mdb commands: class_decl, type_ctor, all_class_decls
and all_type_ctors.
Make some existing code follow our coding conventions.
doc/user_guide.texi:
doc/mdb_categories:
Document the four new mdb commands.
tests/debugger/class_decl.{m,inp,exp}:
A new test case to test the new mdb commands.
tests/debugger/Mmakefile:
tests/debugger/Mercury.options:
Add the new test case.
tests/debugger/completion.exp:
Expect the new commands to appear in the command name completion.
tests/debugger/mdb_command_test.inp:
Test the documentation of the new mdb commands.
Expect the new commands to appear in the command name completion.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/backend_libs.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/backend_libs.m,v
retrieving revision 1.4
diff -u -b -r1.4 backend_libs.m
--- compiler/backend_libs.m 16 Mar 2003 08:01:26 -0000 1.4
+++ compiler/backend_libs.m 16 Oct 2003 04:11:47 -0000
@@ -33,6 +33,7 @@
:- include_module rtti.
:- include_module switch_util.
:- include_module type_ctor_info.
+:- include_module type_class_info.
:- end_module backend_libs.
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.289
diff -u -b -r1.289 mercury_compile.m
--- compiler/mercury_compile.m 6 Aug 2003 12:38:10 -0000 1.289
+++ compiler/mercury_compile.m 16 Oct 2003 13:10:05 -0000
@@ -100,6 +100,7 @@
:- import_module backend_libs__foreign.
:- import_module backend_libs__export.
:- import_module backend_libs__base_typeclass_info.
+:- import_module backend_libs__type_class_info.
% the Aditi-RL back-end
:- import_module aditi_backend__rl_gen.
@@ -3582,7 +3583,17 @@
% rather than output_pass.
%
{ type_ctor_info__generate_rtti(HLDS, TypeCtorRttiData) },
- { base_typeclass_info__generate_rtti(HLDS, TypeClassInfoRttiData) },
+ { base_typeclass_info__generate_rtti(HLDS, OldTypeClassInfoRttiData) },
+ globals__io_lookup_bool_option(new_type_class_rtti, NewTypeClassRtti),
+ {
+ NewTypeClassRtti = no,
+ TypeClassInfoRttiData = OldTypeClassInfoRttiData
+ ;
+ NewTypeClassRtti = yes,
+ type_class_info__generate_rtti(HLDS, NewTypeClassInfoRttiData),
+ list__append(OldTypeClassInfoRttiData, NewTypeClassInfoRttiData,
+ TypeClassInfoRttiData)
+ },
{ list__map(llds__wrap_rtti_data, TypeCtorRttiData, TypeCtorTables) },
{ list__map(llds__wrap_rtti_data, TypeClassInfoRttiData,
TypeClassInfos) },
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.86
diff -u -b -r1.86 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 13 May 2003 08:51:48 -0000 1.86
+++ compiler/mlds_to_gcc.m 16 Oct 2003 04:09:35 -0000
@@ -2125,6 +2125,35 @@
build_rtti_type_tc_name(base_typeclass_info(_, _, _), Size, GCC_Type) -->
{ MR_BaseTypeclassInfo = gcc__ptr_type_node },
build_sized_array_type(MR_BaseTypeclassInfo, Size, GCC_Type).
+build_rtti_type_tc_name(type_class_id(_), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_id NYI") }.
+build_rtti_type_tc_name(type_class_decl(_), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_decl NYI") }.
+build_rtti_type_tc_name(type_class_decl_super(_, _, _), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_decl_super NYI") }.
+build_rtti_type_tc_name(type_class_decl_supers(_), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_decl_supers NYI") }.
+build_rtti_type_tc_name(type_class_id_var_names(_), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_id_var_names NYI") }.
+build_rtti_type_tc_name(type_class_id_method_ids(_), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_id_method_ids NYI") }.
+build_rtti_type_tc_name(type_class_instance(_, _), _Size, _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_instance NYI") }.
+build_rtti_type_tc_name(type_class_instance_tc_type_vector(_, _), _Size,
+ _GCC_Type) -->
+ { error("build_rtti_type_tc_name: " ++
+ "type_class_instance_tc_type_vector NYI") }.
+build_rtti_type_tc_name(type_class_instance_constraint(_, _, _, _), _Size,
+ _GCC_Type) -->
+ { error("build_rtti_type_tc_name: " ++
+ "type_class_instance_constraint NYI") }.
+build_rtti_type_tc_name(type_class_instance_constraints(_, _), _Size,
+ _GCC_Type) -->
+ { error("build_rtti_type_tc_name: " ++
+ "type_class_instance_constraints NYI") }.
+build_rtti_type_tc_name(type_class_instance_methods(_, _), _Size,
+ _GCC_Type) -->
+ { error("build_rtti_type_tc_name: type_class_instance_methods NYI") }.
:- pred build_type_info_type(rtti_type_info::in,
gcc__type::out, io__state::di, io__state::uo) is det.
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.133
diff -u -b -r1.133 opt_debug.m
--- compiler/opt_debug.m 27 May 2003 05:57:15 -0000 1.133
+++ compiler/opt_debug.m 16 Oct 2003 03:29:16 -0000
@@ -72,6 +72,13 @@
:- pred opt_debug__dump_rtti_type_ctor(rtti_type_ctor, string).
:- mode opt_debug__dump_rtti_type_ctor(in, out) is det.
+:- pred opt_debug__dump_rtti_type_class_name(tc_name, string).
+:- mode opt_debug__dump_rtti_type_class_name(in, out) is det.
+
+:- pred opt_debug__dump_rtti_type_class_instance_name(tc_name, list(tc_type),
+ string).
+:- mode opt_debug__dump_rtti_type_class_instance_name(in, in, out) is det.
+
:- pred opt_debug__dump_rtti_name(ctor_rtti_name, string).
:- mode opt_debug__dump_rtti_name(in, out) is det.
@@ -420,6 +427,87 @@
opt_debug__dump_tc_rtti_name(base_typeclass_info(_ModuleName, ClassId,
InstanceStr), Str) :-
Str = make_base_typeclass_info_name(ClassId, InstanceStr).
+opt_debug__dump_tc_rtti_name(type_class_id(TCName), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "id",
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_decl(TCName), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "decl",
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_decl_super(TCName, Ordinal, _), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "decl_super",
+ string__int_to_string(Ordinal, OrdinalStr),
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, "(", OrdinalStr, "))"], Str).
+opt_debug__dump_tc_rtti_name(type_class_decl_supers(TCName), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "decl_supers",
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_id_method_ids(TCName), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "id_method_ids",
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_id_var_names(TCName), Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameStr),
+ DataNameStr = "id_var_names",
+ string__append_list(["tc_rtti_addr(", TCNameStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_instance(TCName, TCTypes), Str) :-
+ opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes,
+ InstanceStr),
+ DataNameStr = "instance",
+ string__append_list(["tc_rtti_addr(", InstanceStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_instance_tc_type_vector(TCName,
+ TCTypes), Str) :-
+ opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes,
+ InstanceStr),
+ DataNameStr = "instance_tc_types_vector",
+ string__append_list(["tc_rtti_addr(", InstanceStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_instance_constraints(TCName,
+ TCTypes), Str) :-
+ opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes,
+ InstanceStr),
+ DataNameStr = "instance_constraints",
+ string__append_list(["tc_rtti_addr(", InstanceStr, ", ",
+ DataNameStr, ")"], Str).
+opt_debug__dump_tc_rtti_name(type_class_instance_constraint(TCName,
+ TCTypes, Ordinal, _), Str) :-
+ opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes,
+ InstanceStr),
+ DataNameStr = "instance_constraint",
+ string__int_to_string(Ordinal, OrdinalStr),
+ string__append_list(["tc_rtti_addr(", InstanceStr, ", ",
+ DataNameStr, "(", OrdinalStr, "))"], Str).
+opt_debug__dump_tc_rtti_name(type_class_instance_methods(TCName, TCTypes),
+ Str) :-
+ opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes,
+ InstanceStr),
+ DataNameStr = "instance_methods",
+ string__append_list(["tc_rtti_addr(", InstanceStr, ", ",
+ DataNameStr, ")"], Str).
+
+opt_debug__dump_rtti_type_class_name(tc_name(ModuleName, ClassName, Arity),
+ Str) :-
+ ModuleNameStr = sym_name_mangle(ModuleName),
+ ClassNameStr = name_mangle(ClassName),
+ string__int_to_string(Arity, ArityStr),
+ string__append_list(["tc_name(", ModuleNameStr, ", ",
+ ClassNameStr, ArityStr, ")"], Str).
+
+opt_debug__dump_rtti_type_class_instance_name(TCName, TCTypes, Str) :-
+ opt_debug__dump_rtti_type_class_name(TCName, TCNameSTr),
+ EncodedTCTypes = list__map(rtti__encode_tc_instance_type, TCTypes),
+ string__append_list(EncodedTCTypes, TypesStr),
+ string__append_list(["tc_instance(", TCNameSTr, ", ", TypesStr, ")"],
+ Str).
opt_debug__dump_layout_name(label_layout(Label, LabelVars), Str) :-
opt_debug__dump_label(Label, LabelStr),
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.417
diff -u -b -r1.417 options.m
--- compiler/options.m 25 Sep 2003 07:56:28 -0000 1.417
+++ compiler/options.m 16 Oct 2003 12:51:55 -0000
@@ -360,6 +360,14 @@
% off, then you're unlikely to be able
% to link.
; type_ctor_functors
+ % XXX temporary option: enables the generation
+ % of new style static data structures for
+ % runtime information about type classes.
+ % These are not yet used. When we add code to
+ % generate the matching dynamic data structures
+ % and switch over to use them, we won't need
+ % this option anymore.
+ ; new_type_class_rtti
% Generate line number information in the RTTI
% when debugging is enabled. For measurement
% only -- if you turn this off, then the
@@ -936,7 +944,8 @@
type_ctor_info - bool(yes),
type_ctor_layout - bool(yes),
type_ctor_functors - bool(yes),
- rtti_line_numbers - bool(yes)
+ rtti_line_numbers - bool(yes),
+ new_type_class_rtti - bool(no)
]).
option_defaults_2(code_gen_option, [
% Code Generation Options
@@ -1564,6 +1573,7 @@
long_option("type-ctor-info", type_ctor_info).
long_option("type-ctor-layout", type_ctor_layout).
long_option("type-ctor-functors", type_ctor_functors).
+long_option("new-type-class-rtti", new_type_class_rtti).
long_option("rtti-line-numbers", rtti_line_numbers).
% code generation options
Index: compiler/pseudo_type_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pseudo_type_info.m,v
retrieving revision 1.11
diff -u -b -r1.11 pseudo_type_info.m
--- compiler/pseudo_type_info.m 15 Mar 2003 03:09:08 -0000 1.11
+++ compiler/pseudo_type_info.m 16 Oct 2003 16:45:00 -0000
@@ -94,8 +94,8 @@
;
TypeCtor = QualTypeName - Arity,
unqualify_name(QualTypeName, TypeName),
- sym_name_get_module_name(QualTypeName, unqualified(""),
- TypeModule),
+ sym_name_get_module_name(QualTypeName,
+ unqualified("builtin"), TypeModule),
RttiTypeCtor = rtti_type_ctor(TypeModule, TypeName,
Arity),
pseudo_type_info__generate_pseudo_args(TypeArgs,
@@ -167,8 +167,8 @@
;
TypeCtor = QualTypeName - Arity,
unqualify_name(QualTypeName, TypeName),
- sym_name_get_module_name(QualTypeName, unqualified(""),
- TypeModule),
+ sym_name_get_module_name(QualTypeName,
+ unqualified("builtin"), TypeModule),
RttiTypeCtor = rtti_type_ctor(TypeModule, TypeName,
Arity),
pseudo_type_info__generate_plain_args(TypeArgs,
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.34
diff -u -b -r1.34 rtti.m
--- compiler/rtti.m 17 Jul 2003 14:40:23 -0000 1.34
+++ compiler/rtti.m 18 Oct 2003 18:45:36 -0000
@@ -424,6 +424,83 @@
methods :: list(rtti_proc_label)
).
+%-----------------------------------------------------------------------------%
+
+ % This type corresponds to the C type MR_TypeClassMethod.
+:- type tc_method_id
+ ---> tc_method_id(
+ tcm_name :: string,
+ tcm_arity :: int,
+ tcm_pred_or_func :: pred_or_func
+ ).
+
+ % Uniquely identifies a type class.
+:- type tc_name
+ ---> tc_name(
+ tcn_module :: module_name,
+ tcn_name :: string,
+ tcn_arity :: int
+ ).
+
+ % Values of the tc_id and tc_decl types contain the information about
+ % a type class declaration that we need to interpret other data
+ % structures related to the type class.
+ %
+ % The tc_id type corresponds to the C type MR_TypeClassId, while
+ % the tc_decl type corresponds to the C type MR_TypeClassDecl.
+ %
+ % The reason for splitting the information between two C structures
+ % is to make it easier to allow us to maintain binary compatibility
+ % even if the amount of information we want to record about type class
+ % declarations changes.
+:- type tc_id
+ ---> tc_id(
+ tc_id_name :: tc_name,
+ tc_id_type_var_names :: list(string),
+ tc_id_methods :: list(tc_method_id)
+ ).
+
+:- type tc_decl
+ ---> tc_decl(
+ tc_decl_id :: tc_id,
+ tc_decl_version_number :: int,
+ tc_decl_supers :: list(tc_constraint)
+ ).
+
+:- type tc_type == rtti_maybe_pseudo_type_info.
+
+ % This type corresponds to the C type MR_TypeClassConstraint_NStruct,
+ % where N is the length of the list in the tcc_types field.
+:- type tc_constraint
+ ---> tc_constraint(
+ tcc_class_name :: tc_name,
+ tcc_types :: list(tc_type)
+ ).
+
+ % Uniquely identifies an instance declaration, and gives information
+ % about the declaration that we need to interpret other data
+ % structures related to the type class.
+ %
+ % This type corresponds to the C type MR_Instance.
+:- type tc_instance
+ ---> tc_instance(
+ tci_type_class :: tc_name,
+ tci_types :: list(tc_type),
+ tci_num_type_vars :: int,
+ tci_constraints :: list(tc_constraint),
+ tci_methods :: list(rtti_proc_label)
+ ).
+
+ % This type corresponds to the C type MR_ClassDict.
+:- type tc_dict
+ ---> tc_dict(
+ tcd_class :: tc_name,
+ tcd_types :: list(rtti_type_info),
+ tcd_methods :: list(rtti_proc_label)
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- type prog_var_name == string.
% The rtti_proc_label type holds all the information about a procedure
@@ -490,6 +567,12 @@
% types in the instance declaration
base_typeclass_info
+ )
+ ; type_class_decl(
+ tc_decl
+ )
+ ; type_class_instance(
+ tc_instance
).
% All rtti_data data structures and all their components are identified
@@ -533,7 +616,21 @@
class_id, % specifies class name & class arity
string % encodes the names and arities of the
% types in the instance declaration
- ).
+ )
+ ; type_class_id(tc_name)
+ ; type_class_id_var_names(tc_name)
+ ; type_class_id_method_ids(tc_name)
+ ; type_class_decl(tc_name)
+ ; type_class_decl_super(tc_name, int, int)
+ % superclass ordinal, constraint arity
+ ; type_class_decl_supers(tc_name)
+ ; type_class_instance(tc_name, list(tc_type))
+ ; type_class_instance_tc_type_vector(tc_name, list(tc_type))
+ ; type_class_instance_constraint(tc_name, list(tc_type),
+ int, int)
+ % constraint ordinal, constraint arity
+ ; type_class_instance_constraints(tc_name, list(tc_type))
+ ; type_class_instance_methods(tc_name, list(tc_type)).
%-----------------------------------------------------------------------------%
%
@@ -664,6 +761,10 @@
:- pred tc_rtti_name_java_type(tc_rtti_name::in, string::out, bool::out)
is det.
+ % Given a type in a type vector in a type class instance declaration,
+ % return its string encoding for use in RTTI data structures.
+:- func rtti__encode_tc_instance_type(tc_type) = string.
+
:- implementation.
:- import_module backend_libs__name_mangle.
@@ -671,6 +772,7 @@
:- import_module check_hlds__type_util.
:- import_module hlds__hlds_data.
:- import_module parse_tree__prog_util. % for mercury_public_builtin_module
+:- import_module parse_tree__prog_out.
:- import_module int, string, require, varset.
@@ -697,6 +799,11 @@
RttiTypeCtor = pti_get_rtti_type_ctor(PseudoTypeInfo).
rtti_data_to_id(base_typeclass_info(Module, ClassId, Instance, _),
tc_rtti_id(base_typeclass_info(Module, ClassId, Instance))).
+rtti_data_to_id(type_class_decl(tc_decl(TCId, _, _)),
+ tc_rtti_id(type_class_decl(TCName))) :-
+ TCId = tc_id(TCName, _, _).
+rtti_data_to_id(type_class_instance(tc_instance(TCName, TCTypes, _, _, _)),
+ tc_rtti_id(type_class_instance(TCName, TCTypes))).
tcd_get_rtti_type_ctor(TypeCtorData) = RttiTypeCtor :-
ModuleName = TypeCtorData ^ tcr_module_name,
@@ -704,6 +811,14 @@
Arity = TypeCtorData ^ tcr_arity,
RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, Arity).
+:- func maybe_pseudo_get_rtti_type_ctor(rtti_maybe_pseudo_type_info)
+ = rtti_type_ctor.
+
+maybe_pseudo_get_rtti_type_ctor(plain(TypeInfo)) =
+ ti_get_rtti_type_ctor(TypeInfo).
+maybe_pseudo_get_rtti_type_ctor(pseudo(PseudoTypeInfo)) =
+ pti_get_rtti_type_ctor(PseudoTypeInfo).
+
:- func ti_get_rtti_type_ctor(rtti_type_info) = rtti_type_ctor.
ti_get_rtti_type_ctor(plain_arity_zero_type_info(RttiTypeCtor))
@@ -776,6 +891,17 @@
ctor_rtti_name_is_exported(type_hashcons_pointer) = no.
tc_rtti_name_is_exported(base_typeclass_info(_, _, _)) = yes.
+tc_rtti_name_is_exported(type_class_id(_)) = no.
+tc_rtti_name_is_exported(type_class_id_var_names(_)) = no.
+tc_rtti_name_is_exported(type_class_id_method_ids(_)) = no.
+tc_rtti_name_is_exported(type_class_decl(_)) = yes.
+tc_rtti_name_is_exported(type_class_decl_super(_, _, _)) = no.
+tc_rtti_name_is_exported(type_class_decl_supers(_)) = no.
+tc_rtti_name_is_exported(type_class_instance(_, _)) = yes.
+tc_rtti_name_is_exported(type_class_instance_tc_type_vector(_, _)) = no.
+tc_rtti_name_is_exported(type_class_instance_constraint(_, _, _, _)) = no.
+tc_rtti_name_is_exported(type_class_instance_constraints(_, _)) = no.
+tc_rtti_name_is_exported(type_class_instance_methods(_, _)) = no.
:- func type_info_is_exported(rtti_type_info) = bool.
@@ -928,6 +1054,136 @@
rtti__tc_name_to_string(TCRttiName, Str) :-
TCRttiName = base_typeclass_info(_ModuleName, ClassId, InstanceStr),
Str = make_base_typeclass_info_name(ClassId, InstanceStr).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_id(TCName),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__append_list([ModuleName, "__type_class_id_",
+ ClassName, "_", ArityStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_id_method_ids(TCName),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__append_list([ModuleName, "__type_class_id_method_ids_",
+ ClassName, "_", ArityStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_id_var_names(TCName),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__append_list([ModuleName, "__type_class_id_var_names_",
+ ClassName, "_", ArityStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_decl(TCName),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__append_list([ModuleName, "__type_class_decl_",
+ ClassName, "_", ArityStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_decl_supers(TCName),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__append_list([ModuleName, "__type_class_decl_supers_",
+ ClassName, "_", ArityStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_decl_super(TCName, Ordinal, _),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ string__int_to_string(Ordinal, OrdinalStr),
+ string__append_list([ModuleName, "__type_class_decl_super_",
+ ClassName, "_", ArityStr, "_", OrdinalStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_instance(TCName, TCTypes),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ TypeStrs = list__map(rtti__encode_tc_instance_type, TCTypes),
+ TypeVectorStr = string__append_list(TypeStrs),
+ string__append_list([ModuleName, "__type_class_instance_",
+ ClassName, "_", ArityStr, "_", TypeVectorStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_instance_tc_type_vector(TCName, TCTypes),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ TypeStrs = list__map(rtti__encode_tc_instance_type, TCTypes),
+ TypeVectorStr = string__append_list(TypeStrs),
+ string__append_list([ModuleName,
+ "__type_class_instance_tc_type_vector_",
+ ClassName, "_", ArityStr, "_", TypeVectorStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName =
+ type_class_instance_constraint(TCName, TCTypes, Ordinal, _),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ TypeStrs = list__map(rtti__encode_tc_instance_type, TCTypes),
+ TypeVectorStr = string__append_list(TypeStrs),
+ string__int_to_string(Ordinal, OrdinalStr),
+ string__append_list([ModuleName, "__type_class_instance_constraint_",
+ ClassName, "_", ArityStr, "_", OrdinalStr, "_", TypeVectorStr],
+ Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_instance_constraints(TCName, TCTypes),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ TypeStrs = list__map(rtti__encode_tc_instance_type, TCTypes),
+ TypeVectorStr = string__append_list(TypeStrs),
+ string__append_list([ModuleName, "__type_class_instance_constraints_",
+ ClassName, "_", ArityStr, "_", TypeVectorStr], Str).
+rtti__tc_name_to_string(TCRttiName, Str) :-
+ TCRttiName = type_class_instance_methods(TCName, TCTypes),
+ rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName,
+ ArityStr),
+ TypeStrs = list__map(rtti__encode_tc_instance_type, TCTypes),
+ TypeVectorStr = string__append_list(TypeStrs),
+ string__append_list([ModuleName, "__type_class_instance_methods_",
+ ClassName, "_", ArityStr, "_", TypeVectorStr], Str).
+
+% The encoding we use here depends on the types in instance declarations
+% being type constructors applied to vectors of distinct variables. When
+% we lift that restriction, we will have to change this scheme.
+%
+% The code here is based on the code of base_typeclass_info__type_to_string,
+% but its input is of type `maybe_pseudo_type_info', not of type `type'.
+
+rtti__encode_tc_instance_type(TCType) = Str :-
+ (
+ TCType = plain(TI),
+ (
+ TI = plain_arity_zero_type_info(RttiTypeCtor),
+ ArgTIs = []
+ ;
+ TI = plain_type_info(RttiTypeCtor, ArgTIs)
+ ;
+ TI = var_arity_type_info(VarArityId, ArgTIs),
+ RttiTypeCtor =
+ var_arity_id_to_rtti_type_ctor(VarArityId)
+ ),
+ Arity = list__length(ArgTIs)
+ % XXX We may wish to check that all arguments are variables.
+ % (possible only if Arity = 0)
+ ;
+ TCType = pseudo(PTI),
+ (
+ PTI = plain_arity_zero_pseudo_type_info(RttiTypeCtor),
+ ArgPTIs = []
+ ;
+ PTI = plain_pseudo_type_info(RttiTypeCtor, ArgPTIs)
+ ;
+ PTI = var_arity_pseudo_type_info(VarArityId, ArgPTIs),
+ RttiTypeCtor =
+ var_arity_id_to_rtti_type_ctor(VarArityId)
+ ;
+ PTI = type_var(_),
+ error("rtti__encode_tc_instance_type: type_var")
+ ),
+ Arity = list__length(ArgPTIs)
+ % XXX We may wish to check that all arguments are variables.
+ ),
+ RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, _CtorArity),
+ prog_out__sym_name_to_string(qualified(ModuleName, TypeName), "__",
+ TypeStr),
+ string__int_to_string(Arity, ArityStr),
+ % XXX This naming scheme is the same as for base_typeclass_infos.
+ % We should think about whether its uniquely invertible.
+ string__append_list([TypeStr, "__arity", ArityStr, "__"], Str).
:- pred rtti__mangle_rtti_type_ctor(rtti_type_ctor::in,
string::out, string::out, string::out) is det.
@@ -936,7 +1192,7 @@
RttiTypeCtor = rtti_type_ctor(ModuleNameSym0, TypeName0, TypeArity),
% This predicate will be invoked only at stages of compilation
% that are after everything has been module qualified. The only
- % things with an empty module name should be the builtins,
+ % things with an empty module name should be the builtins.
( ModuleNameSym0 = unqualified("") ->
mercury_public_builtin_module(ModuleNameSym)
;
@@ -946,6 +1202,15 @@
TypeName = name_mangle(TypeName0),
string__int_to_string(TypeArity, ArityStr).
+:- pred rtti__mangle_rtti_type_class_name(tc_name::in,
+ string::out, string::out, string::out) is det.
+
+rtti__mangle_rtti_type_class_name(TCName, ModuleName, ClassName, ArityStr) :-
+ TCName = tc_name(ModuleNameSym, ClassName0, Arity),
+ ModuleName = sym_name_mangle(ModuleNameSym),
+ ClassName = name_mangle(ClassName0),
+ string__int_to_string(Arity, ArityStr).
+
%-----------------------------------------------------------------------------%
:- func rtti__type_info_to_string(rtti_type_info) = string.
@@ -1259,6 +1524,21 @@
pseudo_type_info_would_incl_code_addr(PseudoTypeInfo).
tc_rtti_name_would_include_code_addr(base_typeclass_info(_, _, _)) = yes.
+tc_rtti_name_would_include_code_addr(type_class_id(_)) = no.
+tc_rtti_name_would_include_code_addr(type_class_id_var_names(_)) = no.
+tc_rtti_name_would_include_code_addr(type_class_id_method_ids(_)) = no.
+tc_rtti_name_would_include_code_addr(type_class_decl(_)) = no.
+tc_rtti_name_would_include_code_addr(type_class_decl_super(_, _, _)) = no.
+tc_rtti_name_would_include_code_addr(type_class_decl_supers(_)) = no.
+tc_rtti_name_would_include_code_addr(type_class_instance(_, _)) = no.
+tc_rtti_name_would_include_code_addr(type_class_instance_tc_type_vector(_, _))
+ = no.
+tc_rtti_name_would_include_code_addr(type_class_instance_constraint(_, _, _, _))
+ = no.
+tc_rtti_name_would_include_code_addr(type_class_instance_constraints(_, _))
+ = no.
+tc_rtti_name_would_include_code_addr(type_class_instance_methods(_, _))
+ = yes.
type_info_would_incl_code_addr(plain_arity_zero_type_info(_)) = yes.
type_info_would_incl_code_addr(plain_type_info(_, _)) = no.
@@ -1344,6 +1624,26 @@
:- pred tc_rtti_name_type(tc_rtti_name::in, string::out, bool::out) is det.
tc_rtti_name_type(base_typeclass_info(_, _, _), "BaseTypeclassInfo", yes).
+tc_rtti_name_type(type_class_id(_), "TypeClassId", no).
+tc_rtti_name_type(type_class_id_var_names(_), "ConstString", yes).
+tc_rtti_name_type(type_class_id_method_ids(_), "TypeClassMethod", yes).
+tc_rtti_name_type(type_class_decl(_), "TypeClassDeclStruct", no).
+tc_rtti_name_type(type_class_decl_supers(_), "TypeClassConstraint", yes).
+tc_rtti_name_type(type_class_decl_super(_, _, N), TypeName, no) :-
+ string__int_to_string(N, NStr),
+ string__append_list(["TypeClassConstraint_", NStr, "Struct"],
+ TypeName).
+tc_rtti_name_type(type_class_instance(_, _), "InstanceStruct", no).
+tc_rtti_name_type(type_class_instance_tc_type_vector(_, _),
+ "PseudoTypeInfo", yes).
+tc_rtti_name_type(type_class_instance_constraint(_, _, _, N), TypeName, no) :-
+ string__int_to_string(N, NStr),
+ string__append_list(["TypeClassConstraint_", NStr, "Struct"],
+ TypeName).
+tc_rtti_name_type(type_class_instance_constraints(_, _),
+ "TypeClassConstraint", yes).
+tc_rtti_name_type(type_class_instance_methods(_, _),
+ "CodePtr", yes).
:- func type_info_name_type(rtti_type_info) = string.
Index: compiler/rtti_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.38
diff -u -b -r1.38 rtti_out.m
--- compiler/rtti_out.m 14 Aug 2003 06:13:48 -0000 1.38
+++ compiler/rtti_out.m 17 Oct 2003 16:33:05 -0000
@@ -84,7 +84,8 @@
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_out.
-:- import_module int, string, list, assoc_list, map, require, std_util.
+:- import_module int, string, list, assoc_list, map.
+:- import_module counter, require, std_util.
%-----------------------------------------------------------------------------%
@@ -98,6 +99,10 @@
InstanceString, BaseTypeClassInfo), !DeclSet, !IO) :-
output_base_typeclass_info_defn(InstanceModuleName, ClassId,
InstanceString, BaseTypeClassInfo, !DeclSet, !IO).
+output_rtti_data_defn(type_class_decl(TCDecl), !DeclSet, !IO) :-
+ output_type_class_decl_defn(TCDecl, !DeclSet, !IO).
+output_rtti_data_defn(type_class_instance(InstanceDecl), !DeclSet, !IO) :-
+ output_type_class_instance_defn(InstanceDecl, !DeclSet, !IO).
%-----------------------------------------------------------------------------%
@@ -125,6 +130,276 @@
%-----------------------------------------------------------------------------%
+:- pred output_type_class_decl_defn(tc_decl::in,
+ decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
+
+output_type_class_decl_defn(TCDecl, !DeclSet, !IO) :-
+ TCDecl = tc_decl(TCId, Version, Supers),
+ TCId = tc_id(TCName, TVarNames, MethodIds),
+ TCName = tc_name(ModuleSymName, ClassName, Arity),
+
+ TCIdVarNamesRttiName = type_class_id_var_names(TCName),
+ TCIdVarNamesRttiId = tc_rtti_id(TCIdVarNamesRttiName),
+ TCIdMethodIdsRttiName = type_class_id_method_ids(TCName),
+ TCIdMethodIdsRttiId = tc_rtti_id(TCIdMethodIdsRttiName),
+ TCIdRttiName = type_class_id(TCName),
+ TCIdRttiId = tc_rtti_id(TCIdRttiName),
+ TCDeclSupersRttiName = type_class_decl_supers(TCName),
+ TCDeclSupersRttiId = tc_rtti_id(TCDeclSupersRttiName),
+ TCDeclRttiName = type_class_decl(TCName),
+ TCDeclRttiId = tc_rtti_id(TCDeclRttiName),
+
+ (
+ TVarNames = []
+ ;
+ TVarNames = [_ | _],
+ output_generic_rtti_data_defn_start(TCIdVarNamesRttiId,
+ !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ list__foldl(output_type_class_id_tvar_name, TVarNames, !IO),
+ io__write_string("};\n", !IO)
+ ),
+
+ (
+ MethodIds = []
+ ;
+ MethodIds = [_ | _],
+ output_generic_rtti_data_defn_start(TCIdMethodIdsRttiId,
+ !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ list__foldl(output_type_class_id_method_id, MethodIds, !IO),
+ io__write_string("};\n", !IO)
+ ),
+
+ list__length(TVarNames, NumTVarNames),
+ list__length(MethodIds, NumMethodIds),
+ output_generic_rtti_data_defn_start(TCIdRttiId, !DeclSet, !IO),
+ io__write_string(" = {\n\t""", !IO),
+ prog_out__sym_name_to_string(ModuleSymName, ModuleName),
+ c_util__output_quoted_string(ModuleName, !IO),
+ io__write_string(""",\n\t""", !IO),
+ c_util__output_quoted_string(ClassName, !IO),
+ io__write_string(""",\n\t", !IO),
+ io__write_int(Arity, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(NumTVarNames, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(NumMethodIds, !IO),
+ io__write_string(",\n\t", !IO),
+ (
+ TVarNames = [],
+ io__write_string("NULL", !IO)
+ ;
+ TVarNames = [_ | _],
+ output_rtti_id(TCIdVarNamesRttiId, !IO)
+ ),
+ io__write_string(",\n\t", !IO),
+ (
+ MethodIds = [],
+ io__write_string("NULL", !IO)
+ ;
+ MethodIds = [_ | _],
+ output_rtti_id(TCIdMethodIdsRttiId, !IO)
+ ),
+ io__write_string("\n};\n", !IO),
+
+ (
+ Supers = []
+ ;
+ Supers = [_ | _],
+ list__map_foldl3(output_type_class_constraint(
+ make_tc_decl_super_id(TCName)), Supers, SuperIds,
+ counter__init(1), _, !DeclSet, !IO),
+ output_generic_rtti_data_defn_start(TCDeclSupersRttiId,
+ !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ output_cast_addr_of_rtti_ids("(MR_TypeClassConstraint) ",
+ SuperIds, !IO),
+ io__write_string("};\n", !IO)
+ ),
+
+ list__length(Supers, NumSupers),
+ output_generic_rtti_data_defn_start(TCDeclRttiId, !DeclSet, !IO),
+ io__write_string(" = {\n\t&", !IO),
+ output_rtti_id(TCIdRttiId, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(Version, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(NumSupers, !IO),
+ io__write_string(",\n\t", !IO),
+ (
+ Supers = [],
+ io__write_string("NULL", !IO)
+ ;
+ Supers = [_ | _],
+ output_rtti_id(TCDeclSupersRttiId, !IO)
+ ),
+ io__write_string("\n};\n", !IO).
+
+:- pred output_type_class_id_tvar_name(string::in,
+ io__state::di, io__state::uo) is det.
+
+output_type_class_id_tvar_name(TVarName, !IO) :-
+ io__write_string("\t""", !IO),
+ c_util__output_quoted_string(TVarName, !IO),
+ io__write_string(""",\n", !IO).
+
+:- pred output_type_class_id_method_id(tc_method_id::in,
+ io__state::di, io__state::uo) is det.
+
+output_type_class_id_method_id(MethodId, !IO) :-
+ MethodId = tc_method_id(MethodName, MethodArity, PredOrFunc),
+ io__write_string("\t{ """, !IO),
+ c_util__output_quoted_string(MethodName, !IO),
+ io__write_string(""", ", !IO),
+ io__write_int(MethodArity, !IO),
+ io__write_string(", ", !IO),
+ output_pred_or_func(PredOrFunc, !IO),
+ io__write_string(" },\n", !IO).
+
+:- pred output_pred_or_func(pred_or_func::in,
+ io__state::di, io__state::uo) is det.
+
+output_pred_or_func(PredOrFunc, !IO) :-
+ (
+ PredOrFunc = predicate,
+ io__write_string("MR_PREDICATE", !IO)
+ ;
+ PredOrFunc = function,
+ io__write_string("MR_FUNCTION", !IO)
+ ).
+
+:- pred make_tc_decl_super_id(tc_name::in, int::in, int::in, rtti_id::out)
+ is det.
+
+make_tc_decl_super_id(TCName, Ordinal, NumTypes, RttiId) :-
+ RttiId = tc_rtti_id(type_class_decl_super(TCName, Ordinal, NumTypes)).
+
+%-----------------------------------------------------------------------------%
+
+:- pred output_type_class_instance_defn(tc_instance::in,
+ decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
+
+output_type_class_instance_defn(Instance, !DeclSet, !IO) :-
+ Instance = tc_instance(TCName, TCTypes, NumTypeVars, Constraints,
+ MethodProcLabels),
+ list__foldl2(output_maybe_pseudo_type_info_defn, TCTypes,
+ !DeclSet, !IO),
+ TCTypeRttiDatas = list__map(maybe_pseudo_type_info_to_rtti_data,
+ TCTypes),
+ TCInstanceTypesRttiId = tc_rtti_id(
+ type_class_instance_tc_type_vector(TCName, TCTypes)),
+ output_generic_rtti_data_defn_start(TCInstanceTypesRttiId,
+ !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ output_cast_addr_of_rtti_datas("(MR_PseudoTypeInfo) ", TCTypeRttiDatas,
+ !IO),
+ io__write_string("};\n", !IO),
+ TCInstanceConstraintsRttiId = tc_rtti_id(
+ type_class_instance_constraints(TCName, TCTypes)),
+ (
+ Constraints = []
+ ;
+ Constraints = [_ | _],
+ list__map_foldl3(output_type_class_constraint(
+ make_tc_instance_constraint_id(TCName, TCTypes)),
+ Constraints, ConstraintIds, counter__init(1), _,
+ !DeclSet, !IO),
+ output_generic_rtti_data_defn_start(
+ TCInstanceConstraintsRttiId, !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ output_cast_addr_of_rtti_ids("(MR_TypeClassConstraint) ",
+ ConstraintIds, !IO),
+ io__write_string("};\n", !IO)
+ ),
+ TCInstanceMethodsRttiId = tc_rtti_id(
+ type_class_instance_methods(TCName, TCTypes)),
+ (
+ MethodProcLabels = []
+ ;
+ MethodProcLabels = [_ | _],
+ MethodCodeAddrs = list__map(make_code_addr, MethodProcLabels),
+ output_code_addrs_decls(MethodCodeAddrs, "", "", 0, _,
+ !DeclSet, !IO),
+ output_generic_rtti_data_defn_start(TCInstanceMethodsRttiId,
+ !DeclSet, !IO),
+ io__write_string(" = {\n", !IO),
+ list__foldl(output_code_addr_in_list, MethodCodeAddrs, !IO),
+ io__write_string("};\n", !IO)
+ ),
+ TCDeclRttiId = tc_rtti_id(type_class_decl(TCName)),
+ output_rtti_id_decls(TCDeclRttiId, "", "", 0, _, !DeclSet, !IO),
+ TCInstanceRttiId = tc_rtti_id(type_class_instance(TCName, TCTypes)),
+ output_generic_rtti_data_defn_start(TCInstanceRttiId, !DeclSet, !IO),
+ io__write_string(" = {\n\t&", !IO),
+ output_rtti_id(TCDeclRttiId, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(NumTypeVars, !IO),
+ io__write_string(",\n\t", !IO),
+ io__write_int(list__length(Constraints), !IO),
+ io__write_string(",\n\t", !IO),
+ output_rtti_id(TCInstanceTypesRttiId, !IO),
+ io__write_string(",\n\t", !IO),
+ (
+ Constraints = [],
+ io__write_string("NULL", !IO)
+ ;
+ Constraints = [_ | _],
+ output_rtti_id(TCInstanceConstraintsRttiId, !IO)
+ ),
+ io__write_string(",\n\t", !IO),
+ (
+ MethodProcLabels = [],
+ io__write_string("NULL", !IO)
+ ;
+ MethodProcLabels = [_ | _],
+ io__write_string("&", !IO),
+ output_rtti_id(TCInstanceMethodsRttiId, !IO)
+ ),
+ io__write_string("\n};\n", !IO).
+
+:- pred make_tc_instance_constraint_id(tc_name::in, list(tc_type)::in,
+ int::in, int::in, rtti_id::out) is det.
+
+make_tc_instance_constraint_id(TCName, TCTypes, Ordinal, NumTypes, RttiId) :-
+ RttiId = tc_rtti_id(type_class_instance_constraint(TCName, TCTypes,
+ Ordinal, NumTypes)).
+
+:- pred output_code_addr_in_list(code_addr::in,
+ io__state::di, io__state::uo) is det.
+
+output_code_addr_in_list(CodeAddr, !IO) :-
+ io__write_string("\t", !IO),
+ output_static_code_addr(CodeAddr, !IO),
+ io__write_string(",\n", !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred output_type_class_constraint(
+ pred(int, int, rtti_id)::in(pred(in, in, out) is det),
+ tc_constraint::in, rtti_id::out, counter::in, counter::out,
+ decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
+
+output_type_class_constraint(MakeRttiId, Constraint, TCDeclSuperRttiId,
+ !Counter, !DeclSet, !IO) :-
+ Constraint = tc_constraint(TCName, Types),
+ list__length(Types, NumTypes),
+ counter__allocate(Ordinal, !Counter),
+ MakeRttiId(Ordinal, NumTypes, TCDeclSuperRttiId),
+ TCDeclRttiId = tc_rtti_id(type_class_decl(TCName)),
+ output_generic_rtti_data_decl(TCDeclRttiId, !DeclSet, !IO),
+ list__foldl2(output_maybe_pseudo_type_info_defn, Types, !DeclSet, !IO),
+ TypeRttiDatas = list__map(maybe_pseudo_type_info_to_rtti_data, Types),
+ output_generic_rtti_data_defn_start(TCDeclSuperRttiId, !DeclSet, !IO),
+ io__write_string(" = {\n\t&", !IO),
+ output_rtti_id(TCDeclRttiId, !IO),
+ io__write_string(",\n\t{\n", !IO),
+ output_cast_addr_of_rtti_datas("(MR_PseudoTypeInfo) ", TypeRttiDatas,
+ !IO),
+ io__write_string("\t}\n};\n", !IO).
+
+%-----------------------------------------------------------------------------%
+
:- pred output_maybe_pseudo_type_info_or_self_defn(
rtti_maybe_pseudo_type_info_or_self::in, decl_set::in, decl_set::out,
io__state::di, io__state::uo) is det.
@@ -162,13 +437,16 @@
:- pred do_output_type_info_defn(rtti_type_info::in,
decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
-do_output_type_info_defn(plain_arity_zero_type_info(_), !DeclSet, !IO).
+do_output_type_info_defn(TypeInfo, !DeclSet, !IO) :-
+ TypeInfo = plain_arity_zero_type_info(RttiTypeCtor),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO).
do_output_type_info_defn(TypeInfo, !DeclSet, !IO) :-
TypeInfo = plain_type_info(RttiTypeCtor, Args),
- TypeCtorRttiData = type_info(plain_arity_zero_type_info(RttiTypeCtor)),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO),
ArgRttiDatas = list__map(type_info_to_rtti_data, Args),
- output_type_ctor_and_arg_defns_and_decls(TypeCtorRttiData,
- ArgRttiDatas, !DeclSet, !IO),
+ output_type_ctor_arg_defns_and_decls(ArgRttiDatas, !DeclSet, !IO),
output_generic_rtti_data_defn_start(
ctor_rtti_id(RttiTypeCtor, type_info(TypeInfo)),
!DeclSet, !IO),
@@ -180,11 +458,10 @@
do_output_type_info_defn(TypeInfo, !DeclSet, !IO) :-
TypeInfo = var_arity_type_info(RttiVarArityId, Args),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(RttiVarArityId),
- TypeCtorRttiData = type_info(
- plain_arity_zero_type_info(RttiTypeCtor)),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO),
ArgRttiDatas = list__map(type_info_to_rtti_data, Args),
- output_type_ctor_and_arg_defns_and_decls(TypeCtorRttiData,
- ArgRttiDatas, !DeclSet, !IO),
+ output_type_ctor_arg_defns_and_decls(ArgRttiDatas, !DeclSet, !IO),
output_generic_rtti_data_defn_start(
ctor_rtti_id(RttiTypeCtor, type_info(TypeInfo)),
!DeclSet, !IO),
@@ -219,15 +496,16 @@
:- pred do_output_pseudo_type_info_defn(rtti_pseudo_type_info::in,
decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
-do_output_pseudo_type_info_defn(plain_arity_zero_pseudo_type_info(_),
- !DeclSet, !IO).
+do_output_pseudo_type_info_defn(PseudoTypeInfo, !DeclSet, !IO) :-
+ PseudoTypeInfo = plain_arity_zero_pseudo_type_info(RttiTypeCtor),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO).
do_output_pseudo_type_info_defn(PseudoTypeInfo, !DeclSet, !IO) :-
PseudoTypeInfo = plain_pseudo_type_info(RttiTypeCtor, Args),
- TypeCtorRttiData = pseudo_type_info(
- plain_arity_zero_pseudo_type_info(RttiTypeCtor)),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO),
ArgRttiDatas = list__map(maybe_pseudo_type_info_to_rtti_data, Args),
- output_type_ctor_and_arg_defns_and_decls(TypeCtorRttiData,
- ArgRttiDatas, !DeclSet, !IO),
+ output_type_ctor_arg_defns_and_decls(ArgRttiDatas, !DeclSet, !IO),
output_generic_rtti_data_defn_start(
ctor_rtti_id(RttiTypeCtor, pseudo_type_info(PseudoTypeInfo)),
!DeclSet, !IO),
@@ -240,11 +518,10 @@
do_output_pseudo_type_info_defn(PseudoTypeInfo, !DeclSet, !IO) :-
PseudoTypeInfo = var_arity_pseudo_type_info(RttiVarArityId, Args),
RttiTypeCtor = var_arity_id_to_rtti_type_ctor(RttiVarArityId),
- TypeCtorRttiData = pseudo_type_info(
- plain_arity_zero_pseudo_type_info(RttiTypeCtor)),
+ TypeCtorRttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ output_rtti_id_decls(TypeCtorRttiId, "", "", 0, _, !DeclSet, !IO),
ArgRttiDatas = list__map(maybe_pseudo_type_info_to_rtti_data, Args),
- output_type_ctor_and_arg_defns_and_decls(TypeCtorRttiData,
- ArgRttiDatas, !DeclSet, !IO),
+ output_type_ctor_arg_defns_and_decls(ArgRttiDatas, !DeclSet, !IO),
output_generic_rtti_data_defn_start(
ctor_rtti_id(RttiTypeCtor, pseudo_type_info(PseudoTypeInfo)),
!DeclSet, !IO),
@@ -259,14 +536,10 @@
io__write_string("}};\n", !IO).
do_output_pseudo_type_info_defn(type_var(_), !DeclSet, !IO).
-:- pred output_type_ctor_and_arg_defns_and_decls(rtti_data::in,
- list(rtti_data)::in, decl_set::in, decl_set::out,
- io__state::di, io__state::uo) is det.
+:- pred output_type_ctor_arg_defns_and_decls(list(rtti_data)::in,
+ decl_set::in, decl_set::out, io__state::di, io__state::uo) is det.
-output_type_ctor_and_arg_defns_and_decls(TypeCtorRttiData, ArgRttiDatas,
- !DeclSet, !IO) :-
- output_rtti_data_decls(TypeCtorRttiData, "", "", 0, _,
- !DeclSet, !IO),
+output_type_ctor_arg_defns_and_decls(ArgRttiDatas, !DeclSet, !IO) :-
% We must output the definitions of the rtti_datas of the argument
% typeinfos and/or pseudo-typeinfos, because they may contain other
% typeinfos and/or pseudo-typeinfos nested within them. However,
@@ -993,8 +1266,9 @@
output_rtti_type_decl(RttiId, !IO) :-
(
- rtti_type_template_arity(RttiId, Arity),
- Arity > max_always_declared_arity
+ RttiId = ctor_rtti_id(_, RttiName),
+ rtti_type_ctor_template_arity(RttiName, Arity),
+ Arity > max_always_declared_arity_type_ctor
->
Template =
"#ifndef MR_TYPE_INFO_LIKE_STRUCTS_FOR_ARITY_%d_GUARD
@@ -1004,13 +1278,25 @@
",
io__format(Template, [i(Arity), i(Arity), i(Arity)], !IO)
;
+ RttiId = tc_rtti_id(TCRttiName),
+ rtti_type_class_constraint_template_arity(TCRttiName, Arity),
+ Arity > max_always_declared_arity_type_class_constraint
+ ->
+ Template =
+"#ifndef MR_TYPECLASS_CONSTRAINT_STRUCT_%d_GUARD
+#define MR_TYPECLASS_CONSTRAINT_STRUCT_%d_GUARD
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_%d, %d);
+#endif
+",
+ io__format(Template, [i(Arity), i(Arity), i(Arity), i(Arity)],
+ !IO)
+ ;
true
).
-:- pred rtti_type_template_arity(rtti_id::in, int::out) is semidet.
+:- pred rtti_type_ctor_template_arity(ctor_rtti_name::in, int::out) is semidet.
-rtti_type_template_arity(RttiId, NumArgTypes) :-
- RttiId = ctor_rtti_id(_, RttiName),
+rtti_type_ctor_template_arity(RttiName, NumArgTypes) :-
RttiName = type_info(TypeInfo),
(
TypeInfo = plain_type_info(_, ArgTypes)
@@ -1018,8 +1304,7 @@
TypeInfo = var_arity_type_info(_, ArgTypes)
),
NumArgTypes = list__length(ArgTypes).
-rtti_type_template_arity(RttiId, NumArgTypes) :-
- RttiId = ctor_rtti_id(_, RttiName),
+rtti_type_ctor_template_arity(RttiName, NumArgTypes) :-
RttiName = pseudo_type_info(PseudoTypeInfo),
(
PseudoTypeInfo = plain_pseudo_type_info(_, ArgTypes)
@@ -1028,9 +1313,21 @@
),
NumArgTypes = list__length(ArgTypes).
-:- func max_always_declared_arity = int.
+:- func max_always_declared_arity_type_ctor = int.
+
+max_always_declared_arity_type_ctor = 20.
+
+:- pred rtti_type_class_constraint_template_arity(tc_rtti_name::in, int::out)
+ is semidet.
-max_always_declared_arity = 20.
+rtti_type_class_constraint_template_arity(TCRttiName, Arity) :-
+ TCRttiName = type_class_decl_super(_, _, Arity).
+rtti_type_class_constraint_template_arity(TCRttiName, Arity) :-
+ TCRttiName = type_class_instance_constraint(_, _, _, Arity).
+
+:- func max_always_declared_arity_type_class_constraint = int.
+
+max_always_declared_arity_type_class_constraint = 5.
%-----------------------------------------------------------------------------%
@@ -1073,6 +1370,15 @@
io__write_string("#endif /* MR_STATIC_CODE_ADDRESSES */\n",
!IO)
;
+ Data = type_class_instance(_)
+ ->
+ io__write_string("#ifndef MR_STATIC_CODE_ADDRESSES\n", !IO),
+ io__write_string("#error ""type_class_instance " ++
+ "not yet supported without static code addresses""\n",
+ !IO),
+ io__write_string("#endif /* MR_STATIC_CODE_ADDRESSES */\n",
+ !IO)
+ ;
true
).
@@ -1082,39 +1388,68 @@
->
RttiTypeCtor = tcd_get_rtti_type_ctor(TypeCtorData),
RttiId = ctor_rtti_id(RttiTypeCtor, type_ctor_info),
+ io__write_string("\t{\n\t", !IO),
(
SplitFiles = yes,
- io__write_string("\t{\n\t", !IO),
output_rtti_id_storage_type_name(RttiId, no, !IO),
- io__write_string(
- ";\n\tMR_register_type_ctor_info(\n\t\t&",
- !IO),
+ io__write_string(";\n", !IO)
+ ;
+ SplitFiles = no
+ ),
+ io__write_string("\tMR_register_type_ctor_info(\n\t\t&", !IO),
output_rtti_id(RttiId, !IO),
io__write_string(");\n\t}\n", !IO)
;
- SplitFiles = no,
- io__write_string(
- "\tMR_register_type_ctor_info(\n\t\t&", !IO),
+ Data = type_class_decl(TCDecl)
+ ->
+ TCDecl = tc_decl(TCId, _, _),
+ TCId = tc_id(TCName, _, _),
+ RttiId = tc_rtti_id(type_class_decl(TCName)),
+ io__write_string("\t{\n\t", !IO),
+ (
+ SplitFiles = yes,
+ output_rtti_id_storage_type_name(RttiId, no, !IO),
+ io__write_string(";\n", !IO)
+ ;
+ SplitFiles = no
+ ),
+ io__write_string("\tMR_register_type_class_decl(\n\t\t&", !IO),
output_rtti_id(RttiId, !IO),
- io__write_string(");\n", !IO)
- )
+ io__write_string(");\n\t}\n", !IO)
;
- Data = base_typeclass_info(_InstanceModuleName, _ClassId,
- _InstanceString, _BaseTypeClassInfo)
+ Data = type_class_instance(TCInstance)
->
- % XXX Registering base_typeclass_infos by themselves is not
- % enough. A base_typeclass_info doesn't say which types it
- % declares to be members of which typeclass, and for now
- % we don't even have any data structures in the runtime system
- % to describe such membership information.
- %
- % io__write_string(
- % "\tMR_register_base_typeclass_info(\n\t\t&"),
- % output_base_typeclass_info_storage_type_name(
- % InstanceModuleName, ClassId, InstanceString, no),
- % io__write_string(");\n")
- true
+ TCInstance = tc_instance(TCName, TCTypes, _, _, _),
+ RttiId = tc_rtti_id(type_class_instance(TCName, TCTypes)),
+ io__write_string("\t{\n\t", !IO),
+ (
+ SplitFiles = yes,
+ output_rtti_id_storage_type_name(RttiId, no, !IO),
+ io__write_string(";\n", !IO)
+ ;
+ SplitFiles = no
+ ),
+ io__write_string("\tMR_register_type_class_instance(\n\t\t&",
+ !IO),
+ output_rtti_id(RttiId, !IO),
+ io__write_string(");\n\t}\n", !IO)
;
+% Data = base_typeclass_info(_InstanceModuleName, _ClassId,
+% _InstanceString, _BaseTypeClassInfo)
+% ->
+% % XXX Registering base_typeclass_infos by themselves is not
+% % enough. A base_typeclass_info doesn't say which types it
+% % declares to be members of which typeclass, and for now
+% % we don't even have any data structures in the runtime system
+% % to describe such membership information.
+% %
+% % io__write_string(
+% % "\tMR_register_base_typeclass_info(\n\t\t&"),
+% % output_base_typeclass_info_storage_type_name(
+% % InstanceModuleName, ClassId, InstanceString, no),
+% % io__write_string(");\n")
+% true
+% ;
true
).
@@ -1174,6 +1509,19 @@
output_data_addr_decls(rtti_addr(RttiId), FirstIndent, LaterIndent,
N0, N1, !DeclSet, !IO).
+:- pred output_cast_addr_of_rtti_ids(string::in, list(rtti_id)::in,
+ io__state::di, io__state::uo) is det.
+
+output_cast_addr_of_rtti_ids(_, [], !IO) :-
+ io__write_string(
+ "\t/* Dummy entry, since ISO C forbids zero-sized arrays */\n", !IO),
+ io__write_string("\t0\n", !IO).
+output_cast_addr_of_rtti_ids(Cast, [TCRttiName | TCRttiNames], !IO) :-
+ io__write_string("\t", !IO),
+ io__write_list([TCRttiName | TCRttiNames], ",\n\t",
+ output_cast_addr_of_rtti_id(Cast), !IO),
+ io__write_string("\n", !IO).
+
:- pred output_addr_of_ctor_rtti_names(rtti_type_ctor::in,
list(ctor_rtti_name)::in, io__state::di, io__state::uo) is det.
@@ -1219,6 +1567,13 @@
rtti_data_to_id(RttiData, RttiId),
output_addr_of_rtti_id(RttiId, !IO)
).
+
+:- pred output_cast_addr_of_rtti_id(string::in, rtti_id::in,
+ io__state::di, io__state::uo) is det.
+
+output_cast_addr_of_rtti_id(Cast, RttiId, !IO) :-
+ io__write_string(Cast, !IO),
+ output_addr_of_rtti_id(RttiId, !IO).
:- pred output_addr_of_rtti_id(rtti_id::in, io__state::di, io__state::uo)
is det.
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.41
diff -u -b -r1.41 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 25 Sep 2003 07:56:30 -0000 1.41
+++ compiler/rtti_to_mlds.m 16 Oct 2003 04:11:14 -0000
@@ -150,6 +150,7 @@
% occurring in the given module.
:- pred gen_init_rtti_data_defn(rtti_data::in, module_info::in,
mlds__initializer::out, list(mlds__defn)::out) is det.
+
gen_init_rtti_data_defn(RttiData, ModuleInfo, Init, ExtraDefns) :-
RttiData = base_typeclass_info(_InstanceModule, _ClassId, _InstanceStr,
BaseTypeClassInfo),
@@ -166,6 +167,12 @@
gen_init_boxed_int(N5)
| MethodInitializers
]).
+gen_init_rtti_data_defn(RttiData, _ModuleInfo, _Init, _SubDefns) :-
+ RttiData = type_class_decl(_),
+ error("gen_init_rtti_data_defn: type_class_decl NYI").
+gen_init_rtti_data_defn(RttiData, _ModuleInfo, _Init, _SubDefns) :-
+ RttiData = type_class_instance(_),
+ error("gen_init_rtti_data_defn: type_class_instance NYI").
gen_init_rtti_data_defn(RttiData, ModuleInfo, Init, SubDefns) :-
RttiData = type_info(TypeInfo),
gen_type_info_defn(ModuleInfo, TypeInfo, Init, SubDefns).
@@ -961,11 +968,54 @@
:- func gen_tc_rtti_name(module_name, tc_rtti_name) = mlds__rval.
gen_tc_rtti_name(_ThisModuleName, TCRttiName) = Rval :-
+ (
TCRttiName = base_typeclass_info(InstanceModuleName, _, _),
- MLDS_ModuleName = mercury_module_name_to_mlds(InstanceModuleName),
+ MLDS_ModuleName =
+ mercury_module_name_to_mlds(InstanceModuleName)
+ ;
+ TCRttiName = type_class_id(TCName),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_decl(TCName),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_decl_super(TCName, _, _),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_decl_supers(TCName),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_id_var_names(TCName),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_id_method_ids(TCName),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_instance(TCName, _Types),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_instance_tc_type_vector(TCName, _Types),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_instance_constraint(TCName, _Types,
+ _, _),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_instance_constraints(TCName, _Types),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ;
+ TCRttiName = type_class_instance_methods(TCName, _Types),
+ MLDS_ModuleName = mlds_module_name_from_tc_name(TCName)
+ ),
MLDS_DataName = rtti(tc_rtti_id(TCRttiName)),
DataAddr = data_addr(MLDS_ModuleName, MLDS_DataName),
Rval = const(data_addr_const(DataAddr)).
+
+:- func mlds_module_name_from_tc_name(tc_name) = mlds_module_name.
+
+mlds_module_name_from_tc_name(TCName) = MLDS_ModuleName :-
+ TCName = tc_name(ModuleName, _ClassName, _Arity),
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName).
%-----------------------------------------------------------------------------%
Index: compiler/type_class_info.m
===================================================================
RCS file: compiler/type_class_info.m
diff -N compiler/type_class_info.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/type_class_info.m 16 Oct 2003 12:39:58 -0000
@@ -0,0 +1,207 @@
+%---------------------------------------------------------------------------%
+% Copyright (C) 2003 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%---------------------------------------------------------------------------%
+%
+% This module generates the RTTI data for the global variables (or constants)
+% that hold the data structures representing the type class and instance
+% declarations in the current module.
+%
+% Author: zs.
+%
+%---------------------------------------------------------------------------%
+
+:- module backend_libs__type_class_info.
+
+:- interface.
+
+:- import_module backend_libs__rtti.
+:- import_module hlds__hlds_module.
+
+:- import_module list.
+
+:- pred type_class_info__generate_rtti(module_info::in, list(rtti_data)::out)
+ is det.
+
+:- implementation.
+
+:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_out.
+:- import_module hlds__hlds_pred.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_io.
+:- import_module parse_tree__prog_out.
+:- import_module backend_libs__pseudo_type_info.
+:- import_module backend_libs__base_typeclass_info.
+
+:- import_module bool, int, string, assoc_list, map.
+:- import_module std_util, require, term, varset.
+
+%---------------------------------------------------------------------------%
+
+generate_rtti(ModuleInfo, RttiDatas) :-
+ module_info_classes(ModuleInfo, ClassTable),
+ map__to_assoc_list(ClassTable, Classes),
+ list__foldl(generate_class_decl(ModuleInfo), Classes,
+ [], RttiDatas0),
+ module_info_instances(ModuleInfo, InstanceTable),
+ map__to_assoc_list(InstanceTable, Instances),
+ list__foldl(generate_instance_decls(ModuleInfo), Instances,
+ RttiDatas0, RttiDatas).
+
+%---------------------------------------------------------------------------%
+
+:- pred generate_class_decl(module_info::in,
+ pair(class_id, hlds_class_defn)::in,
+ list(rtti_data)::in, list(rtti_data)::out) is det.
+
+generate_class_decl(ModuleInfo, ClassId - ClassDefn, !RttiDatas) :-
+ ImportStatus = ClassDefn ^ class_status,
+ ( status_defined_in_this_module(ImportStatus, yes) ->
+ TCId = generate_class_id(ModuleInfo, ClassId, ClassDefn),
+ Supers = ClassDefn ^ class_supers,
+ TCSupers = list__map(generate_class_constraint, Supers),
+ TCVersion = type_class_info_rtti_version,
+ RttiData = type_class_decl(tc_decl(TCId, TCVersion, TCSupers)),
+ !:RttiDatas = [RttiData | !.RttiDatas]
+ ;
+ true
+ ).
+
+:- func generate_class_id(module_info, class_id, hlds_class_defn) = tc_id.
+
+generate_class_id(ModuleInfo, ClassId, ClassDefn) = TCId :-
+ TCName = generate_class_name(ClassId),
+ ClassVars = ClassDefn ^ class_vars,
+ ClassVarSet = ClassDefn ^ class_tvarset,
+ list__map(varset__lookup_name(ClassVarSet), ClassVars, VarNames),
+ Interface = ClassDefn ^ class_hlds_interface,
+ MethodIds = list__map(generate_method_id(ModuleInfo), Interface),
+ TCId = tc_id(TCName, VarNames, MethodIds).
+
+:- func generate_method_id(module_info, hlds_class_proc) = tc_method_id.
+
+generate_method_id(ModuleInfo, ClassProc) = MethodId :-
+ ClassProc = hlds_class_proc(PredId, _ProcId),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_name(PredInfo, MethodName),
+ pred_info_arity(PredInfo, Arity),
+ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
+ MethodId = tc_method_id(MethodName, Arity, PredOrFunc).
+
+%---------------------------------------------------------------------------%
+
+:- pred generate_instance_decls(module_info::in,
+ pair(class_id, list(hlds_instance_defn))::in,
+ list(rtti_data)::in, list(rtti_data)::out) is det.
+
+generate_instance_decls(ModuleInfo, ClassId - Instances, !RttiDatas) :-
+ list__foldl(generate_maybe_instance_decl(ModuleInfo, ClassId),
+ Instances, !RttiDatas).
+
+:- pred generate_maybe_instance_decl(module_info::in,
+ class_id::in, hlds_instance_defn::in,
+ list(rtti_data)::in, list(rtti_data)::out) is det.
+
+generate_maybe_instance_decl(ModuleInfo, ClassId, InstanceDefn, !RttiDatas) :-
+ ImportStatus = InstanceDefn ^ instance_status,
+ Body = InstanceDefn ^ instance_body,
+ (
+ Body = concrete(_),
+ % Only make the RTTI structure for the type class
+ % instance if the instance declaration originally
+ % came from _this_ module.
+ status_defined_in_this_module(ImportStatus, yes)
+ ->
+ RttiData = generate_instance_decl(ModuleInfo, ClassId,
+ InstanceDefn),
+ !:RttiDatas = [RttiData | !.RttiDatas]
+ ;
+ true
+ ).
+
+:- func generate_instance_decl(module_info, class_id, hlds_instance_defn)
+ = rtti_data.
+
+generate_instance_decl(ModuleInfo, ClassId, Instance) = RttiData :-
+ TCName = generate_class_name(ClassId),
+ InstanceTypes = Instance ^ instance_types,
+ InstanceTCTypes = list__map(generate_tc_type, InstanceTypes),
+ TVarSet = Instance ^ instance_tvarset,
+ varset__vars(TVarSet, TVars),
+ TVarNums = list__map(term__var_to_int, TVars),
+ TVarLength = list__length(TVarNums),
+ ( list__last(TVarNums, LastTVarNum) ->
+ require(unify(TVarLength, LastTVarNum),
+ "generate_instance_decl: tvar num mismatch"),
+ NumTypeVars = TVarLength
+ ;
+ NumTypeVars = 0
+ ),
+ Constraints = Instance ^ instance_constraints,
+ TCConstraints = list__map(generate_class_constraint, Constraints),
+ MaybeInterface = Instance ^ instance_hlds_interface,
+ (
+ MaybeInterface = yes(Interface),
+ MethodProcLabels = list__map(
+ generate_method_proc_label(ModuleInfo), Interface)
+ ;
+ MaybeInterface = no,
+ error("generate_instance_decl: no interface")
+ ),
+ TCInstance = tc_instance(TCName, InstanceTCTypes, NumTypeVars,
+ TCConstraints, MethodProcLabels),
+ RttiData = type_class_instance(TCInstance).
+
+:- func generate_method_proc_label(module_info, hlds_class_proc) =
+ rtti_proc_label.
+
+generate_method_proc_label(ModuleInfo, hlds_class_proc(PredId, ProcId)) =
+ make_rtti_proc_label(ModuleInfo, PredId, ProcId).
+
+%---------------------------------------------------------------------------%
+
+:- func generate_class_name(class_id) = tc_name.
+
+generate_class_name(class_id(SymName, Arity)) = TCName :-
+ (
+ SymName = qualified(ModuleName, ClassName)
+ ;
+ SymName = unqualified(_),
+ error("generate_class_name: unqualified sym_name")
+ ),
+ TCName = tc_name(ModuleName, ClassName, Arity).
+
+:- func generate_class_constraint(class_constraint) = tc_constraint.
+
+generate_class_constraint(constraint(ClassName, Types)) = TCConstr :-
+ Arity = list__length(Types),
+ ClassId = class_id(ClassName, Arity),
+ TCClassName = generate_class_name(ClassId),
+ ClassTypes = list__map(generate_tc_type, Types),
+ TCConstr = tc_constraint(TCClassName, ClassTypes).
+
+:- func generate_tc_type(type) = tc_type.
+
+generate_tc_type(Type) = TCType :-
+ pseudo_type_info__construct_maybe_pseudo_type_info(Type, -1, [],
+ TCType).
+
+%---------------------------------------------------------------------------%
+
+% The version number of the runtime data structures describing type class
+% information, most of which (currently, all of which) is generated in this
+% module.
+%
+% The value returned by this function should be kept in sync with
+% MR_TYPECLASS_VERSION in runtime/mercury_typeclass_info.h.
+
+:- func type_class_info_rtti_version = int.
+
+type_class_info_rtti_version = 0.
+
+%---------------------------------------------------------------------------%
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/mdb_categories
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/mdb_categories,v
retrieving revision 1.16
diff -u -b -r1.16 mdb_categories
--- doc/mdb_categories 15 Nov 2002 04:50:33 -0000 1.16
+++ doc/mdb_categories 19 Oct 2003 14:53:35 -0000
@@ -68,7 +68,8 @@
developer - Commands that are intended to be of use only to developers
of the Mercury implementation. The developer commands are
`nondet_stack', `stack_regs', `all_regs', `proc_stats',
- `label_stats', `print_optionals', `unhide_events', `dd_dd'
- and `table'.
+ `label_stats', `print_optionals', `unhide_events', `dd_dd',
+ `table', `type_ctor', `class_decl', `all_type_ctors' and
+ `all_class_decls'.
end
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.375
diff -u -b -r1.375 user_guide.texi
--- doc/user_guide.texi 25 Sep 2003 07:56:44 -0000 1.375
+++ doc/user_guide.texi 18 Oct 2003 06:14:40 -0000
@@ -3311,6 +3311,64 @@
If the user specifies one or more integers on the command line,
the output is restricted to the entries in the call table in which
the @var{n}th argument is equal to the @var{n}th number on the command line.
+ at sp 1
+ at item type_ctor [-fr] @var{modulename} @var{typectorname} @var{arity}
+ at kindex type_ctor (mdb command)
+Tests whether there is a type constructor defined in the given module,
+with the given name, and with the given arity.
+If there isn't, it prints a message to that effect.
+If there is, it echoes the identity of the type constructor.
+ at sp 1
+If the option @samp{-r} or @samp{--print-rep} option is given,
+it also prints the name of the type representation scheme
+used by the type constructor
+(known as its `type_ctor_rep' in the implementation).
+ at sp 1
+If the option @samp{-f} or @samp{--print-functors} option is given,
+it also prints the names and arities
+of function symbols defined by type constructor.
+ at sp 1
+ at item all_type_ctors [-fr] [@var{modulename}]
+ at kindex all_type_ctors (mdb command)
+If the user specifies a module name,
+lists all the type constructors defined in the given module.
+If the user doesn't specify a module name,
+lists all the type constructors defined in the whole program.
+ at sp 1
+If the option @samp{-r} or @samp{--print-rep} option is given,
+it also prints the name of the type representation scheme
+of each type constructor
+(known as its `type_ctor_rep' in the implementation).
+ at sp 1
+If the option @samp{-f} or @samp{--print-functors} option is given,
+it also prints the names and arities
+of function symbols defined by each type constructor.
+ at sp 1
+ at item class_decl [-im] @var{modulename} @var{typeclassname} @var{arity}
+ at kindex class_decl (mdb command)
+Tests whether there is a type class defined in the given module,
+with the given name, and with the given arity.
+If there isn't, it prints a message to that effect.
+If there is, it echoes the identity of the type class.
+ at sp 1
+If the option @samp{-m} or @samp{--print-methods} option is given,
+it also lists all the methods of the type class.
+ at sp 1
+If the option @samp{-i} or @samp{--print-instance} option is given,
+it also lists all the instances of the type class.
+ at sp 1
+ at item all_class_decls [-im] [@var{modulename}]
+ at kindex all_class_decls (mdb command)
+If the user specifies a module name,
+lists all the type classes defined in the given module.
+If the user doesn't specify a module name,
+lists all the type classes defined in the whole program.
+ at sp 1
+If the option @samp{-m} or @samp{--print-methods} option is given,
+it also lists all the methods of each type class.
+ at sp 1
+If the option @samp{-i} or @samp{--print-instance} option is given,
+it also lists all the instances of each type class.
@end table
@node Declarative debugging
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/list.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/list.m,v
retrieving revision 1.114
diff -u -b -r1.114 list.m
--- library/list.m 1 Sep 2003 01:17:10 -0000 1.114
+++ library/list.m 12 Oct 2003 16:14:26 -0000
@@ -603,6 +603,18 @@
:- mode list__map_foldl2(pred(in, out, in, out, in, out) is nondet,
in, out, in, out, in, out) is nondet.
+ % Same as list__map_foldl, but with three accumulators.
+:- pred list__map_foldl3(pred(X, Y, A, A, B, B, C, C), list(X), list(Y),
+ A, A, B, B, C, C).
+:- mode list__map_foldl3(pred(in, out, in, out, in, out, di, uo) is det,
+ in, out, in, out, in, out, di, uo) is det.
+:- mode list__map_foldl3(pred(in, out, in, out, in, out, in, out) is det,
+ in, out, in, out, in, out, in, out) is det.
+:- mode list__map_foldl3(pred(in, out, in, out, in, out, in, out) is semidet,
+ in, out, in, out, in, out, in, out) is semidet.
+:- mode list__map_foldl3(pred(in, out, in, out, in, out, in, out) is nondet,
+ in, out, in, out, in, out, in, out) is nondet.
+
% list__filter(Pred, List, TrueList) takes a closure with one
% input argument and for each member of List `X', calls the closure.
% Iff call(Pred, X) is true, then X is included in TrueList.
@@ -1353,10 +1365,15 @@
call(P, H0, H1, H2),
list__map2_foldl(P, T0, T1, T2).
-list__map_foldl2(_, [], [], A, A) --> [].
-list__map_foldl2(P, [H0 | T0], [H | T], A0, A) -->
- call(P, H0, H, A0, A1),
- list__map_foldl2(P, T0, T, A1, A).
+list__map_foldl2(_, [], [], !A, !B).
+list__map_foldl2(P, [H0 | T0], [H | T], !A, !B) :-
+ call(P, H0, H, !A, !B),
+ list__map_foldl2(P, T0, T, !A, !B).
+
+list__map_foldl3(_, [], [], !A, !B, !C).
+list__map_foldl3(P, [H0 | T0], [H | T], !A, !B, !C) :-
+ call(P, H0, H, !A, !B, !C),
+ list__map_foldl3(P, T0, T, !A, !B, !C).
list__foldr(_, [], Acc, Acc).
list__foldr(P, [H | T], Acc0, Acc) :-
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/Mmakefile,v
retrieving revision 1.103
diff -u -b -r1.103 Mmakefile
--- runtime/Mmakefile 13 Jul 2003 08:19:18 -0000 1.103
+++ runtime/Mmakefile 16 Oct 2003 13:43:02 -0000
@@ -77,6 +77,7 @@
mercury_type_desc.h \
mercury_type_info.h \
mercury_type_tables.h \
+ mercury_typeclass_info.h \
mercury_types.h \
mercury_wrapper.h \
$(LIB_DLL_H)
Index: runtime/mercury_imp.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_imp.h,v
retrieving revision 1.20
diff -u -b -r1.20 mercury_imp.h
--- runtime/mercury_imp.h 18 Mar 2003 16:38:10 -0000 1.20
+++ runtime/mercury_imp.h 16 Oct 2003 04:29:26 -0000
@@ -71,6 +71,7 @@
#include "mercury_context.h"
#include "mercury_thread.h"
#include "mercury_type_info.h"
+#include "mercury_typeclass_info.h"
#include "mercury_type_tables.h"
#ifdef MR_USE_TRAIL
#include "mercury_trail.h"
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.56
diff -u -b -r1.56 mercury_type_info.c
--- runtime/mercury_type_info.c 21 Mar 2003 08:00:30 -0000 1.56
+++ runtime/mercury_type_info.c 17 Oct 2003 15:39:43 -0000
@@ -19,6 +19,10 @@
#include "mercury_heap.h" /* for incr_saved_hp() */
#include "mercury_builtin_types.h" /* for void/0's type_ctor_info */
+MR_ConstString MR_ctor_rep_name[] = {
+ MR_CTOR_REP_NAMES
+};
+
/*---------------------------------------------------------------------------*/
static MR_TypeInfo
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.106
diff -u -b -r1.106 mercury_type_info.h
--- runtime/mercury_type_info.h 5 Aug 2003 08:26:53 -0000 1.106
+++ runtime/mercury_type_info.h 17 Oct 2003 16:57:49 -0000
@@ -315,8 +315,7 @@
((MR_TypeInfoParams) &(type_info)->MR_ti_type_ctor_info)
#define MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info) \
- ((MR_TypeInfoParams) \
- &(type_info)->MR_ti_var_arity_arity)
+ ((MR_TypeInfoParams) &(type_info)->MR_ti_var_arity_arity)
/*
** Macros for creating type_infos.
@@ -630,6 +629,8 @@
"REFERENCE", \
"STABLE_C_POINTER", \
"UNKNOWN"
+
+extern MR_ConstString MR_ctor_rep_name[];
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_type_tables.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_tables.c,v
retrieving revision 1.7
diff -u -b -r1.7 mercury_type_tables.c
--- runtime/mercury_type_tables.c 18 Feb 2002 07:01:23 -0000 1.7
+++ runtime/mercury_type_tables.c 18 Oct 2003 10:19:50 -0000
@@ -5,8 +5,8 @@
*/
/*
-** This module manages tables that list the definitions of the types (and
-** eventually type class instances) defined in the program.
+** This module manages tables that list the definitions of the type
+** constructors, type classes and type class instances defined in the program.
**
** The sizes of these tables can vary by several orders of magnitude,
** so using a fixed size hash table would not be a good idea. This is why
@@ -23,19 +23,52 @@
#include "mercury_misc.h"
#include <string.h>
+/*
+** This module maintains four data structures: two hash tables and two lists.
+** One hash table and one list contain information about type constructors,
+** with the elements in the hash table and the list being MR_TypeCtorInfos,
+** while the other hash table and list contain information about type
+** classes and their instances, with the elements in the hash table and the
+** list being MR_TypeClassDeclInfo pointers.
+**
+** All four data structures are mononotic: you can insert information into
+** them, but you cannot remove anything from them.
+**
+** We assume that two registered structures (whether MR_TypeCtorInfos,
+** MR_TypeClassDecls, or MR_Instances) with different addresses contain
+** different information. This is OK because the registered structures are
+** supposed to be compiler generated, and the compiler ensures this invariant.
+*/
+
static MR_TableNode MR_type_ctor_table = { 0 };
+static MR_TableNode MR_type_class_decl_info_table = { 0 };
+static MR_Dlist *MR_type_ctor_list = NULL;
+static MR_Dlist *MR_type_class_decl_info_list = NULL;
+
+static MR_TypeClassDeclInfo *MR_do_register_type_class_decl(
+ MR_TypeClassDecl type_class_decl);
-#define names_match(tc1, module_name, type_name, arity) \
+#define type_names_match(tc1, module_name, type_name, arity) \
( MR_streq(MR_type_ctor_name(tc1), type_name) \
&& MR_streq(MR_type_ctor_module_name(tc1), module_name) \
&& tc1->MR_type_ctor_arity == arity)
-#define names_match_tc(tc1, tc2) \
+#define type_names_match_ctor(tc1, tc2) \
( MR_streq(MR_type_ctor_name(tc1), MR_type_ctor_name(tc2)) \
&& MR_streq(MR_type_ctor_module_name(tc1), \
MR_type_ctor_module_name(tc2)) \
&& tc1->MR_type_ctor_arity == tc2->MR_type_ctor_arity )
+#define class_names_match(tc_id1, module_name, class_name, arity) \
+ ( MR_streq(tc_id1->MR_tc_id_name, class_name) \
+ && MR_streq(tc_id1->MR_tc_id_module_name, module_name) \
+ && tc_id1->MR_tc_id_arity == arity)
+
+#define class_names_match_id(tc_id1, tc_id2) \
+ ( MR_streq(tc_id1->MR_tc_id_name, tc_id2->MR_tc_id_name) \
+ && MR_streq(tc_id1->MR_tc_id_module_name, tc_id2->MR_tc_id_module_name)\
+ && tc_id1->MR_tc_id_arity == tc_id2->MR_tc_id_arity)
+
void
MR_register_type_ctor_info(MR_TypeCtorInfo type_ctor_info)
{
@@ -43,6 +76,7 @@
MR_Dlist *element_ptr;
MR_TypeCtorInfo cur_type_ctor_info;
+ MR_assert(type_ctor_info != NULL);
slot = MR_string_hash_lookup_or_add(&MR_type_ctor_table,
MR_type_ctor_name(type_ctor_info));
@@ -50,7 +84,8 @@
cur_type_ctor_info =
(MR_TypeCtorInfo) MR_dlist_data(element_ptr);
- if (names_match_tc(type_ctor_info, cur_type_ctor_info)) {
+ if (type_names_match_ctor(type_ctor_info, cur_type_ctor_info))
+ {
if (cur_type_ctor_info == type_ctor_info) {
/* type_ctor_info has been registered before */
return;
@@ -63,6 +98,86 @@
slot->MR_type_table = MR_dlist_addhead(slot->MR_type_table,
type_ctor_info);
+ MR_type_ctor_list = MR_dlist_addtail(MR_type_ctor_list,
+ type_ctor_info);
+}
+
+static MR_TypeClassDeclInfo *
+MR_do_register_type_class_decl(MR_TypeClassDecl type_class_decl)
+{
+ MR_TrieNode slot;
+ MR_Dlist *element_ptr;
+ MR_TypeClassDeclInfo *cur_type_class_decl_info;
+ MR_TypeClassDecl cur_type_class_decl;
+ const MR_TypeClassId *cur_type_class_id;
+ MR_TypeClassDeclInfo *type_class_decl_info;
+ const MR_TypeClassId *type_class_id;
+
+ MR_assert(type_class_decl != NULL);
+ type_class_id = type_class_decl->MR_tc_decl_id;
+
+ slot = MR_string_hash_lookup_or_add(&MR_type_class_decl_info_table,
+ type_class_id->MR_tc_id_name);
+
+ MR_for_dlist (element_ptr, slot->MR_type_table) {
+ cur_type_class_decl_info =
+ (MR_TypeClassDeclInfo *) MR_dlist_data(element_ptr);
+ cur_type_class_decl = cur_type_class_decl_info->
+ MR_tcd_info_decl;
+ cur_type_class_id = cur_type_class_decl->MR_tc_decl_id;
+
+ if (class_names_match_id(type_class_id, cur_type_class_id)) {
+ if (cur_type_class_decl == type_class_decl) {
+ /* type_ctor_info has been registered before */
+ return cur_type_class_decl_info;
+ } else {
+ MR_fatal_error(
+ "MR_do_register_type_class_decl: "
+ "ambiguous type class decl");
+ }
+ }
+ }
+
+ type_class_decl_info = MR_NEW(MR_TypeClassDeclInfo);
+ type_class_decl_info->MR_tcd_info_decl = type_class_decl;
+ type_class_decl_info->MR_tcd_info_instances = MR_dlist_makelist0();
+ slot->MR_type_table = MR_dlist_addhead(slot->MR_type_table,
+ type_class_decl_info);
+ MR_type_class_decl_info_list = MR_dlist_addtail(
+ MR_type_class_decl_info_list, type_class_decl_info);
+ return type_class_decl_info;
+}
+
+void
+MR_register_type_class_decl(MR_TypeClassDecl type_class_decl)
+{
+ (void) MR_do_register_type_class_decl(type_class_decl);
+}
+
+void
+MR_register_type_class_instance(MR_Instance type_class_instance)
+{
+ MR_TypeClassDeclInfo *type_class_decl_info;
+ MR_Dlist *element_ptr;
+ MR_Instance cur_instance;
+
+ type_class_decl_info = MR_do_register_type_class_decl(
+ type_class_instance->MR_tc_inst_type_class);
+ MR_assert(type_class_decl_info != NULL);
+
+ MR_for_dlist (element_ptr, type_class_decl_info->MR_tcd_info_instances)
+ {
+ cur_instance = (MR_Instance) MR_dlist_data(element_ptr);
+ if (cur_instance == type_class_instance) {
+ /* type_class_instance has been registered before */
+ return;
+ }
+ }
+
+ /* type_class_instance has not been registered before */
+ type_class_decl_info->MR_tcd_info_instances =
+ MR_dlist_addtail(type_class_decl_info->MR_tcd_info_instances,
+ type_class_instance);
}
MR_TypeCtorInfo
@@ -79,12 +194,86 @@
cur_type_ctor_info =
(MR_TypeCtorInfo) MR_dlist_data(element_ptr);
- if (names_match(cur_type_ctor_info, module_name, type_name,
- arity))
+ if (type_names_match(cur_type_ctor_info, module_name,
+ type_name, arity))
{
return cur_type_ctor_info;
}
}
return NULL;
+}
+
+MR_TypeClassDeclInfo *
+MR_lookup_type_class_decl_info(const char *module_name, const char *class_name,
+ int arity)
+{
+ MR_TrieNode slot;
+ MR_Dlist *element_ptr;
+ MR_TypeClassDeclInfo *cur_type_class_decl_info;
+ MR_TypeClassDecl cur_type_class_decl;
+ const MR_TypeClassId *cur_type_class_id;
+
+ slot = MR_string_hash_lookup_or_add(&MR_type_class_decl_info_table,
+ class_name);
+
+ MR_for_dlist (element_ptr, slot->MR_type_table) {
+ cur_type_class_decl_info =
+ (MR_TypeClassDeclInfo *) MR_dlist_data(element_ptr);
+ cur_type_class_decl = cur_type_class_decl_info->
+ MR_tcd_info_decl;
+ cur_type_class_id = cur_type_class_decl->MR_tc_decl_id;
+
+ if (class_names_match(cur_type_class_id, module_name,
+ class_name, arity))
+ {
+ return cur_type_class_decl_info;
+ }
+ }
+
+ return NULL;
+}
+
+MR_TypeClassDecl
+MR_lookup_type_class_decl(const char *module_name, const char *class_name,
+ int arity)
+{
+ MR_TypeClassDeclInfo *type_class_decl_info;
+
+ type_class_decl_info = MR_lookup_type_class_decl_info(module_name,
+ class_name, arity);
+
+ if (type_class_decl_info == NULL) {
+ return NULL;
+ } else {
+ return type_class_decl_info->MR_tcd_info_decl;
+ }
+}
+
+MR_Dlist *
+MR_lookup_type_class_instances(const char *module_name, const char *class_name,
+ int arity)
+{
+ MR_TypeClassDeclInfo *type_class_decl_info;
+
+ type_class_decl_info = MR_lookup_type_class_decl_info(module_name,
+ class_name, arity);
+
+ if (type_class_decl_info == NULL) {
+ return NULL;
+ } else {
+ return type_class_decl_info->MR_tcd_info_instances;
+ }
+}
+
+MR_Dlist *
+MR_all_type_ctor_infos(void)
+{
+ return MR_type_ctor_list;
+}
+
+MR_Dlist *
+MR_all_type_class_decl_infos(void)
+{
+ return MR_type_class_decl_info_list;
}
Index: runtime/mercury_type_tables.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_type_tables.h,v
retrieving revision 1.1
diff -u -b -r1.1 mercury_type_tables.h
--- runtime/mercury_type_tables.h 11 Oct 2000 03:00:46 -0000 1.1
+++ runtime/mercury_type_tables.h 17 Oct 2003 14:48:16 -0000
@@ -14,6 +14,7 @@
#define MERCURY_TYPE_TABLES_H
#include "mercury_type_info.h"
+#include "mercury_typeclass_info.h"
/*
** Register the given type_ctor_info in the type table, so that it can be found
@@ -22,18 +23,130 @@
** The mercury_<module>_init_type_tables function generated automatically
** by the Mercury compiler for every module should call this function to
** register the type_ctor_infos of all the types defined in that module.
+**
+** The caller must not change anything in or reachable from type_ctor_info
+** at any time after this call.
*/
extern void MR_register_type_ctor_info(
MR_TypeCtorInfo type_ctor_info);
/*
+** Register the declaration of the given type class in the table of type
+** classes, so that it can be found by later calls to
+** MR_lookup_type_class_decl.
+**
+** The mercury_<module>_init_type_tables function generated automatically
+** by the Mercury compiler for every module should call this function to
+** register all the type classes defined in that module.
+**
+** The caller must not change anything in or reachable from type_class_decl
+** at any time after this call.
+*/
+
+extern void MR_register_type_class_decl(
+ MR_TypeClassDecl type_class_decl);
+
+/*
+** Register the given type class instance declaration in the table of type
+** class instances, so that it can be found by later calls to
+** MR_lookup_type_class_instances.
+**
+** The mercury_<module>_init_type_tables function generated automatically
+** by the Mercury compiler for every module should call this function to
+** register all the type class instances defined in that module.
+**
+** Since you can reach the MR_TypeClassDecl of the type class that
+** this function registers an instance of from the value of the argument,
+** it is OK to register an instance of a class whose declaration hasn't been
+** registered yet.
+**
+** The caller must not change anything in or reachable from instance
+** at any time after this call.
+*/
+
+extern void MR_register_type_class_instance(
+ MR_Instance instance);
+
+/*
** Find out if there is a type named type_name defined in module module_name
** with the given arity. If there is, return its type_ctor_info; if not, return
** NULL.
+**
+** The returned value is not guaranteed to be valid after the next call
+** to any of the MR_register_* functions in this module.
*/
-extern MR_TypeCtorInfo MR_lookup_type_ctor_info(const char *module_name,
+extern MR_TypeCtorInfo MR_lookup_type_ctor_info(
+ const char *module_name,
const char *type_name, int arity);
+
+/*
+** Each MR_TypeClassDeclInfo structure gives the MR_TypeClassDecl of a
+** type class and a list of all its instances.
+*/
+
+typedef struct {
+ MR_TypeClassDecl MR_tcd_info_decl;
+ MR_Dlist *MR_tcd_info_instances;
+ /* the list elements are of type MR_Instance */
+} MR_TypeClassDeclInfo;
+
+/*
+** Find out if there is a type class named class_name defined in module
+** module_name with the given arity. If there is, return a structure
+** giving its declaration and a list of all its instances. If not, return NULL.
+**
+** The returned value is not guaranteed to be valid after the next call
+** to any of the MR_register_* functions in this module.
+*/
+
+extern MR_TypeClassDeclInfo *MR_lookup_type_class_decl_info(
+ const char *module_name,
+ const char *class_name, int arity);
+
+/*
+** Find out if there is a type class named class_name defined in module
+** module_name with the given arity. If there is, return its declaration.
+** If not, return NULL.
+**
+** The returned value is not guaranteed to be valid after the next call
+** to any of the MR_register_* functions in this module.
+*/
+
+extern MR_TypeClassDecl MR_lookup_type_class_decl(
+ const char *module_name,
+ const char *class_name, int arity);
+
+/*
+** Find out if there is a type class named class_name defined in module
+** module_name with the given arity. If there is, return a list of its
+** instances (which may be of length zero but won't be NULL). If not,
+** return NULL.
+**
+** The returned value is not guaranteed to be valid after the next call
+** to any of the MR_register_* functions in this module.
+*/
+
+extern MR_Dlist *MR_lookup_type_class_instances(
+ const char *module_name,
+ const char *class_name, int arity);
+
+/*
+** Return a list of all the type constructors registered so far. The list
+** elements are of type MR_TypeCtorInfo. The caller must not modify anything
+** reachable from the returned list.
+*/
+
+extern MR_Dlist *MR_all_type_ctor_infos(void);
+
+/*
+** Return a list of all the type classes registered so far. The list
+** elements are of type MR_TypeClassDeclInfo.
+** The caller must not modify anything reachable from the returned
+** list.
+*/
+
+extern MR_Dlist *MR_all_type_class_decl_infos(void);
#endif /* not MERCURY_TYPE_TABLES */
Index: runtime/mercury_typeclass_info.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_typeclass_info.h,v
retrieving revision 1.2
diff -u -b -r1.2 mercury_typeclass_info.h
--- runtime/mercury_typeclass_info.h 12 Sep 2002 09:07:15 -0000 1.2
+++ runtime/mercury_typeclass_info.h 18 Oct 2003 05:01:30 -0000
@@ -77,53 +77,59 @@
Zoltan.
*/
+#ifndef MERCURY_TYPECLASS_INFO_H
+#define MERCURY_TYPECLASS_INFO_H
+
+#include "mercury_types.h"
+#include "mercury_type_info.h" /* for MR_PseudoTypeInfo */
+#include "mercury_stack_layout.h" /* for MR_PredFunc */
+
/*****************************************************************************/
-typedef const struct MR_TypeClass_Struct MR_TypeClassStruct;
-typedef const struct MR_TypeClass_Struct *MR_TypeClass;
-typedef const struct MR_Instance_Struct MR_InstanceStruct;
+typedef struct MR_TypeClassDecl_Struct MR_TypeClassDeclStruct;
+typedef const struct MR_TypeClassDecl_Struct *MR_TypeClassDecl;
+typedef struct MR_Instance_Struct MR_InstanceStruct;
typedef const struct MR_Instance_Struct *MR_Instance;
typedef struct MR_Dictionary_Struct MR_DictionaryStruct;
typedef struct MR_Dictionary_Struct *MR_Dictionary;
/*
-** A typeclass skeleton is intended to represent a typeclass constraint
-** being applied to a vector of possibly nonground types, as one may find
-** constraining a typeclass declaration, an instance declaration, or a
-** predicate/function declaration.
-**
-** Type class skeletons for type classes with arity N will be of type
-** MR_TypeClassSkel_N. Generic code will manipulate them as if they were of
-** type MR_TypeClassSkel, getting the actual number of arguments from
-** MR_tc_skel_type_class_info->MR_tc_id->MR_tc_id_arity.
+** A typeclass constraint asserts the membership of a possibly nonground
+** vector of types in a type class, as one may find constraining a typeclass
+** declaration, an instance declaration, or a predicate/function declaration.
+**
+** Type class constraints for type classes with arity N will be of type
+** MR_TypeClassConstraint_N. Generic code will manipulate them as if they were
+** of type MR_TypeClassConstraint, getting the actual number of arguments from
+** MR_tc_constr_type_class_info->MR_tc_decl_id->MR_tc_id_arity.
**
** Note that the arity cannot be zero, so we do not have to worry about
** zero-size arrays. On the other hand, type classes with more than even two
** arguments can be expected to be very rare, so having five as a fixed limit
** should not be a problem. If it is, we can lift the limit by defining
-** MR_TypeClassSkel_N on demand for all N > 5.
+** MR_TypeClassConstraint_N on demand for all N > 5.
**
** We will have to rethink this structure once we start supporting constructor
** classes.
*/
-#define MR_DEFINE_TYPECLASS_SKEL_STRUCT(NAME, ARITY) \
+#define MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(NAME, ARITY) \
typedef struct MR_PASTE2(NAME, _Struct) { \
- MR_TypeClass MR_tc_skel_type_class_info; \
- MR_PseudoTypeInfo MR_tc_skel_arg_ptis[ARITY]; \
+ MR_TypeClassDecl MR_tc_constr_type_class_info; \
+ MR_PseudoTypeInfo MR_tc_constr_arg_ptis[ARITY]; \
} MR_PASTE2(NAME, Struct)
-MR_DEFINE_TYPECLASS_SKEL_STRUCT(MR_TypeClassSkel_1, 1);
-MR_DEFINE_TYPECLASS_SKEL_STRUCT(MR_TypeClassSkel_2, 2);
-MR_DEFINE_TYPECLASS_SKEL_STRUCT(MR_TypeClassSkel_3, 3);
-MR_DEFINE_TYPECLASS_SKEL_STRUCT(MR_TypeClassSkel_4, 4);
-MR_DEFINE_TYPECLASS_SKEL_STRUCT(MR_TypeClassSkel_5, 5);
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_1, 1);
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_2, 2);
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_3, 3);
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_4, 4);
+MR_DEFINE_TYPECLASS_CONSTRAINT_STRUCT(MR_TypeClassConstraint_5, 5);
-typedef MR_TypeClassSkel_5Struct MR_TypeClassSkelStruct;
-typedef MR_TypeClassSkelStruct *MR_TypeClassSkel;
+typedef MR_TypeClassConstraint_5Struct MR_TypeClassConstraintStruct;
+typedef const MR_TypeClassConstraintStruct *MR_TypeClassConstraint;
-#define MR_STD_TYPECLASS_SKEL_ADDR(p) ((MR_TypeClassSkel) \
- &((p).MR_tc_skel_type_class_info))
+#define MR_STD_TYPECLASS_CONSTRAINT_ADDR(p) \
+ ((MR_TypeClassConstraint) &((p).MR_tc_constr_type_class_info))
/*
** We generate one static MR_TypeClassMethod structure for every method in
@@ -179,38 +185,76 @@
*/
typedef struct {
- MR_ConstString MR_tc_id_module;
+ MR_ConstString MR_tc_id_module_name;
MR_ConstString MR_tc_id_name;
const MR_int_least8_t MR_tc_id_arity;
const MR_int_least8_t MR_tc_id_num_type_vars;
- const MR_int_least8_t MR_tc_id_num_methods;
+ const MR_int_least16_t MR_tc_id_num_methods;
const MR_ConstString *MR_tc_id_type_var_names;
- const MR_TypeClassMethod **MR_tc_id_methods;
+ const MR_TypeClassMethod *MR_tc_id_methods;
} MR_TypeClassId;
/*
-** We generate one static MR_TypeClass structure for each typeclass
+** We generate one static MR_TypeClassDecl structure for each typeclass
** declaration in the program.
**
-** The MR_tc_id field gives a printable representation of the declaration.
+** The MR_tc_decl_id field gives a printable representation of the declaration.
** We point to it instead of including it because we want to allow its size to
** change without affecting binary compatibility.
**
-** The MR_tc_num_super field gives the number of superclasses, while the
-** MR_tc_supers field points to a vector of pointers to superclass descriptors,
-** one for each superclass. (The reason why the vector elements are pointers to
-** descriptors instead of descriptors themselves is that superclasses with
-** different arities have different sizes, so putting them into an array is not
-** practical.)
+** The MR_tc_decl_version_number field specifies the version of the data
+** structures describing runtime information about type classes. Any change
+** to those structures that affects binary compatibility should be accompanied
+** by an increase in this version number. The symbolic names of different
+** versions should follow the form MR_TYPECLASS_VERSION_*, and be listed
+** below.
+**
+** The MR_tc_decl_num_supers field gives the number of superclasses, while the
+** MR_tc_decl_supers field points to a vector of pointers to superclass
+** descriptors, one for each superclass. (The reason why the vector elements
+** are pointers to descriptors instead of descriptors themselves is that
+** superclasses with different arities have different sizes, so putting them
+** into an array is not practical.)
*/
-struct MR_TypeClass_Struct {
- const MR_TypeClassId *MR_tc_id;
- const MR_int_least8_t MR_tc_num_super;
- const MR_TypeClassSkel *MR_tc_supers;
+struct MR_TypeClassDecl_Struct {
+ const MR_TypeClassId *MR_tc_decl_id;
+ const MR_int_least8_t MR_tc_decl_version_number;
+ const MR_int_least8_t MR_tc_decl_num_supers;
+ const MR_TypeClassConstraint *MR_tc_decl_supers;
};
/*
+** The symbolic names of versions of the run time data structures
+** describing type class information -- useful for bootstrapping.
+**
+** MR_TYPECLASS_VERSION plays the same role for the data structures defined in
+** this file as MR_RTTI_VERSION plays for the data structures defined in
+** mercury_type_info.h. If you write runtime code that checks this version
+** number and can at least handle the previous version of the data
+** structure, it makes it easier to bootstrap changes to these data
+** structures.
+**
+** This number should be kept in sync with type_class_info_rtti_version in
+** compiler/type_class_info.m and with MR_TYPECLASS_VERSION in mercury_mcpp.h.
+*/
+
+#define MR_TYPECLASS_VERSION MR_TYPECLASS_VERSION_INITIAL
+#define MR_TYPECLASS_VERSION_INITIAL 0
+
+/*
+** Check that the RTTI version number for type class information is in
+** a sensible range. The lower bound should be the lowest currently supported
+** version number. The upper bound is the current version number.
+** If you increase the lower bound you should also increase the binary
+** compatibility version number in runtime/mercury_grade.h (MR_GRADE_PART_0).
+*/
+
+#define MR_TYPE_CLASS_INFO_CHECK_RTTI_VERSION_RANGE(typeclassdecl) \
+ assert((typeclassdecl)->MR_tc_decl_version_number == \
+ MR_TYPECLASS_VERSION__FLAG)
+
+/*
** We generate one static MR_Instance structure for each instance declaration
** in the program.
**
@@ -218,7 +262,7 @@
** declaration creates new instances of.
**
** The MR_tc_inst_type_args field points to a vector of MR_PseudoTypeInfos
-** whose length is MR_tc_inst_type_class->MR_tc_id->MR_tc_id_arity; each
+** whose length is MR_tc_inst_type_class->MR_tc_decl_id->MR_tc_id_arity; each
** pseudotypeinfo in this vector will describe the (possibly nonground) type
** in the corresponding position in the head of the instance declaration.
**
@@ -235,7 +279,7 @@
**
** The MR_tc_inst_methods field gives the methods declared by the instance
** declaration. It points to a vector of code addresses, one for each method;
-** the length of the vector is MR_tc_inst_type_class->MR_tc_id->
+** the length of the vector is MR_tc_inst_type_class->MR_tc_decl_id->
** MR_tc_id_num_methods. The procedures being pointed to may be polymorphic,
** for either one of two reasons: the instance declaration may specify
** nonground types, and the method may have universally quantified type
@@ -243,12 +287,12 @@
*/
struct MR_Instance_Struct {
- const MR_TypeClass MR_tc_inst_type_class;
- const MR_PseudoTypeInfo *MR_tc_inst_type_args;
+ const MR_TypeClassDecl MR_tc_inst_type_class;
const MR_int_least8_t MR_tc_inst_num_type_vars;
const MR_int_least8_t MR_tc_inst_num_instance_constraints;
- const MR_TypeClassSkel *MR_tc_inst_instance_constraints;
- const MR_Code *MR_tc_inst_methods;
+ const MR_PseudoTypeInfo *MR_tc_inst_type_args;
+ const MR_TypeClassConstraint *MR_tc_inst_instance_constraints;
+ const MR_CodePtr MR_tc_inst_methods;
};
/*
@@ -260,32 +304,33 @@
**
** The MR_class_dict_class field identifies the type class, while the
** MR_class_dict_type_binding field, which points to a vector of typeinfos
-** whose length is MR_class_dict_class->MR_tc_id->MR_tc_id_arity, identifies
-** the ground instance.
+** whose length is MR_class_dict_class->MR_tc_decl_id->MR_tc_id_arity,
+** identifies the ground instance.
**
** The MR_class_dict_methods field, which points to a vector whose length is
-** MR_class_dict_class->MR_tc_id->MR_tc_id_num_methods, gives the methods
+** MR_class_dict_class->MR_tc_decl_id->MR_tc_id_num_methods, gives the methods
** themselves. A method procedure will be polymorphic only if its signature
** includes type variables that are not parameters of the type class.
**
-** The MR_class_dict_version_number field is needed only for bootstrapping.
-** Initially, it should always contain zero. Do_call_class_method in the
-** runtime system can then distingish distinguish MR_ClassDicts from the
-** old-style typeclass_infos filling the same role, which all contain a
-** non-null pointer to a base_typeclass_info in their first word. Later,
-** we can use different values in this field to distinguish different versions
-** of this design at runtime, just as we do for type_ctor_infos.
+** The MR_class_dict_version_number field is needed only for bootstrapping
+** the change from MR_BaseTypeclassInfo to MR_ClassDict. It should always
+** contain zero, to allow do_call_class_method in the runtime system to
+** distingish distinguish MR_ClassDicts (whose first word is thus always zero)
+** from old-style typeclass_infos filling the same role, which all contain a
+** non-null pointer to an MR_BaseTypeclassInfo in their first word.
+**
+** For bootstrapping later changes in the structures of the types representing
+** run time information about typeclasses, we will use the version number field
+** in MR_TypeClassDecls.
*/
typedef struct {
MR_Integer MR_class_dict_version_number;
- MR_TypeClass MR_class_dict_class;
+ MR_TypeClassDecl MR_class_dict_class;
MR_TypeInfo *MR_class_dict_type_binding;
- MR_Code *MR_class_dict_methods;
+ MR_CodePtr MR_class_dict_methods;
} MR_ClassDict;
-#define MR_TYPECLASS_VERSION 0
-
/*
** A MR_Dictionary_Struct structure corresponds to a fully solved type class
** constraint. They can be either static and dynamic, for the same reasons as
@@ -299,10 +344,10 @@
**
** The MR_dict_superclass_dicts field points to a vector of pointers to
** dictionaries. The number of elements in the vector will be given by
-** MR_dict_top_instance->MR_class_dict_class->MR_tc_id->MR_tc_id_num_supers.
-** The element in the vector at index N+1 will specify the dictionary for this
-** instance of the Nth superclass constraint on the typeclass declaration.
-** (The +1 is because array numbering starts at 0.)
+** MR_dict_top_instance->MR_class_dict_class->MR_tc_decl_num_supers.
+** dict->MR_dict_superclass_dicts[N-1] will specify the dictionary
+** for this instance of the Nth superclass constraint on the typeclass
+** declaration. (The -1 is because array numbering starts at 0.)
*/
typedef struct {
@@ -310,3 +355,5 @@
MR_ClassDict *MR_dict_class_methods;
MR_ClassDict **MR_dict_superclass_dicts;
} MR_Dictionary_Struct;
+
+#endif /* not MERCURY_TYPECLASS_INFO_H */
Index: runtime/mercury_typeclass_info_example.c
===================================================================
RCS file: runtime/mercury_typeclass_info_example.c
diff -N runtime/mercury_typeclass_info_example.c
--- runtime/mercury_typeclass_info_example.c 5 Aug 2002 02:23:35 -0000 1.1
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,175 +0,0 @@
-/*
-** vim: ts=4 sw=4 expandtab
-*/
-/*
-** Copyright (C) 2002 The University of Melbourne.
-** This file may only be copied under the terms of the GNU Library General
-** Public License - see the file COPYING.LIB in the Mercury distribution.
-*/
-
-#include "mercury_imp.h"
-#include "mercury_typeclass_info.h"
-
-/*
-
-As an example, consider the following declarations, which we want to be able
-to support in the future, although they are not allowed by the current system:
-
-:- module sample.
-
-:- typeclass foo(T1, T2) <= bar(T1), baz(T2), quux(float, T1) where [
- pred method1(T1::in, T2::in, W::in, W::out) is det,
- func method2(list(T1)::in, int::in, T2::in) = T::out is det
-].
-
-:- instance foo(list(U1), T2) <= foo(U1, T2), boo(int, U1).
-
-We should generate the following data structures from the above declarations.
-(The names of the global variables are tentative.)
-
-*/
-
-extern struct MR_TypeClass_Struct
- mercury_data__type_class__sample__bar__1;
-extern struct MR_TypeClass_Struct
- mercury_data__type_class__sample__baz__1;
-extern struct MR_TypeClass_Struct
- mercury_data__type_class__sample__quux__2;
-extern struct MR_TypeCtorInfo_Struct
- mercury_data__type_ctor_info__builtin__int_0;
-extern struct MR_TypeCtorInfo_Struct
- mercury_data__type_ctor_info__builtin__float_0;
-
-const MR_TypeClassMethod mercury_data__type_class_method__sample__foo_2_1 =
-{
- "method1",
- 4,
- MR_PREDICATE
-};
-
-const MR_TypeClassMethod mercury_data__type_class_method__sample__foo_2_2 =
-{
- "method2",
- 4,
- MR_FUNCTION
-};
-
-const MR_ConstString mercury_data__type_class_id_tvar_names__sample__foo_2[] =
-{
- "T1",
- "T2",
- "W",
-};
-
-const MR_TypeClassMethod *mercury_data__type_class_id_methods__sample__foo_2[] =
-{
- /* the form of what goes here is backend-dependent */
- &mercury_data__type_class_method__sample__foo_2_1,
- &mercury_data__type_class_method__sample__foo_2_2,
-};
-
-const MR_TypeClassId mercury_data__type_class_id__sample__foo__2 =
-{
- "sample",
- "foo",
- 2,
- 3, /* T1, T2, W */
- 2,
- mercury_data__type_class_id_tvar_names__sample__foo_2,
- mercury_data__type_class_id_methods__sample__foo_2
-};
-
-const MR_TypeClassSkel_1Struct
-mercury_data__type_class_skel__sample__bar__1_var_1
-= {
- &mercury_data__type_class__sample__bar__1,
- {
- (MR_PseudoTypeInfo) 1,
- }
-};
-
-const MR_TypeClassSkel_1Struct
-mercury_data__type_class_skel__sample__baz__1_var_2
-= {
- &mercury_data__type_class__sample__baz__1,
- {
- (MR_PseudoTypeInfo) 2,
- }
-};
-
-const MR_TypeClassSkel_2Struct
-mercury_data__type_class_skel__sample__quux__2_float_var_1
-= {
- &mercury_data__type_class__sample__quux__2,
- {
- (MR_PseudoTypeInfo) &mercury_data__type_ctor_info__builtin__float_0,
- (MR_PseudoTypeInfo) 1,
- }
-};
-
-const MR_TypeClassSkel mercury_data__type_class_supers__sample__foo__2[] =
-{
- MR_STD_TYPECLASS_SKEL_ADDR(
- mercury_data__type_class_skel__sample__bar__1_var_1),
- MR_STD_TYPECLASS_SKEL_ADDR(
- mercury_data__type_class_skel__sample__baz__1_var_2),
- MR_STD_TYPECLASS_SKEL_ADDR(
- mercury_data__type_class_skel__sample__quux__2_float_var_1),
-};
-
-MR_TypeClassStruct mercury_data__type_class__sample__foo__2 =
-{
- &mercury_data__type_class_id__sample__foo__2,
- 3,
- mercury_data__type_class_supers__sample__foo__2
-};
-
-const MR_PseudoTypeInfo
-mercury_data__instance_args__sample__foo__2__list__list__1_var_1_var_2[]
-= {
- /* <pseudotypeinfo for list(1)>, */
- (MR_PseudoTypeInfo) 0,
- (MR_PseudoTypeInfo) 2,
-};
-
-const MR_TypeClassSkel_2Struct
-mercury_data__type_class_skel__sample__foo__2_var_1_var_2
-= {
- &mercury_data__type_class__sample__foo__2,
- {
- (MR_PseudoTypeInfo) 1,
- (MR_PseudoTypeInfo) 2,
- }
-};
-
-const MR_TypeClassSkel_2Struct
-mercury_data__type_class_skel__sample__boo__2_int_var_1
-= {
- &mercury_data__type_class__sample__foo__2,
- {
- (MR_PseudoTypeInfo) &mercury_data__type_ctor_info__builtin__int_0,
- (MR_PseudoTypeInfo) 1,
- }
-};
-
-const MR_TypeClassSkel
-mercury_data__instance_constraints__sample__foo__2__list__list__1_var_1_var_2[]
-= {
- MR_STD_TYPECLASS_SKEL_ADDR(
- mercury_data__type_class_skel__sample__foo__2_var_1_var_2),
- MR_STD_TYPECLASS_SKEL_ADDR(
- mercury_data__type_class_skel__sample__boo__2_int_var_1),
-};
-
-MR_InstanceStruct
-mercury_data__instance__sample__foo__2__list__list__1_var_1_var_2
-= {
- &mercury_data__type_class__sample__foo__2,
- mercury_data__instance_args__sample__foo__2__list__list__1_var_1_var_2,
- 2, /* U1, T2 */
- 2,
- mercury_data__instance_constraints__sample__foo__2__list__list__1_var_1_var_2,
- /* the form of the methods in the method block is backend-dependent */
- /* <method block pointer> */
- NULL
-};
Index: runtime/mercury_types.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_types.h,v
retrieving revision 1.34
diff -u -b -r1.34 mercury_types.h
--- runtime/mercury_types.h 24 Jun 2003 01:21:22 -0000 1.34
+++ runtime/mercury_types.h 16 Oct 2003 05:35:25 -0000
@@ -80,7 +80,7 @@
/*
** This section defines the basic types that we use.
** Note that we require
-** sizeof(MR_Word) == sizeof(MR_Integer) == sizeof(MR_Code*).
+** sizeof(MR_Word) == sizeof(MR_Integer) == sizeof(MR_CodePtr).
*/
typedef MR_uintptr_t MR_Word;
@@ -94,11 +94,12 @@
#define MR_bytes_to_words(x) (((x) + sizeof(MR_Word) - 1) / sizeof(MR_Word))
/*
-** `MR_Code *' is used as a generic pointer-to-label type that can point
-** to any label defined using the Define_* macros in mercury_goto.h.
+** `MR_CodePtr' is used as a generic pointer-to-label type that can point
+** to any label defined using the MR_define_* macros in mercury_goto.h.
*/
typedef void MR_Code;
+typedef MR_Code *MR_CodePtr;
/*
** MR_Float64 is required for the bytecode.
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.123
diff -u -b -r1.123 mercury_wrapper.c
--- runtime/mercury_wrapper.c 16 Oct 2003 05:26:38 -0000 1.123
+++ runtime/mercury_wrapper.c 17 Oct 2003 15:39:08 -0000
@@ -1470,10 +1470,6 @@
#ifdef MR_TYPE_CTOR_STATS
-static MR_ConstString MR_ctor_rep_name[] = {
- MR_CTOR_REP_NAMES
-};
-
#define MR_INIT_CTOR_NAME_ARRAY_SIZE 10
void
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
Index: tests/debugger/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/Mercury.options,v
retrieving revision 1.7
diff -u -b -r1.7 Mercury.options
--- tests/debugger/Mercury.options 2 Apr 2003 23:01:42 -0000 1.7
+++ tests/debugger/Mercury.options 18 Oct 2003 09:44:56 -0000
@@ -3,6 +3,10 @@
# the input is not a terminal.
MLFLAGS-completion = --runtime-flags --force-readline
+# The debugger can't know about type class declarations unless we generate
+# the new type of RTTI for them.
+MCFLAGS-class_decl = --new-type-class-rtti
+
# The label_layout test is for a bug that showed up only with --opt-space.
MCFLAGS-label_layout = --opt-space
@@ -28,4 +32,3 @@
# The following is necessary for shared libraries to work on Linux.
GRADEFLAGS-interactive = --pic-reg
MLFLAGS-interactive = --shared
-
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.97
diff -u -b -r1.97 Mmakefile
--- tests/debugger/Mmakefile 2 Sep 2003 09:25:25 -0000 1.97
+++ tests/debugger/Mmakefile 18 Oct 2003 08:53:24 -0000
@@ -17,6 +17,7 @@
NONRETRY_PROGS = \
breakpoints \
browse_pretty \
+ class_decl \
cmd_quote \
debugger_regs \
exception_cmd \
@@ -199,6 +200,12 @@
browser_test.out: browser_test browser_test.inp
$(MDB_STD) ./browser_test < browser_test.inp 2>&1 | \
sed 's/io.m:[0-9]*/io.m:NNNN/g' > browser_test.out 2>&1
+
+# We need to pipe the output through sed to avoid hard-coding dependencies on
+# particular line numbers in the standard library source code.
+class_decl.out: class_decl class_decl.inp
+ $(MDB) ./class_decl < class_decl.inp 2>&1 | \
+ sed 's/io.m:[0-9]*/io.m:NNNN/g' > class_decl.out 2>&1
# We need to pipe the output through sed to avoid hard-coding dependencies on
# particular line numbers in the standard library source code.
Index: tests/debugger/class_decl.exp
===================================================================
RCS file: tests/debugger/class_decl.exp
diff -N tests/debugger/class_decl.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/class_decl.exp 18 Oct 2003 10:21:05 -0000
@@ -0,0 +1,93 @@
+ 1: 1 1 CALL pred class_decl.main/2-0 (det) class_decl.m:21
+mdb> echo on
+Command echo enabled.
+mdb> register --quiet
+mdb> all_type_ctors class_decl
+type constructor class_decl.t2/1
+
+type constructor class_decl.t1/0
+
+number of type constructors in module class_decl: 2
+mdb> type_ctor class_decl t1 0
+type constructor class_decl.t1/0
+mdb> type_ctor -r class_decl t1 0
+type constructor class_decl.t1/0: NOTAG_GROUND
+mdb> type_ctor -f class_decl t1 0
+type constructor class_decl.t1/0
+t1/1
+mdb> type_ctor -rf class_decl t1 0
+type constructor class_decl.t1/0: NOTAG_GROUND
+t1/1
+mdb> type_ctor class_decl t2 1
+type constructor class_decl.t2/1
+mdb> type_ctor -r class_decl t2 1
+type constructor class_decl.t2/1: DU
+mdb> type_ctor -f class_decl t2 1
+type constructor class_decl.t2/1
+t2a/1, t2b/2
+mdb> type_ctor -f -r class_decl t2 1
+type constructor class_decl.t2/1: DU
+t2a/1, t2b/2
+mdb> type_ctor class_decl t1 1
+there is no such type constructor
+mdb> type_ctor class_decl nonexistent 3
+there is no such type constructor
+mdb> all_class_decls class_decl
+type class class_decl.foo/1
+
+type class class_decl.bar/2
+
+number of type classes in module class_decl: 2
+mdb> class_decl class_decl foo 1
+type class class_decl.foo/1
+mdb> class_decl -m class_decl foo 1
+type class class_decl.foo/1
+methods: pred foo_method/3
+mdb> class_decl -i class_decl foo 1
+type class class_decl.foo/1
+instance builtin.string
+instance class_decl.t1
+instance class_decl.t2(T1)
+mdb> class_decl -mi class_decl foo 1
+type class class_decl.foo/1
+methods: pred foo_method/3
+instance builtin.string
+instance class_decl.t1
+instance class_decl.t2(T1)
+mdb> class_decl class_decl bar 2
+type class class_decl.bar/2
+mdb> class_decl -m class_decl bar 2
+type class class_decl.bar/2
+methods: pred bar_method/4
+mdb> class_decl -i class_decl bar 2
+type class class_decl.bar/2
+instance builtin.int, builtin.int
+instance builtin.string, builtin.int
+instance builtin.string, builtin.string
+instance class_decl.t1, builtin.int
+instance class_decl.t1, class_decl.t2(T1)
+mdb> class_decl -mi class_decl bar 2
+type class class_decl.bar/2
+methods: pred bar_method/4
+instance builtin.int, builtin.int
+instance builtin.string, builtin.int
+instance builtin.string, builtin.string
+instance class_decl.t1, builtin.int
+instance class_decl.t1, class_decl.t2(T1)
+mdb> class_decl class_decl bar 1
+there is no such type class
+mdb> class_decl class_decl bad 2
+there is no such type class
+mdb> continue
+string: zero
+t1: 10
+t2a: 20
+t2b: 30, 40
+t2b: "thirty", "forty"
+ii: 11, 22
+si: eleven, 22
+ss: eleven, twentytwo
+t1int: 111, 222
+t1t2a: 333, 444
+t1t2b: 333, 444, 555
+t1t2b: 888, "sixsixsix", "sevensevenseven"
Index: tests/debugger/class_decl.inp
===================================================================
RCS file: tests/debugger/class_decl.inp
diff -N tests/debugger/class_decl.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/class_decl.inp 18 Oct 2003 09:10:14 -0000
@@ -0,0 +1,25 @@
+echo on
+register --quiet
+all_type_ctors class_decl
+type_ctor class_decl t1 0
+type_ctor -r class_decl t1 0
+type_ctor -f class_decl t1 0
+type_ctor -rf class_decl t1 0
+type_ctor class_decl t2 1
+type_ctor -r class_decl t2 1
+type_ctor -f class_decl t2 1
+type_ctor -f -r class_decl t2 1
+type_ctor class_decl t1 1
+type_ctor class_decl nonexistent 3
+all_class_decls class_decl
+class_decl class_decl foo 1
+class_decl -m class_decl foo 1
+class_decl -i class_decl foo 1
+class_decl -mi class_decl foo 1
+class_decl class_decl bar 2
+class_decl -m class_decl bar 2
+class_decl -i class_decl bar 2
+class_decl -mi class_decl bar 2
+class_decl class_decl bar 1
+class_decl class_decl bad 2
+continue
Index: tests/debugger/class_decl.m
===================================================================
RCS file: tests/debugger/class_decl.m
diff -N tests/debugger/class_decl.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/class_decl.m 18 Oct 2003 08:49:56 -0000
@@ -0,0 +1,122 @@
+:- module class_decl.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- typeclass foo(T) where [
+ pred foo_method(T::in, io__state::di, io__state::uo) is det
+].
+
+:- typeclass bar(T, U) where [
+ pred bar_method(T::in, U::in, io__state::di, io__state::uo) is det
+].
+
+:- type t1 ---> t1(int).
+:- type t2(T) ---> t2a(T) ; t2b(T, T).
+
+main -->
+ foo_method("zero"),
+ foo_method(t1(10)),
+ foo_method(t2a(20)),
+ foo_method(t2b(30, 40)),
+ foo_method(t2b("thirty", "forty")),
+ bar_method(11, 22),
+ bar_method("eleven", 22),
+ bar_method("eleven", "twentytwo"),
+ bar_method(t1(111), 222),
+ bar_method(t1(333), t2a(444)),
+ bar_method(t1(333), t2b(444, 555)),
+ bar_method(t1(888), t2b("sixsixsix", "sevensevenseven")).
+
+:- instance foo(string) where [pred(foo_method/3) is foo_string].
+:- instance foo(t1) where [pred(foo_method/3) is foo_t1].
+:- instance foo(t2(U)) where [pred(foo_method/3) is foo_t2].
+
+:- pred foo_string(string::in, io__state::di, io__state::uo) is det.
+:- pred foo_t1(t1::in, io__state::di, io__state::uo) is det.
+:- pred foo_t2(t2(V)::in, io__state::di, io__state::uo) is det.
+
+foo_string(S) -->
+ io__write_string("string: "),
+ io__write_string(S),
+ io__nl.
+
+foo_t1(t1(I)) -->
+ io__write_string("t1: "),
+ io__write_int(I),
+ io__nl.
+
+foo_t2(t2a(I)) -->
+ io__write_string("t2a: "),
+ io__write(I),
+ io__nl.
+foo_t2(t2b(I1, I2)) -->
+ io__write_string("t2b: "),
+ io__write(I1),
+ io__write_string(", "),
+ io__write(I2),
+ io__nl.
+
+:- instance bar(int, int) where [pred(bar_method/4) is bar_int_int].
+:- instance bar(string, int) where [pred(bar_method/4) is bar_str_int].
+:- instance bar(string, string) where [pred(bar_method/4) is bar_str_str].
+:- instance bar(t1, int) where [pred(bar_method/4) is bar_t1_int].
+:- instance bar(t1, t2(U)) where [pred(bar_method/4) is bar_t1_t2].
+
+:- pred bar_int_int(int::in, int::in,
+ io__state::di, io__state::uo) is det.
+:- pred bar_str_int(string::in, int::in,
+ io__state::di, io__state::uo) is det.
+:- pred bar_str_str(string::in, string::in,
+ io__state::di, io__state::uo) is det.
+:- pred bar_t1_int(t1::in, int::in,
+ io__state::di, io__state::uo) is det.
+:- pred bar_t1_t2(t1::in, t2(V)::in,
+ io__state::di, io__state::uo) is det.
+
+bar_int_int(I1, I2) -->
+ io__write_string("ii: "),
+ io__write_int(I1),
+ io__write_string(", "),
+ io__write_int(I2),
+ io__nl.
+
+bar_str_int(S1, I2) -->
+ io__write_string("si: "),
+ io__write_string(S1),
+ io__write_string(", "),
+ io__write_int(I2),
+ io__nl.
+
+bar_str_str(S1, S2) -->
+ io__write_string("ss: "),
+ io__write_string(S1),
+ io__write_string(", "),
+ io__write_string(S2),
+ io__nl.
+
+bar_t1_int(t1(I1), I2) -->
+ io__write_string("t1int: "),
+ io__write_int(I1),
+ io__write_string(", "),
+ io__write_int(I2),
+ io__nl.
+
+bar_t1_t2(t1(I1), t2a(I2)) -->
+ io__write_string("t1t2a: "),
+ io__write_int(I1),
+ io__write_string(", "),
+ io__write(I2),
+ io__nl.
+bar_t1_t2(t1(I1), t2b(I2, I3)) -->
+ io__write_string("t1t2b: "),
+ io__write_int(I1),
+ io__write_string(", "),
+ io__write(I2),
+ io__write_string(", "),
+ io__write(I3),
+ io__nl.
Index: tests/debugger/completion.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/completion.exp,v
retrieving revision 1.12
diff -u -b -r1.12 completion.exp
--- tests/debugger/completion.exp 18 Mar 2003 16:38:31 -0000 1.12
+++ tests/debugger/completion.exp 18 Oct 2003 08:12:56 -0000
@@ -3,27 +3,28 @@
Command echo enabled.
mdb> register --quiet
mdb>
-? document_category level s
-P down maxdepth save
-alias e mindepth scope
-all_regs echo mmc_options scroll
-b enable modules set
-break exception next source
-browse excp nondet_stack stack
-c f p stack_regs
-cc_query finish pneg_stack step
-clear_histogram flag print subgoal
-consumer forward print_optionals table
-context g printlevel table_io
-continue gen_stack proc_body unalias
-current goto proc_stats unhide_events
-cut_stack h procedures up
-d help query v
-dd histogram_all quit vars
-dd_dd histogram_exp r view
-delete ignore register
-disable io_query retry
-document label_stats return
+? disable label_stats s
+P document level save
+alias document_category maxdepth scope
+all_class_decls down mindepth scroll
+all_regs e mmc_options set
+all_type_ctors echo modules source
+b enable next stack
+break exception nondet_stack stack_regs
+browse excp p step
+c f pneg_stack subgoal
+cc_query finish print table
+class_decl flag print_optionals table_io
+clear_histogram forward printlevel type_ctor
+consumer g proc_body unalias
+context gen_stack proc_stats unhide_events
+continue goto procedures up
+current h query v
+cut_stack help quit vars
+d histogram_all r view
+dd histogram_exp register
+dd_dd ignore retry
+delete io_query return
h help histogram_all histogram_exp
vars view
help vars
Index: tests/debugger/mdb_command_test.inp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/debugger/mdb_command_test.inp,v
retrieving revision 1.24
diff -u -b -r1.24 mdb_command_test.inp
--- tests/debugger/mdb_command_test.inp 18 Mar 2003 16:38:31 -0000 1.24
+++ tests/debugger/mdb_command_test.inp 18 Oct 2003 10:20:52 -0000
@@ -60,3 +60,7 @@
unhide_events xyzzy xyzzy xyzzy xyzzy xyzzy
dd_dd xyzzy xyzzy xyzzy xyzzy xyzzy
table xyzzy xyzzy xyzzy xyzzy xyzzy
+type_ctor xyzzy xyzzy xyzzy xyzzy xyzzy
+all_type_ctors xyzzy xyzzy xyzzy xyzzy xyzzy
+class_decl xyzzy xyzzy xyzzy xyzzy xyzzy
+all_class_decls xyzzy xyzzy xyzzy xyzzy xyzzy
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.159
diff -u -b -r1.159 mercury_trace_internal.c
--- trace/mercury_trace_internal.c 8 Oct 2003 10:12:04 -0000 1.159
+++ trace/mercury_trace_internal.c 18 Oct 2003 09:58:44 -0000
@@ -456,6 +456,10 @@
static MR_TraceCmdFunc MR_trace_cmd_print_optionals;
static MR_TraceCmdFunc MR_trace_cmd_unhide_events;
static MR_TraceCmdFunc MR_trace_cmd_table;
+static MR_TraceCmdFunc MR_trace_cmd_type_ctor;
+static MR_TraceCmdFunc MR_trace_cmd_class_decl;
+static MR_TraceCmdFunc MR_trace_cmd_all_type_ctors;
+static MR_TraceCmdFunc MR_trace_cmd_all_class_decls;
static MR_TraceCmdFunc MR_trace_cmd_save;
static MR_TraceCmdFunc MR_trace_cmd_quit;
static MR_TraceCmdFunc MR_trace_cmd_dd;
@@ -521,6 +525,12 @@
static MR_bool MR_trace_options_dd(MR_bool *assume_all_io_is_tabled,
char ***words, int *word_count,
const char *cat, const char *item);
+static MR_bool MR_trace_options_type_ctor(MR_bool *print_rep,
+ MR_bool *print_functors, char ***words,
+ int *word_count, const char *cat, const char *item);
+static MR_bool MR_trace_options_class_decl(MR_bool *print_methods,
+ MR_bool *print_instances, char ***words,
+ int *word_count, const char *cat, const char *item);
static void MR_trace_usage(const char *cat, const char *item);
static void MR_trace_do_noop(void);
@@ -580,6 +590,17 @@
static void MR_trace_print_consumer_debug(const MR_Proc_Layout *proc,
MR_ConsumerDebug *consumer_debug);
+/* Prints the requested information inside the given MR_TypeCtorInfo. */
+static void MR_print_type_ctor_info(FILE *fp,
+ MR_TypeCtorInfo type_ctor_info,
+ MR_bool print_rep, MR_bool print_functors);
+/* Prints the requested information inside the given MR_TypeClassDeclInfo. */
+static void MR_print_class_decl_info(FILE *fp,
+ MR_TypeClassDeclInfo *type_class_decl_info,
+ MR_bool print_methods, MR_bool print_instances);
+/* Print the given pseudo-typeinfo. */
+static void MR_print_pseudo_type_info(FILE *fp, MR_PseudoTypeInfo pseudo);
+
static void MR_trace_set_level_and_report(int ancestor_level,
MR_bool detailed, MR_bool print_optionals);
static void MR_trace_browse_internal(MR_Word type_info, MR_Word value,
@@ -3509,16 +3530,13 @@
return KEEP_INTERACTING;
}
- if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE)
- {
+ if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE) {
fprintf(MR_mdb_out,
"io tabling has not yet started\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
fprintf(MR_mdb_out,
"io tabling has started\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out,
"io tabling has stopped\n");
} else {
@@ -3545,12 +3563,10 @@
MR_io_tabling_debug = MR_TRUE;
#endif
fprintf(MR_mdb_out, "io tabling started\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
fprintf(MR_mdb_out,
"io tabling has already started\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out,
"io tabling has already stopped\n");
} else {
@@ -3567,19 +3583,16 @@
return KEEP_INTERACTING;
}
- if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE)
- {
+ if (MR_io_tabling_phase == MR_IO_TABLING_BEFORE) {
fprintf(MR_mdb_out,
"io tabling has not yet started\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_DURING) {
MR_io_tabling_phase = MR_IO_TABLING_AFTER;
MR_io_tabling_end = MR_io_tabling_counter_hwm;
MR_io_tabling_stop_event_num =
event_info->MR_event_number;
fprintf(MR_mdb_out, "io tabling stopped\n");
- } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER)
- {
+ } else if (MR_io_tabling_phase == MR_IO_TABLING_AFTER) {
fprintf(MR_mdb_out,
"io tabling has already stopped\n");
} else {
@@ -4477,6 +4490,420 @@
}
static MR_Next
+MR_trace_cmd_type_ctor(char **words, int word_count,
+ MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
+ MR_Event_Details *event_details, MR_Code **jumpaddr)
+{
+ const char *module_name;
+ const char *name;
+ int arity;
+ MR_bool print_rep;
+ MR_bool print_functors;
+ MR_TypeCtorInfo type_ctor_info;
+
+ MR_do_init_modules_type_tables();
+
+ print_rep = MR_FALSE;
+ print_functors = MR_FALSE;
+ if (! MR_trace_options_type_ctor(&print_rep, &print_functors,
+ &words, &word_count, "developer", "type_ctor"))
+ {
+ ; /* the usage message has already been printed */
+ } else if (word_count == 4 &&
+ MR_trace_is_natural_number(words[3], &arity))
+ {
+ module_name = words[1];
+ name = words[2];
+ type_ctor_info =
+ MR_lookup_type_ctor_info(module_name, name, arity);
+ if (type_ctor_info != NULL) {
+ MR_print_type_ctor_info(MR_mdb_out, type_ctor_info,
+ print_rep, print_functors);
+ } else {
+ fprintf(MR_mdb_out,
+ "there is no such type constructor\n");
+ }
+ } else {
+ MR_trace_usage("developer", "type_ctor");
+ }
+
+ return KEEP_INTERACTING;
+}
+
+static MR_Next
+MR_trace_cmd_class_decl(char **words, int word_count,
+ MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
+ MR_Event_Details *event_details, MR_Code **jumpaddr)
+{
+ const char *module_name;
+ const char *name;
+ int arity;
+ MR_bool print_methods;
+ MR_bool print_instances;
+ MR_TypeClassDeclInfo *type_class_decl_info;
+
+ MR_do_init_modules_type_tables();
+
+ print_methods = MR_FALSE;
+ print_instances = MR_FALSE;
+ if (! MR_trace_options_class_decl(&print_methods, &print_instances,
+ &words, &word_count, "developer", "class_decl"))
+ {
+ ; /* the usage message has already been printed */
+ } else if (word_count == 4 &&
+ MR_trace_is_natural_number(words[3], &arity))
+ {
+ module_name = words[1];
+ name = words[2];
+ type_class_decl_info =
+ MR_lookup_type_class_decl_info(module_name, name,
+ arity);
+ if (type_class_decl_info != NULL) {
+ MR_print_class_decl_info(MR_mdb_out,
+ type_class_decl_info, print_methods,
+ print_instances);
+ } else {
+ fprintf(MR_mdb_out,
+ "there is no such type class\n");
+ }
+ } else {
+ MR_trace_usage("developer", "class_decl");
+ }
+
+ return KEEP_INTERACTING;
+}
+
+static MR_Next
+MR_trace_cmd_all_type_ctors(char **words, int word_count,
+ MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
+ MR_Event_Details *event_details, MR_Code **jumpaddr)
+{
+ MR_bool print_rep;
+ MR_bool print_functors;
+ MR_Dlist *list;
+ MR_Dlist *element_ptr;
+ MR_TypeCtorInfo type_ctor_info;
+ const char *module_name;
+ int count;
+
+ MR_do_init_modules_type_tables();
+
+ print_rep = MR_FALSE;
+ print_functors = MR_FALSE;
+ if (! MR_trace_options_type_ctor(&print_rep, &print_functors,
+ &words, &word_count, "developer", "all_class_decls"))
+ {
+ ; /* the usage message has already been printed */
+ } else if (word_count == 1 || word_count == 2) {
+ if (word_count == 2) {
+ module_name = words[1];
+ } else {
+ module_name = NULL;
+ }
+
+ list = MR_all_type_ctor_infos();
+ count = 0;
+ MR_for_dlist(element_ptr, list) {
+ type_ctor_info = (MR_TypeCtorInfo)
+ MR_dlist_data(element_ptr);
+ if (module_name != NULL && strcmp(module_name,
+ type_ctor_info->MR_type_ctor_module_name) != 0)
+ {
+ continue;
+ }
+
+ if (count > 0) {
+ fprintf(MR_mdb_out, "\n");
+ }
+ MR_print_type_ctor_info(MR_mdb_out, type_ctor_info,
+ print_rep, print_functors);
+ count++;
+ }
+
+ fprintf(MR_mdb_out, "\nnumber of type constructors ");
+ if (module_name == NULL) {
+ fprintf(MR_mdb_out, "in the program: %d\n", count);
+ } else {
+ fprintf(MR_mdb_out, "in module %s: %d\n",
+ module_name, count);
+ }
+ } else {
+ MR_trace_usage("developer", "class_decl");
+ }
+
+ return KEEP_INTERACTING;
+}
+
+static MR_Next
+MR_trace_cmd_all_class_decls(char **words, int word_count,
+ MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
+ MR_Event_Details *event_details, MR_Code **jumpaddr)
+{
+ MR_bool print_methods;
+ MR_bool print_instances;
+ MR_Dlist *list;
+ MR_Dlist *element_ptr;
+ MR_TypeClassDeclInfo *type_class_decl_info;
+ const char *module_name;
+ int count;
+
+ MR_do_init_modules_type_tables();
+
+ print_methods = MR_FALSE;
+ print_instances = MR_FALSE;
+ if (! MR_trace_options_class_decl(&print_methods, &print_instances,
+ &words, &word_count, "developer", "all_class_decls"))
+ {
+ ; /* the usage message has already been printed */
+ } else if (word_count == 1 || word_count == 2) {
+ if (word_count == 2) {
+ module_name = words[1];
+ } else {
+ module_name = NULL;
+ }
+ list = MR_all_type_class_decl_infos();
+ count = 0;
+ MR_for_dlist(element_ptr, list) {
+ type_class_decl_info = (MR_TypeClassDeclInfo *)
+ MR_dlist_data(element_ptr);
+ if (module_name != NULL && strcmp(module_name,
+ type_class_decl_info->MR_tcd_info_decl->
+ MR_tc_decl_id->MR_tc_id_module_name) != 0)
+ {
+ continue;
+ }
+
+ if (count > 0) {
+ fprintf(MR_mdb_out, "\n");
+ }
+ MR_print_class_decl_info(MR_mdb_out,
+ type_class_decl_info, print_methods,
+ print_instances);
+ count++;
+ }
+
+ fprintf(MR_mdb_out, "\nnumber of type classes ");
+ if (module_name == NULL) {
+ fprintf(MR_mdb_out, "in the program: %d\n", count);
+ } else {
+ fprintf(MR_mdb_out, "in module %s: %d\n",
+ module_name, count);
+ }
+ } else {
+ MR_trace_usage("developer", "class_decl");
+ }
+
+ return KEEP_INTERACTING;
+}
+
+static void
+MR_print_type_ctor_info(FILE *fp, MR_TypeCtorInfo type_ctor_info,
+ MR_bool print_rep, MR_bool print_functors)
+{
+ MR_TypeCtorRep rep;
+ MR_EnumFunctorDesc *enum_functor;
+ MR_DuFunctorDesc *du_functor;
+ MR_MaybeResAddrFunctorDesc *maybe_res_functor;
+ MR_NotagFunctorDesc *notag_functor;
+ int num_functors;
+ int i;
+
+ fprintf(fp, "type constructor %s.%s/%d",
+ type_ctor_info->MR_type_ctor_module_name,
+ type_ctor_info->MR_type_ctor_name,
+ type_ctor_info->MR_type_ctor_arity);
+
+ rep = MR_type_ctor_rep(type_ctor_info);
+ if (print_rep) {
+ fprintf(fp, ": %s\n", MR_ctor_rep_name[rep]);
+ } else {
+ fprintf(fp, "\n");
+ }
+
+ if (print_functors) {
+ num_functors = type_ctor_info->MR_type_ctor_num_functors;
+ switch (rep) {
+ case MR_TYPECTOR_REP_ENUM:
+ case MR_TYPECTOR_REP_ENUM_USEREQ:
+ for (i = 0; i < num_functors; i++) {
+ enum_functor = type_ctor_info->
+ MR_type_ctor_functors.
+ MR_functors_enum[i];
+ if (i > 0) {
+ fprintf(fp, ", ");
+ }
+ fprintf(fp, "%s/0",
+ enum_functor->
+ MR_enum_functor_name);
+ }
+ fprintf(fp, "\n");
+ break;
+
+ case MR_TYPECTOR_REP_DU:
+ case MR_TYPECTOR_REP_DU_USEREQ:
+ for (i = 0; i < num_functors; i++) {
+ du_functor = type_ctor_info->
+ MR_type_ctor_functors.
+ MR_functors_du[i];
+ if (i > 0) {
+ fprintf(fp, ", ");
+ }
+ fprintf(fp, "%s/%d",
+ du_functor->
+ MR_du_functor_name,
+ du_functor->
+ MR_du_functor_orig_arity);
+ }
+ fprintf(fp, "\n");
+ break;
+
+ case MR_TYPECTOR_REP_RESERVED_ADDR:
+ case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
+ for (i = 0; i < num_functors; i++) {
+ maybe_res_functor = &type_ctor_info->
+ MR_type_ctor_functors.
+ MR_functors_res[i];
+ if (i > 0) {
+ fprintf(fp, ", ");
+ }
+ fprintf(fp, "%s/%d",
+ maybe_res_functor->
+ MR_maybe_res_name,
+ maybe_res_functor->
+ MR_maybe_res_arity);
+ }
+ fprintf(fp, "\n");
+ break;
+
+ case MR_TYPECTOR_REP_NOTAG:
+ case MR_TYPECTOR_REP_NOTAG_USEREQ:
+ case MR_TYPECTOR_REP_NOTAG_GROUND:
+ case MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ:
+ notag_functor = type_ctor_info->
+ MR_type_ctor_functors.
+ MR_functors_notag;
+ fprintf(fp, "%s/1\n",
+ notag_functor->MR_notag_functor_name);
+ break;
+
+ default:
+ break;
+ }
+ }
+}
+
+static void
+MR_print_class_decl_info(FILE *fp, MR_TypeClassDeclInfo *type_class_decl_info,
+ MR_bool print_methods, MR_bool print_instances)
+{
+ MR_TypeClassDecl type_class_decl;
+ const MR_TypeClassId *type_class_id;
+ const MR_TypeClassMethod *method;
+ MR_Instance instance;
+ MR_Dlist *list;
+ MR_Dlist *element_ptr;
+ int num_methods;
+ int i;
+
+ type_class_decl = type_class_decl_info->MR_tcd_info_decl;
+ type_class_id = type_class_decl->MR_tc_decl_id;
+ fprintf(fp, "type class %s.%s/%d\n",
+ type_class_id->MR_tc_id_module_name,
+ type_class_id->MR_tc_id_name,
+ type_class_id->MR_tc_id_arity);
+
+ if (print_methods) {
+ num_methods = type_class_id->MR_tc_id_num_methods;
+ fprintf(fp, "methods: ");
+
+ for (i = 0; i < num_methods; i++) {
+ if (i > 0) {
+ fprintf(fp, ", ");
+ }
+
+ method = &type_class_id->MR_tc_id_methods[i];
+ if (method->MR_tc_method_pred_func == MR_FUNCTION) {
+ fprintf(fp, "func ");
+ } else {
+ fprintf(fp, "pred ");
+ }
+
+ fprintf(fp, "%s/%d",
+ method->MR_tc_method_name,
+ method->MR_tc_method_arity);
+ }
+
+ fprintf(fp, "\n");
+ }
+
+ if (print_instances) {
+ list = type_class_decl_info->MR_tcd_info_instances;
+ MR_for_dlist (element_ptr, list) {
+ instance = (MR_Instance) MR_dlist_data(element_ptr);
+
+ if (instance->MR_tc_inst_type_class != type_class_decl)
+ {
+ MR_fatal_error("instance/type class mismatch");
+ }
+
+ fprintf(fp, "instance ");
+
+ for (i = 0; i < type_class_id->MR_tc_id_arity; i++) {
+ if (i > 0) {
+ fprintf(fp, ", ");
+ }
+
+ MR_print_pseudo_type_info(fp,
+ instance->MR_tc_inst_type_args[i]);
+ }
+
+ fprintf(fp, "\n");
+ }
+ }
+}
+
+static void
+MR_print_pseudo_type_info(FILE *fp, MR_PseudoTypeInfo pseudo)
+{
+ MR_TypeCtorInfo type_ctor_info;
+ MR_PseudoTypeInfo *pseudo_args;
+ int tvar_num;
+ int arity;
+ int i;
+
+ if (MR_PSEUDO_TYPEINFO_IS_VARIABLE(pseudo)) {
+ tvar_num = (int) pseudo;
+ fprintf(fp, "T%d", tvar_num);
+ } else {
+ type_ctor_info = MR_PSEUDO_TYPEINFO_GET_TYPE_CTOR_INFO(pseudo);
+ fprintf(fp, "%s.%s",
+ type_ctor_info->MR_type_ctor_module_name,
+ type_ctor_info->MR_type_ctor_name);
+ if (MR_type_ctor_has_variable_arity(type_ctor_info)) {
+ arity = MR_PSEUDO_TYPEINFO_GET_VAR_ARITY_ARITY(pseudo);
+ pseudo_args = (MR_PseudoTypeInfo *)
+ &pseudo->MR_pti_var_arity_arity;
+ } else {
+ arity = type_ctor_info->MR_type_ctor_arity;
+ pseudo_args = (MR_PseudoTypeInfo *)
+ &pseudo->MR_pti_type_ctor_info;
+ }
+
+ if (type_ctor_info->MR_type_ctor_arity > 0) {
+ fprintf(fp, "(");
+ for (i = 1; i <= arity; i++) {
+ if (i > 1) {
+ fprintf(fp, ", ");
+ }
+
+ MR_print_pseudo_type_info(fp, pseudo_args[i]);
+ }
+ fprintf(fp, ")");
+ }
+ }
+}
+
+static MR_Next
MR_trace_cmd_source(char **words, int word_count, MR_Trace_Cmd_Info *cmd,
MR_Event_Info *event_info, MR_Event_Details *event_details,
MR_Code **jumpaddr)
@@ -5545,6 +5972,82 @@
return MR_TRUE;
}
+static struct MR_option MR_trace_type_ctor_opts[] =
+{
+ { "print-rep", MR_no_argument, NULL, 'r' },
+ { "print-functors", MR_no_argument, NULL, 'f' },
+ { NULL, MR_no_argument, NULL, 0 }
+};
+
+static MR_bool
+MR_trace_options_type_ctor(MR_bool *print_rep, MR_bool *print_functors,
+ char ***words, int *word_count, const char *cat, const char *item)
+{
+ int c;
+
+ MR_optind = 0;
+ while ((c = MR_getopt_long(*word_count, *words, "rf",
+ MR_trace_type_ctor_opts, NULL)) != EOF)
+ {
+ switch (c) {
+
+ case 'f':
+ *print_functors = MR_TRUE;
+ break;
+
+ case 'r':
+ *print_rep = MR_TRUE;
+ break;
+
+ default:
+ MR_trace_usage(cat, item);
+ return MR_FALSE;
+ }
+ }
+
+ *words = *words + MR_optind - 1;
+ *word_count = *word_count - MR_optind + 1;
+ return MR_TRUE;
+}
+
+static struct MR_option MR_trace_class_decl_opts[] =
+{
+ { "print-methods", MR_no_argument, NULL, 'm' },
+ { "print-instances", MR_no_argument, NULL, 'i' },
+ { NULL, MR_no_argument, NULL, 0 }
+};
+
+static MR_bool
+MR_trace_options_class_decl(MR_bool *print_methods, MR_bool *print_instances,
+ char ***words, int *word_count, const char *cat, const char *item)
+{
+ int c;
+
+ MR_optind = 0;
+ while ((c = MR_getopt_long(*word_count, *words, "mi",
+ MR_trace_class_decl_opts, NULL)) != EOF)
+ {
+ switch (c) {
+
+ case 'm':
+ *print_methods = MR_TRUE;
+ break;
+
+ case 'i':
+ *print_instances = MR_TRUE;
+ break;
+
+ default:
+ MR_trace_usage(cat, item);
+ return MR_FALSE;
+ }
+ }
+
+ *words = *words + MR_optind - 1;
+ *word_count = *word_count - MR_optind + 1;
+ return MR_TRUE;
+}
+
static void
MR_trace_usage(const char *cat, const char *item)
/* cat is unused now, but could be used later */
@@ -6412,6 +6915,14 @@
{ "developer", "dd_dd", MR_trace_cmd_dd_dd,
NULL, MR_trace_filename_completer },
{ "developer", "table", MR_trace_cmd_table,
+ NULL, MR_trace_null_completer },
+ { "developer", "type_ctor", MR_trace_cmd_type_ctor,
+ NULL, MR_trace_null_completer },
+ { "developer", "class_decl", MR_trace_cmd_class_decl,
+ NULL, MR_trace_null_completer },
+ { "developer", "all_type_ctors", MR_trace_cmd_all_type_ctors,
+ NULL, MR_trace_null_completer },
+ { "developer", "all_class_decls", MR_trace_cmd_all_class_decls,
NULL, MR_trace_null_completer },
/* End of doc/mdb_command_list. */
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list